Niclas
384 lines
15 KiB
R
384 lines
15 KiB
R
# Load the general quantile function, the loading can be improved later
|
||
# using the here package.
|
||
source(here::here("R", "qinf.R"))
|
||
|
||
# 0. Analytical test case for d = 1 -----------------------------
|
||
#' --------------------------------------------------------------
|
||
#' Fa(y) = ∫ Fv(y - z) fZ(z) dz with Z = a * X
|
||
#' --------------------------------------------------------------
|
||
#' Compute the graphon CDF for a scalar X and scalar coefficient a.
|
||
#'
|
||
#' @param y numeric vector of points where Fa(y) is required.
|
||
#' @param a numeric scalar (coefficient). a != 0.
|
||
#' @param fX function(z) returning the pdf of X (vectorised).
|
||
#' @param Fv function(x) returning the CDF of the noise v (vectorised).
|
||
#' @param lower,upper numeric bounds for the integration over z.
|
||
#' By default they are set to the (practical) support of X
|
||
#' transformed by a. You can tighten them for speed.
|
||
#' @param rel.tol relative tolerance passed to `integrate`.
|
||
#' @return numeric vector of the same length as y.
|
||
#' @examples
|
||
#' ## Example 1: X ~ Gamma(2,1), a = 0.8, v ~ N(0,1)
|
||
#' fX <- function(z) dgamma(z, shape = 2, rate = 1) # pdf of X
|
||
#' Fv <- function(x) pnorm(x, mean = 0, sd = 1) # cdf of v
|
||
#' a <- 0.8
|
||
#' y <- seq(-3, 6, length.out = 200)
|
||
#' Fa_vals <- Fa_one_dim(y, a, fX, Fv)
|
||
#' plot(y, Fa_vals, type = "l", col = "steelblue",
|
||
#' main = "Fa(y) for Gamma X, Normal noise",
|
||
#' xlab = "y", ylab = expression(F[a](y)))
|
||
#'
|
||
#' ## Example 2: both X and v are normal – analytic check
|
||
#' fX2 <- function(z) dnorm(z, mean = 1, sd = 2)
|
||
#' Fv2 <- function(x) pnorm(x, mean = 0, sd = 1)
|
||
#' a2 <- -1.5
|
||
#' y2 <- seq(-5, 8, length.out = 100)
|
||
#' Fa2_num <- Fa_one_dim(y2, a2, fX2, Fv2)
|
||
#' ## analytic result: Y = a*X + v ~ N(a*mu_X, a^2*sd_X^2 + sd_v^2)
|
||
#' muY <- a2 * 1
|
||
#' sdY <- sqrt(a2^2 * 2^2 + 1^2)
|
||
#' Fa2_ana <- pnorm(y2, mean = muY, sd = sdY)
|
||
#' max(abs(Fa2_num - Fa2_ana)) # should be ~ 1e-6
|
||
#' --------------------------------------------------------------
|
||
pgraphon_analytical_1d <- function(y, a, fX, Fv,
|
||
lower = -Inf, upper = Inf,
|
||
rel.tol = .Machine$double.eps^0.5) {
|
||
stopifnot(is.numeric(a), length(a) == 1, a != 0)
|
||
stopifnot(is.function(fX), is.function(Fv))
|
||
stopifnot(is.numeric(y))
|
||
|
||
# pdf of Z = a*X
|
||
fZ <- function(z) {
|
||
# Jacobian |a|^{-1} and argument scaling
|
||
(1 / abs(a)) * fX(z / a)
|
||
}
|
||
|
||
# Helper that integrates for a single y
|
||
one_y <- function(yy) {
|
||
integrand <- function(z) Fv(yy - z) * fZ(z)
|
||
integrate(integrand, lower = lower, upper = upper,
|
||
rel.tol = rel.tol)$value
|
||
}
|
||
|
||
# Vectorised over the whole y vector
|
||
vapply(y, one_y, numeric(1))
|
||
}
|
||
# 1. Distribution Function -----------------------------------------------------
|
||
|
||
#' Empirical Distribution function for the graphon model.
|
||
#'
|
||
#' Computes the empirical expectation
|
||
#' \deqn{E[F_v(y - a^\top X_i)]}
|
||
#' using observed covariate samples \eqn{X_i}. This is done by evaluating the
|
||
#' supplied CDF \code{Fv} at the shifted values \eqn{y - a^\top X_i} and taking
|
||
#' their empirical average. See also Remark 2.1
|
||
#'
|
||
#' @param y Numeric scalar or vector of evaluation points.
|
||
#' @param a Numeric vector. Coefficient vector used to compute the inner products
|
||
#' \eqn{a^\top X_i}. Its length must match the number of columns in
|
||
#' \code{X_matrix}.
|
||
#' @param Fv Function. Cumulative distribution function of the noise variable
|
||
#' \eqn{v} (e.g., \code{pnorm}, \code{pexp}, etc.). Must accept a numeric vector
|
||
#' and return a numeric vector of the same length.
|
||
#' @param X_matrix Numeric matrix of dimension \eqn{n \times p}, where each row
|
||
#' corresponds to an observed covariate vector \eqn{X_i}.
|
||
#'
|
||
#' @return A numeric scalar giving the empirical expectation
|
||
#' \eqn{(1/n) \sum_{i=1}^n F_v(y - a^\top X_i)}.
|
||
#'
|
||
#' @examples
|
||
#' set.seed(1)
|
||
#' X <- matrix(rnorm(100), ncol = 2)
|
||
#' a <- c(1, -0.5)
|
||
#' y <- 0
|
||
#' pgraphon(y, a, pnorm, X)
|
||
#'
|
||
#' @export
|
||
pgraphon <- function(
|
||
y, # scalar
|
||
a, # vector (coefficient vector, can be one-dimensional)
|
||
Fv, # CDF function of the v's (e.g., pnorm, pexp, etc.)
|
||
X_matrix # n x p matrix: each row is X_i
|
||
) {
|
||
## 1.1 Check inputs ==========================================================
|
||
if (ncol(X_matrix) != length(a)) {
|
||
stop("Number of columns in X_matrix must match length of a")
|
||
}
|
||
if (!is.numeric(y)) {
|
||
stop("'y' must be numeric (scalar or vector)")
|
||
}
|
||
if (!is.numeric(a) || !is.vector(a)) {
|
||
stop("'a' must be a numeric vector")
|
||
}
|
||
if (!is.matrix(X_matrix) || !is.numeric(X_matrix)) {
|
||
stop("'X_matrix' must be a numeric matrix")
|
||
}
|
||
if (!is.function(Fv)) {
|
||
stop("'Fv' must be a function (a CDF)")
|
||
}
|
||
## 1.2 Compute the expected value ============================================
|
||
|
||
# Compute a^T X_i as in the paper. Here we switched to the R convention that each
|
||
# observation is a row. The paper assumes that each observation is a vector
|
||
inner_products <- as.vector(X_matrix %*% a) # vector of length n
|
||
|
||
# outer(y, inner_prod, "-") creates an |y| × n matrix where element (j,i)
|
||
# equals y[j] - inner_prod[i].
|
||
dev_mat <- outer(y, inner_products, "-")
|
||
|
||
# Apply CDF Fv to each deviation
|
||
cdf_vals <- Fv(dev_mat)
|
||
|
||
# Row means give the empirical expectation for each y_j
|
||
out <- rowMeans(cdf_vals)
|
||
out
|
||
}
|
||
|
||
# 2. Density Function ----------------------------------------------------------
|
||
|
||
#' Empirical Graphon Density Estimate
|
||
#'
|
||
#' Computes the empirical expectation \eqn{E[f_v(y - a^\top X_i)]} using observed
|
||
#' covariate samples \eqn{X_i}. This serves as an empirical approximation of the
|
||
#' graphon density evaluated at \eqn{y}, where \eqn{f_v} is the density of the
|
||
#' latent variable \eqn{v}. See also Remark 2.1
|
||
#'
|
||
#' @param y Numeric scalar or vector of points at which the density should be
|
||
#' evaluated.
|
||
#' @param a Numeric vector. Coefficient vector used to compute the linear
|
||
#' projection \eqn{a^\top X_i}. Its length must match the number of columns in
|
||
#' \code{X_matrix}.
|
||
#' @param fv Function. Density function of the latent variable \eqn{v} (e.g.,
|
||
#' \code{dnorm}, \code{dexp}). Must accept a numeric vector and return a
|
||
#' numeric vector of the same length.
|
||
#' @param X_matrix Numeric matrix of size \eqn{n \times p}. Each row represents
|
||
#' an observed covariate vector \eqn{X_i}. The number of columns must match the
|
||
#' length of \code{a}.
|
||
#'
|
||
#' @return A numeric scalar giving the empirical average
|
||
#' \eqn{\frac{1}{n} \sum_{i=1}^n f_v(y - a^\top X_i)}.
|
||
#'
|
||
#' @examples
|
||
#' set.seed(1)
|
||
#' X <- matrix(rnorm(50), ncol = 2)
|
||
#' a <- c(1, -0.5)
|
||
#' dgraphon(y = 0.2, a = a, fv = dnorm, X_matrix = X)
|
||
#'
|
||
#' @export
|
||
dgraphon <- function(
|
||
y, # scalar
|
||
a, # vector (coefficient vector, can be )
|
||
fv, # density function of the v's (e.g., dnorm, dexp, etc.)
|
||
X_matrix # n x p matrix: each row is X_i
|
||
) {
|
||
## 2.1 Check inputs ----------------------------------------------------------
|
||
if (!is.numeric(y)) {
|
||
stop("'y' must be numeric (scalar or vector)")
|
||
}
|
||
if (!is.numeric(a) || !is.vector(a)) {
|
||
stop("'a' must be a numeric vector")
|
||
}
|
||
if (!is.matrix(X_matrix) || !is.numeric(X_matrix)) {
|
||
stop("'X_matrix' must be a numeric matrix")
|
||
}
|
||
if (ncol(X_matrix) != length(a)) {
|
||
stop("Number of columns in X_matrix must match length of a")
|
||
}
|
||
if (!is.function(fv)) {
|
||
stop("'fv' must be a function (a density)")
|
||
}
|
||
|
||
## 1.2 Compute the expected value ============================================
|
||
|
||
# Compute a^T X_i as in the paper. Here we switched to the R convention that each
|
||
# observation is a row. The paper assumes that each observation is a vector
|
||
inner_products <- as.vector(X_matrix %*% a) # vector of length n
|
||
|
||
# outer(y, inner_prod, "-") creates an |y| × n matrix where element (j,i)
|
||
# equals y[j] - inner_prod[i].
|
||
dev_mat <- outer(y, inner_products, "-")
|
||
|
||
# Apply the density function to each y[j]
|
||
dens_vals <- fv(dev_mat)
|
||
|
||
# Row means give the empirical expectation for each y_j
|
||
out <- rowMeans(dens_vals)
|
||
out
|
||
}
|
||
|
||
# 3. Quantile Function ---------------------------------------------------------
|
||
|
||
#' Quantile of the (empirical or analytic) graphon distribution
|
||
#'
|
||
#' If the covariate matrix has a single column and the coefficient vector
|
||
#' has length 1, the function can use an *analytic* CDF (provided the user
|
||
#' supplies the pdf of the covariate via `fX`). Otherwise it falls back to the
|
||
#' original empirical estimator `pgraphon`.
|
||
#'
|
||
#' @param p Numeric vector of probabilities in \eqn{[0,1]}.
|
||
#' @param a Numeric coefficient vector (length = ncol(X_matrix)).
|
||
#' @param Fv Function. CDF of the latent variable $v$ (vectorised).
|
||
#' @param X_matrix Numeric matrix of size $n\times p$; each row is an observation.
|
||
#' @param fX Optional function(z) returning the *known* pdf of the *scalar*
|
||
#' covariate when `ncol(X_matrix)==1 && length(a)==1`. If supplied,
|
||
#' the analytic CDF `pgraphon_analytical_1d` is used.
|
||
#' @param lower,upper Numeric bounds for the root‑finding algorithm.
|
||
#' @param tol Numeric tolerance for the bisection inside `qinf`.
|
||
#' @param max.iter Maximum number of bisection iterations.
|
||
#' @param ... Additional arguments passed to the internal CDF (`pgraphon` or the
|
||
#' analytic version). For the analytic case you may want to pass
|
||
#' `lower`, `upper`, or `rel.tol`.
|
||
#' @return Numeric vector of quantiles, named by the probabilities.
|
||
#' @examples
|
||
#' ## 1. Empirical case
|
||
#' set.seed(123)
|
||
#' X <- matrix(rnorm(200), ncol = 2)
|
||
#' a <- c(0.7, -0.3)
|
||
#' qgraphon(p = c(0.25, 0.5, 0.75), a = a,
|
||
#' Fv = pnorm, X_matrix = X)
|
||
#'
|
||
#' ## 2. Analytic 1‑D case
|
||
#' ## X ~ Gamma(2,1), a = 0.8, v ~ N(0,1)
|
||
#' fX <- function(z) dgamma(z, shape = 2, rate = 1)
|
||
#' a1 <- 0.8
|
||
#' X1 <- matrix(rnorm(100), ncol = 1) # dummy – not used by the analytic branch
|
||
#' qgraphon(p = c(0.1, 0.5, 0.9), a = a1,
|
||
#' Fv = pnorm, X_matrix = X1,
|
||
#' fX = fX, lower = -10, upper = 20)
|
||
#' @export
|
||
qgraphon <- function(p, a, Fv, X_matrix,
|
||
fX = NULL, # <- new optional argument
|
||
lower = -Inf, upper = Inf,
|
||
tol = .Machine$double.eps^0.5,
|
||
max.iter = 100, ...) {
|
||
|
||
## ---- input checks -------------------------------------------------
|
||
if (!is.numeric(p) || any(is.na(p))) {
|
||
stop("'p' must be a numeric vector without NA values")
|
||
}
|
||
if (any(p < 0 | p > 1)) {
|
||
stop("All probabilities in 'p' must lie in [0, 1]")
|
||
}
|
||
if (!is.numeric(a) || !is.vector(a)) {
|
||
stop("'a' must be a numeric vector")
|
||
}
|
||
if (!is.matrix(X_matrix) || !is.numeric(X_matrix)) {
|
||
stop("'X_matrix' must be a numeric matrix")
|
||
}
|
||
if (ncol(X_matrix) != length(a)) {
|
||
stop("Number of columns of 'X_matrix' (", ncol(X_matrix),
|
||
") must equal length of 'a' (", length(a), ")")
|
||
}
|
||
if (!is.function(Fv)) {
|
||
stop("'Fv' must be a function (the CDF of the latent variable)")
|
||
}
|
||
|
||
## ---- decide which CDF to use --------------------------------------
|
||
use_analytic <- (ncol(X_matrix) == 1L) && (length(a) == 1L) && (!is.null(fX))
|
||
|
||
if (use_analytic) {
|
||
# Build a *wrapper* that has the same signature as pgraphon()
|
||
# (y, a, Fv, X_matrix, ...) so that qinf() can call it unchanged.
|
||
analytic_cdf <- function(y, a, Fv, X_matrix, ...) {
|
||
# X_matrix is ignored – the distribution of X is supplied via fX
|
||
pgraphon_analytical_1d(y = y,
|
||
a = a,
|
||
fX = fX,
|
||
Fv = Fv,
|
||
lower = lower,
|
||
upper = upper,
|
||
rel.tol = tol,
|
||
...)
|
||
}
|
||
CDF_to_use <- analytic_cdf
|
||
} else {
|
||
# Fall back to the empirical estimator
|
||
CDF_to_use <- pgraphon
|
||
}
|
||
|
||
## ---- call the generic quantile routine ----------------------------
|
||
out <- qinf(F = CDF_to_use,
|
||
p = p,
|
||
lower = lower,
|
||
upper = upper,
|
||
tol = tol,
|
||
max.iter = max.iter,
|
||
a = a,
|
||
X_matrix = X_matrix,
|
||
Fv = Fv,
|
||
...) # forward any extra arguments (e.g., rel.tol)
|
||
|
||
names(out) <- as.character(p)
|
||
out
|
||
}
|
||
|
||
# 4. Create conditional density ------------------------------------------------
|
||
|
||
#' Create a Conditional Density Function for the Graphon Model.
|
||
#'
|
||
#' This function constructs and returns another function that computes the
|
||
#' conditional density of the graphon model at specified values.
|
||
#' The returned function takes inputs \code{u} (probabilities) and \code{x}
|
||
#' (a scalar covariate value) and evaluates the graphon-based conditional
|
||
#' density using the supplied coefficient vector \code{a}, the density
|
||
#' \code{fv}, the distribution function \code{Fv}, and the empirical sample
|
||
#' \code{X_matrix}.
|
||
#'
|
||
#' @param a Numeric vector. Coefficient vector used in the graphon model; must
|
||
#' have length equal to the number of columns in \code{X_matrix}.
|
||
#' @param fv Function. Density function of the latent variable \eqn{v}
|
||
#' (e.g., \code{dnorm}, \code{dexp}).
|
||
#' @param Fv Function. Distribution function (CDF) corresponding to \code{fv}
|
||
#' (e.g., \code{pnorm}, \code{pexp}).
|
||
#' @param X_matrix Numeric matrix. An \eqn{n \times p} matrix of covariates
|
||
#' \eqn{X_i}, where each row corresponds to an observation.
|
||
#'
|
||
#' @return A function of two arguments \code{u} and \code{x}.
|
||
#' The returned function is vectorized in \code{u} and returns the conditional
|
||
#' density:
|
||
#' \deqn{ f_{U \mid X}(u \mid x) = \frac{f_v(q(u) - a^\top x)}{
|
||
#' \mathbb{E}[f_v(q(u) - a^\top X_i)] },
|
||
#' }
|
||
#' where \eqn{q(u)} is computed via \code{qgraphon()}.
|
||
#'
|
||
#' @details
|
||
#' Internally, the function constructs a scalar evaluator
|
||
#' \code{scalar_conditional_density()} that computes the conditional density for a
|
||
#' single value of \code{u}.
|
||
#' A wrapper function \code{conditional_density()} then applies this scalar
|
||
#' function to each element of the input vector \code{u}.
|
||
#'
|
||
#' Note: the function relies on the existence of \code{qgraphon()},
|
||
#' \code{pgraphon()}, and \code{dgraphon()} in the user's environment.
|
||
#'
|
||
#' @examples
|
||
#' \dontrun{
|
||
#' a <- c(1, -0.5)
|
||
#' fv <- dnorm
|
||
#' Fv <- pnorm
|
||
#' X_matrix <- matrix(rnorm(200), ncol = 2)
|
||
#'
|
||
#' cond_dens <- create_cond_density(a, fv, Fv, X_matrix)
|
||
#' cond_dens(c(0.2, 0.5, 0.8), x = 1.0)
|
||
#' }
|
||
#'
|
||
#' @export
|
||
create_cond_density <- function(
|
||
a,
|
||
fv,
|
||
Fv,
|
||
X_matrix){
|
||
|
||
scalar_conditional_density <-function(u, x) {
|
||
q_a <- qgraphon(u, a, Fv, X_matrix)
|
||
num <- fv(q_a - x %*% a)
|
||
den <- dgraphon(q_a, a, fv, X_matrix)
|
||
num / den
|
||
}
|
||
|
||
conditional_density <- function(u, x) {
|
||
vapply(u, scalar_conditional_density, numeric(1), x = x)
|
||
}
|
||
|
||
return(conditional_density)
|
||
} |