Niclas
339 lines
13 KiB
R
339 lines
13 KiB
R
# Function for creating functions
|
||
|
||
source(here::here("R", "qinf.R"))
|
||
source(here::here("R", "graphon_distribution.R"))
|
||
|
||
#' Factory for a Graphon CDF (empirical or analytical)
|
||
#'
|
||
#' `make_distribution_func()` builds a **callable CDF** that can be used in
|
||
#' downstream code (e.g., for simulation, inference, or plotting).
|
||
#' The function works in two mutually exclusive modes:
|
||
#'
|
||
#' * **Empirical mode** – the CDF is estimated from observed covariates
|
||
#' `X_matrix` and a noise CDF `Fv`. For each evaluation point `y` the
|
||
#' expectation \eqn{E[F_v(y - a^\top X_i)]} is approximated by the empirical
|
||
#' average over the rows of `X_matrix`.
|
||
#' * **Analytical mode** – the user supplies a pre‑computed analytical
|
||
#' function `Fa(y)` (e.g., a closed‑form expression for \eqn{F_a(y) = P( X\cdot a + v \leq y)}.
|
||
#' The returned function simply forwards its argument to `Fa`.
|
||
#'
|
||
#' Exactly **one** of the two mode specifications must be provided; otherwise
|
||
#' an informative error is thrown.
|
||
#'
|
||
#' @param a Numeric vector (or scalar) of coefficients. Required only in the
|
||
#' empirical mode. Its length must match the number of columns of
|
||
#' `X_matrix`.
|
||
#' @param X_matrix Numeric matrix (`n × p`) of observed covariates. Required
|
||
#' only in the empirical mode. Each row corresponds to an observation
|
||
#' \eqn{X_i}.
|
||
#' @param Fv Function. Cumulative distribution function of the noise variable
|
||
#' `v` (e.g., `pnorm`, `pexp`). Must be vectorised and is required only in
|
||
#' the empirical mode.
|
||
#' @param Fa Function. Analytical expression for the graphon CDF
|
||
#' \eqn{F_a(y)}. Required only in the analytical mode. Must be vectorised.
|
||
#'
|
||
#' @return A **function** `cdf(y)` that evaluates the graphon CDF at the
|
||
#' supplied numeric vector or scalar `y`. The returned function is fully
|
||
#' vectorised and performs input validation on each call.
|
||
#'
|
||
#' @details
|
||
#' * **Empirical mode**
|
||
#' The inner products \eqn{a^\top X_i} are pre‑computed once for efficiency.
|
||
#' For a vector of evaluation points `y`, the function builds an
|
||
#' \eqn{|y| \times n} matrix of deviations `y - a^\top X_i`, applies the noise
|
||
#' CDF `Fv` element‑wise, and returns the row means (i.e., the empirical
|
||
#' expectation).
|
||
#' * **Analytical mode**
|
||
#' The supplied `Fa` is assumed to already implement the desired CDF; the
|
||
#' wrapper simply validates its input and forwards the call via `vapply`
|
||
#' to guarantee a numeric return of the same length as `y`.
|
||
#'
|
||
#' @examples
|
||
#' ## -----------------------------------------------------------------
|
||
#' ## Empirical mode ----------------------------------------------------
|
||
#' set.seed(42)
|
||
#' X <- matrix(rnorm(200), ncol = 2) # 100 observations, p = 2
|
||
#' a <- c(1, -0.5)
|
||
#' emp_cdf <- make_distribution_func(a = a, X_matrix = X, Fv = pnorm)
|
||
#' emp_cdf(seq(-3, 3, length.out = 50))
|
||
#'
|
||
#' ## Analytical mode --------------------------------------------------
|
||
#' ## Example: closed‑form CDF for Y = a*X + V where X ~ Gamma(2,1),
|
||
#' ## V ~ N(0,1) and a = 0.8
|
||
#' fX <- function(z) dgamma(z, shape = 2, rate = 1) # pdf of X
|
||
#' Fv <- function(x) pnorm(x, mean = 0, sd = 1) # CDF of V
|
||
#' a2 <- 0.8
|
||
#' ## Analytic CDF (normal convolution)
|
||
#' Fa <- function(y) {
|
||
#' muY <- a2 * 2 # E[X] = shape/rate = 2
|
||
#' sdY <- sqrt(a2^2 * 2 + 1) # Var(Y) = a^2*Var(X) + Var(V)
|
||
#' pnorm(y, mean = muY, sd = sdY)
|
||
#' }
|
||
#' ana_cdf <- make_distribution_func(Fa = Fa)
|
||
#' ana_cdf(seq(-3, 6, length.out = 100))
|
||
#'
|
||
#' @export
|
||
make_distribution_func <- function(a=NULL, X_matrix=NULL, Fv=NULL, Fa=NULL){
|
||
# ----------------------------------------------------------------
|
||
# 1. Switch between empirical and analytical mode
|
||
# ---------------------------------------------------------------
|
||
analytical_mode <- !is.null(Fa)
|
||
empirical_mode <- all(!is.null(X_matrix), !is.null(Fv), !is.null(a))
|
||
|
||
if(xor(analytical_mode, empirical_mode) == FALSE){
|
||
stop("Provide either the arguments for the empiral mode or analytical mode.
|
||
See documentation for details.")
|
||
}
|
||
|
||
# ------------------------------------------------------
|
||
# Empirical mode
|
||
# ------------------------------------------------------
|
||
if(empirical_mode) {
|
||
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 equal length of `a`.")
|
||
}
|
||
if (!is.function(Fv)) {
|
||
stop("'Fv' must be a function (a CDF).")
|
||
}
|
||
|
||
# Pre‑compute the inner products aᵀX_i once (vectorised)
|
||
inner_prod <- as.vector(X_matrix %*% a) # length n
|
||
|
||
# Return a function that only needs y
|
||
cdf <- function(y) {
|
||
if (!is.numeric(y)) {
|
||
stop("'y' must be numeric (scalar or vector).")
|
||
}
|
||
# Compute matrix of y - aᵀX_i
|
||
dev_mat <- outer(y, inner_prod, "-")
|
||
# Apply the noise CDF and average over rows
|
||
rowMeans(Fv(dev_mat))
|
||
}
|
||
|
||
return(cdf)
|
||
} else {
|
||
# -------------------------------------------------
|
||
# Analytical mode
|
||
# ------------------------------------------------
|
||
# input validation
|
||
|
||
if (!is.function(Fa)){
|
||
stop("`Fa` must be a function!")
|
||
}
|
||
|
||
cdf <- function(y) {
|
||
if (!is.numeric(y)) {
|
||
stop("'y' must be numeric (scalar or vector).")
|
||
}
|
||
vapply(y, Fa, numeric(1))
|
||
}
|
||
|
||
return(cdf)
|
||
}
|
||
}
|
||
|
||
|
||
#' Factory for a Graphon **density** function (empirical or analytical)
|
||
#'
|
||
#' `make_density_func()` builds a **callable density** that can be used in
|
||
#' simulation, likelihood evaluation, or plotting. The function operates in
|
||
#' two mutually exclusive modes:
|
||
#'
|
||
#' * **Empirical mode** – the density is estimated from observed covariates
|
||
#' `X_matrix` and a noise density `fv`. For each evaluation point `y` the
|
||
#' expectation \eqn{E[f_v(y - a^\top X_i)]} is approximated by the empirical
|
||
#' average over the rows of `X_matrix`.
|
||
#' * **Analytical mode** – the user supplies a pre‑computed analytical density
|
||
#' function `fa(y)`. The returned function simply forwards its argument to
|
||
#' `fa`.
|
||
#'
|
||
#' Exactly **one** of the two mode specifications must be provided; otherwise
|
||
#' an informative error is raised.
|
||
#'
|
||
#' @param a Numeric vector (or scalar) of coefficients. Required only in the
|
||
#' empirical mode. Its length must match the number of columns of
|
||
#' `X_matrix`.
|
||
#' @param X_matrix Numeric matrix (`n × p`) of observed covariates. Required
|
||
#' only in the empirical mode. Each row corresponds to an observation
|
||
#' \eqn{X_i}.
|
||
#' @param fv Function. Density of the noise variable `v` (e.g., `dnorm`,
|
||
#' `dgamma`). Must be vectorised and is required only in the empirical mode.
|
||
#' @param fa Function. Analytical expression for the graphon density
|
||
#' \eqn{f_a(y)}. Required only in the analytical mode. Must be vectorised.
|
||
#'
|
||
#' @return A **function** `dens(y)` that evaluates the graphon density at the
|
||
#' supplied numeric vector or scalar `y`. The returned function is fully
|
||
#' vectorised and performs input validation on each call.
|
||
#'
|
||
#' @details
|
||
#' * **Empirical mode**
|
||
#' The inner products \eqn{a^\top X_i} are pre‑computed once for efficiency.
|
||
#' For a vector of evaluation points `y`, the function builds an
|
||
#' \eqn{|y| \times n} matrix of deviations `y - a^\top X_i`, applies the noise
|
||
#' density `fv` element‑wise, and returns the row means (i.e., the empirical
|
||
#' expectation).
|
||
#' * **Analytical mode**
|
||
#' The supplied `fa` is assumed to already implement the desired density; the
|
||
#' wrapper validates its input and forwards the call via `vapply` to guarantee
|
||
#' a numeric return of the same length as `y`.
|
||
#'
|
||
#' @examples
|
||
#' ## -----------------------------------------------------------------
|
||
#' ## Empirical mode ----------------------------------------------------
|
||
#' set.seed(123)
|
||
#' X <- matrix(rnorm(200), ncol = 2) # 100 observations, p = 2
|
||
#' a <- c(1, -0.5)
|
||
#' ## Noise density: standard normal
|
||
#' emp_dens <- make_density_func(a = a, X_matrix = X, fv = dnorm)
|
||
#' emp_dens(seq(-3, 3, length.out = 50))
|
||
#'
|
||
#' ## Analytical mode --------------------------------------------------
|
||
#' ## Example: closed‑form density for Y = a*X + V where
|
||
#' ## X ~ Gamma(2,1), V ~ N(0,1) and a = 0.8
|
||
#' a2 <- 0.8
|
||
#' fa <- function(y) {
|
||
#' ## Convolution of Gamma and Normal does not have a simple closed form,
|
||
#' ## but for illustration we use the normal approximation:
|
||
#' muY <- a2 * 2 # E[X] = shape/rate = 2
|
||
#' sdY <- sqrt(a2^2 * 2 + 1) # Var(Y) = a^2*Var(X) + Var(V)
|
||
#' dnorm(y, mean = muY, sd = sdY)
|
||
#' }
|
||
#' ana_dens <- make_density_func(fa = fa)
|
||
#' ana_dens(seq(-3, 6, length.out = 100))
|
||
#'
|
||
#' @export
|
||
make_density_func <- function(a=NULL, X_matrix=NULL, fv=NULL, fa=NULL){
|
||
# ----------------------------------------------------------------
|
||
# 1. Switch between empirical and analytical mode
|
||
# ---------------------------------------------------------------
|
||
analytical_mode <- !is.null(fa)
|
||
empirical_mode <- all(!is.null(X_matrix), !is.null(fv), !is.null(a))
|
||
|
||
if(xor(analytical_mode, empirical_mode) == FALSE){
|
||
stop("Provide either the arguments for the empiral mode or analytical mode.
|
||
See documentation for details.")
|
||
}
|
||
|
||
# ------------------------------------------------------
|
||
# Empirical mode
|
||
# ------------------------------------------------------
|
||
if(empirical_mode) {
|
||
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 equal length of `a`.")
|
||
}
|
||
if (!is.function(Fv)) {
|
||
stop("'Fv' must be a function (a density).")
|
||
}
|
||
|
||
# Pre‑compute the inner products aᵀX_i once (vectorised)
|
||
inner_prod <- as.vector(X_matrix %*% a) # length n
|
||
|
||
# Return a function that only needs y
|
||
cdf <- function(y) {
|
||
if (!is.numeric(y)) {
|
||
stop("'y' must be numeric (scalar or vector).")
|
||
}
|
||
# Compute matrix of y - aᵀX_i
|
||
dev_mat <- outer(y, inner_prod, "-")
|
||
# Apply the noise CDF and average over rows
|
||
rowMeans(fv(dev_mat))
|
||
}
|
||
|
||
return(cdf)
|
||
} else {
|
||
# -------------------------------------------------
|
||
# Analytical mode
|
||
# ------------------------------------------------
|
||
# input validation
|
||
|
||
if (!is.function(fa)){
|
||
stop("`fa` must be a function!")
|
||
}
|
||
|
||
cdf <- function(y) {
|
||
if (!is.numeric(y)) {
|
||
stop("'y' must be numeric (scalar or vector).")
|
||
}
|
||
vapply(y, fa, numeric(1))
|
||
}
|
||
|
||
return(cdf)
|
||
}
|
||
}
|
||
|
||
#' Factory for a Quantile Function from a Cumulative Distribution Function
|
||
#'
|
||
#' `make_quantile_function()` builds a **quantile (inverse CDF) function** by
|
||
#' wrapping the root‑finding routine `qinf()`. The returned function accepts a
|
||
#' probability (or a vector of probabilities) `p` and returns the corresponding
|
||
#' quantile(s) of the distribution defined by the supplied CDF `cdf`.
|
||
#'
|
||
#' @param cdf Function. A cumulative distribution function that takes a numeric
|
||
#' argument `x` and returns \eqn{F(x) \in [0,1]}. The function must be
|
||
#' **monotone non‑decreasing** and vectorised.
|
||
#' @param lower Numeric. Lower bound of the search interval for the root‑finding
|
||
#' algorithm. Defaults to $-\infty$ (practically the left‑most support of
|
||
#' the distribution).
|
||
#' @param upper Numeric. Upper bound of the search interval. Defaults to
|
||
#' $\infty$ (right‑most support).
|
||
#' @param tol Numeric. Relative tolerance passed to `qinf()`. The default is
|
||
#' `sqrt(.Machine$double.eps)`, which provides double‑precision accuracy.
|
||
#' @param max.iter Integer. Maximum number of iterations allowed in `qinf()`.
|
||
#' The default (`100`) is generous for most smooth CDFs.
|
||
#'
|
||
#' @return A **function** `q(p)` that takes a numeric probability (or vector of
|
||
#' probabilities) `p` with values in $[0,1]$ and returns the corresponding
|
||
#' quantile(s). The output is named with the character representation of the
|
||
#' input probabilities.
|
||
#'
|
||
#' @details
|
||
#' The heavy lifting is performed by `qinf()`, which solves for the root of
|
||
#' \eqn{F(x) - p = 0}` using a bracketing method (e.g., bisection or Brent’s
|
||
#' algorithm). `make_quantile_function()` simply captures the user‑specified
|
||
#' arguments and returns a thin wrapper that forwards them to `qinf()`. This
|
||
#' design makes it easy to generate quantile functions for custom CDFs without
|
||
#' having to rewrite the root‑finding code each time.
|
||
#'
|
||
#' @examples
|
||
#' ## -----------------------------------------------------------------
|
||
#' ## Normal distribution (using the built‑in CDF)
|
||
#' qnorm_custom <- make_quantile_function(cdf = pnorm,
|
||
#' lower = -10, upper = 10)
|
||
#' qnorm_custom(c(0.025, 0.5, 0.975))
|
||
#'
|
||
#' ## Gamma distribution – custom CDF defined on the fly
|
||
#' my_gamma_cdf <- function(x) pgamma(x, shape = 2, rate = 1)
|
||
#' qgamma_custom <- make_quantile_function(cdf = my_gamma_cdf,
|
||
#' lower = 0, upper = 20)
|
||
#' qgamma_custom(c(0.1, 0.5, 0.9))
|
||
#'
|
||
#' ## Verify against the base quantile function
|
||
#' all.equal(qnorm_custom(0.8), qnorm(0.8))
|
||
#'
|
||
#' @importFrom stats pnorm pgamma
|
||
#' @export
|
||
make_quantile_function <- function(cdf, lower = -Inf, upper = Inf,
|
||
tol = .Machine$double.eps^0.5,
|
||
max.iter = 100) {
|
||
|
||
quantile_function <- function(p) {
|
||
out <- qinf(F = cdf,
|
||
p = p,
|
||
lower = lower,
|
||
upper = upper,
|
||
tol = tol,
|
||
max.iter = max.iter)
|
||
names(out) <- as.character(p)
|
||
out
|
||
}
|
||
|
||
return(quantile_function)
|
||
}
|
||
|