From dd3c3e4b81b18be4ee5413849d9e0c0eb400bc42 Mon Sep 17 00:00:00 2001 From: Niclas Date: Fri, 16 Jan 2026 19:31:08 +0100 Subject: [PATCH] initial commit --- .Rprofile | 1 + GraphonSimulation.Rproj | 13 + R/graphon_distribution.R | 324 +++++++++ R/qinf.R | 146 ++++ R/singular_values.R | 192 ++++++ renv.lock | 68 ++ renv/.gitignore | 7 + renv/activate.R | 1403 ++++++++++++++++++++++++++++++++++++++ renv/settings.json | 20 + 9 files changed, 2174 insertions(+) create mode 100644 .Rprofile create mode 100644 GraphonSimulation.Rproj create mode 100644 R/graphon_distribution.R create mode 100644 R/qinf.R create mode 100644 R/singular_values.R create mode 100644 renv.lock create mode 100644 renv/.gitignore create mode 100644 renv/activate.R create mode 100644 renv/settings.json diff --git a/.Rprofile b/.Rprofile new file mode 100644 index 0000000..81b960f --- /dev/null +++ b/.Rprofile @@ -0,0 +1 @@ +source("renv/activate.R") diff --git a/GraphonSimulation.Rproj b/GraphonSimulation.Rproj new file mode 100644 index 0000000..8e3c2eb --- /dev/null +++ b/GraphonSimulation.Rproj @@ -0,0 +1,13 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX diff --git a/R/graphon_distribution.R b/R/graphon_distribution.R new file mode 100644 index 0000000..9587847 --- /dev/null +++ b/R/graphon_distribution.R @@ -0,0 +1,324 @@ +# Load the general quantile function, the loading can be improved later +# using the here package. +source("R/qinf.R") + + +# 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 + # With sapply we do not have to assume that Fv is vectorized + cdf_values <- sapply(dev_mat, Fv) + + # 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] + # With sapply we do not have to assume that fv is vectorized + dens_vals <- sapply(dev_mat, fv) + + # Row means give the empirical expectation for each y_j + out <- rowMeans(dens_vals) + out +} + +# 3. Quantile Function --------------------------------------------------------- + +#' Quantile of the empirical graphon distribution +#' +#' This is a thin wrapper around the generic infimum‑type quantile routine +#' \code{qinf()}. It builds the CDF of the graphon, +#' \eqn{p_{\text{graphon}}(x) = \frac{1}{n}\sum_{i=1}^{n}F_v\bigl(x-a^\top X_i\bigr)}, +#' and then finds the quantile(s) for the supplied probability(ies) \code{p}. +#' +#' @param p Numeric vector of probabilities in \eqn{[0,1]}. Values outside this +#' interval are rejected. +#' @param a Numeric coefficient vector. Its length must equal the number of +#' columns of \code{X_matrix}. +#' @param Fv Function. The CDF of the latent variable $v$. It must be +#' vectorised (i.e. accept a numeric vector and return a numeric vector of +#' the same length). Typical examples are \code{pnorm}, \code{pexp}, etc. +#' @param X_matrix Numeric matrix of dimension \eqn{n\times p}. Each row +#' corresponds to an observation $X_i$. +#' @param lower,upper Numeric scalars giving the search interval for the root +#' finder. By default they are set to \code{-Inf} and \code{Inf}. +#' @param tol Numeric tolerance for the bisection algorithm used inside +#' \code{qinf()}. The default is the square‑root of machine epsilon. +#' @param max.iter Maximum number of bisection iterations (safety guard). +#' @param ... Additional arguments that are passed **directly** to the +#' internal CDF \code{pgraphon}. This makes the wrapper flexible – you do not +#' have to list every argument (e.g. \code{a}, \code{X_matrix}, \code{Fv}) +#' explicitly. +#' +#' @return A numeric vector of the same length as \code{p} containing the +#' quantiles. The vector is named by the probabilities. +#' +#' @examples +#' ## ---- simple normal example ------------------------------------------------ +#' set.seed(123) +#' X <- matrix(rnorm(200), ncol = 2) # n = 100, p = 2 +#' a <- c(0.7, -0.3) +#' qgraphon(p = c(0.25, 0.5, 0.75), +#' a = a, +#' Fv = pnorm, +#' X_matrix = X) +#' +#' ## ---- mixture example ------------------------------------------------------ +#' mix_cdf <- function(x, w = 0.4, mu = 0, sigma = 1) { +#' w * (x >= 0) + (1 - w) * pnorm(x, mean = mu, sd = sigma) +#' } +#' qgraphon(p = seq(0, 1, 0.2), +#' a = a, +#' Fv = mix_cdf, +#' X_matrix = X) +#' +#' @export +qgraphon <- function( + p, # probabilities + a, # coefficient vector + Fv, # CDF of the v's + X_matrix, # X_i samples, matrix + lower = -Inf, # lower bound roots + upper = Inf, # upper bound roots + tol = .Machine$double.eps^0.5, # parameter root finding + max.iter = 100) { + + ## 3.1 Check inputs ---------------------------------------------------------- + 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)") + } + + ## 3.2 Call the generic quantile function ------------------------------------ + out <- qinf(F = pgraphon, + p = p, + lower = lower, + upper = upper, + tol = tol, + max.iter = max.iter, + a = a, + X_matrix = X_matrix, + Fv = Fv) + + # Name the result by the probabilities – this mirrors the behaviour of + # base‑R quantile functions (e.g. qnorm, qbeta). + 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) +} \ No newline at end of file diff --git a/R/qinf.R b/R/qinf.R new file mode 100644 index 0000000..bc38249 --- /dev/null +++ b/R/qinf.R @@ -0,0 +1,146 @@ +#' Generic infimum‑type quantile function +#' +#' @param F A function that evaluates the distribution function +#' (CDF). It must be monotone non‑decreasing in its first +#' argument and return values in $0,1$. Additional +#' arguments for the CDF can be supplied via `...`. +#' @param p Numeric vector of probabilities. Values must lie in +#' $0,1$; values outside this range give `NaN`. +#' @param lower Left end of the search interval. By default +#' `-Inf` is used; if the CDF is known to be zero below a +#' finite value you can give that value to speed up the +#' search. +#' @param upper Right end of the search interval. By default +#' `Inf` is used; if the CDF is known to be one above a +#' finite value you can give that value. +#' @param tol Desired absolute tolerance for the quantile. The +#' algorithm stops when the interval width is ≤ `tol`. +#' @param max.iter Maximum number of bisection iterations (safety +#' guard). The default is `1000`. +#' @param ... Additional arguments passed to `F`. +#' +#' @return A numeric vector of the same length as `p` containing the +#' infimum‑type quantiles. +#' @examples +#' ## 1. Continuous normal distribution (compare with qnorm) +#' qinf(pnorm, p = c(0.025, 0.5, 0.975), lower = -10, upper = 10) +#' qnorm(c(0.025, 0.5, 0.975)) +#' +#' ## 2. Discrete distribution: Binomial(10, 0.3) +#' Fbinom <- function(x, size, prob) pbinom(floor(x), size, prob) +#' qinf(Fbinom, p = seq(0, 1, 0.1), size = 10, prob = 0.3) +#' qbinom(seq(0, 1, 0.1), size = 10, prob = 0.3) # built‑in quantile +#' +#' ## 3. Mixed distribution (continuous + point mass at 0) +#' Fmix <- function(x, sigma = 1) { +#' 0.3 * (x >= 0) + 0.7 * pnorm(x, sd = sigma) +#' } +#' qinf(Fmix, p = c(0.1, 0.3, 0.5, 0.9), lower = -5, upper = 5) +#' @export +qinf <- function(F, + p, + lower = -Inf, + upper = Inf, + tol = .Machine$double.eps^0.5, + max.iter = 1000L, + ...) { + + # 1. Input checks ----------------------------------------------------------- + if (!is.function(F)) + stop("'F' must be a function that evaluates a CDF") + if (!is.numeric(p)) + stop("'p' must be numeric") + if (any(is.na(p))) # keep NA positions in the output + warning("NA probabilities supplied – corresponding quantiles will be NA") + if (any(p < 0 | p > 1, na.rm = TRUE)) + stop("probabilities must lie in [0,1]") + + # 2. Helper function for a single probability --------------------------------- + + one_quantile <- function(p_i) { + ## Edge cases: 0 → leftmost point where F(x) >= 0, + ## 1 → rightmost point where F(x) >= 1 + if (is.na(p_i)) return(NA_real_) + if (p_i == 0) { + ## The infimum of the set {x : F(x) >= 0} is the lower bound of the + ## support. If the user gave a finite lower bound we return it, + ## otherwise we try to locate it by moving left until F changes. + if (is.finite(lower)) return(lower) + ## Search leftwards until we see a change in the CDF (or hit -Inf) + x <- 0 + step <- 1 + while (is.finite(x) && F(x, ...) == 0) { + x <- x - step + step <- step * 2 + if (x < -1e12) break # give up – treat as -Inf + } + return(x) + } + if (p_i == 1) { + if (is.finite(upper)) return(upper) + ## Search rightwards until F reaches 1 + x <- 0 + step <- 1 + while (is.finite(x) && F(x, ...) < 1) { + x <- x + step + step <- step * 2 + if (x > 1e12) break + } + return(x) + } + + ## 2.1 Initialise the bracketing interval ================================= + lo <- lower + hi <- upper + + ## If the interval is infinite we first try to find a finite bracket. + ## This is done by exponential expansion from 0 (or from the sign of p) + ## until the CDF straddles p. + if (!is.finite(lo) || !is.finite(hi)) { + # start from 0 (or any convenient point) + centre <- 0 + # expand left if needed + if (!is.finite(lo)) { + step <- 1 + while (F(centre - step, ...) >= p_i) step <- step * 2 + lo <- centre - step + } + # expand right if needed + if (!is.finite(hi)) { + step <- 1 + while (F(centre + step, ...) < p_i) step <- step * 2 + hi <- centre + step + } + } + + ## 2.2 Bisection loop ===================================================== + ## we keep the leftmost point where F(q) >= p + iter <- 0L + while ((hi - lo) > tol && iter < max.iter) { + mid <- (lo + hi) / 2 + fmid <- F(mid, ...) + if (is.na(fmid)) { + ## If the CDF returns NA (e.g. because mid is outside the domain) + ## we shrink the interval towards the side that is known to be + ## finite. + if (is.finite(lo)) hi <- mid else lo <- mid + } else if (fmid >= p_i) { + ## We have reached (or passed) the target probability – move the + ## upper bound leftwards to keep the *infimum*. + hi <- mid + } else { + ## Still below the target – move the lower bound rightwards. + lo <- mid + } + iter <- iter + 1L + } + + ## 2.3 Return the upper bound (the smallest x with F(x) >= p) ============= + hi + } + + # 3. Vectorised call – preserve names / attributes of p --------------------- + out <- vapply(p, one_quantile, numeric(1), USE.NAMES = FALSE) + if (!is.null(names(p))) names(out) <- names(p) + out +} \ No newline at end of file diff --git a/R/singular_values.R b/R/singular_values.R new file mode 100644 index 0000000..41e1f71 --- /dev/null +++ b/R/singular_values.R @@ -0,0 +1,192 @@ +# TODO improve later using the here package +source("R/graphon_distribution.R") + +# 1. Compute the Matrix Q according to (3.1) ----------------------------------- +#' Compute the matrix **Q** +#' +#' This helper builds the matrix \eqn{Q} that appears in equation (3.1) of the +#' graphon‑based model. The routine performs the following steps: +#' 1. Checks that all inputs are of the correct type and dimension. +#' 2. Generates a covariate matrix \eqn{X} of size \eqn{n \times p} using the +#' user‑supplied sampling function `sample_X_fn`. The random seed is +#' handled locally with **`withr::with_seed()`** so the global RNG state is +#' left untouched. +#' 3. Constructs the empirical conditional density of the latent variable +#' \eqn{v} via `create_cond_density()`. +#' 4. Computes the graphon quantiles \eqn{q_k} for a regular grid +#' \eqn{k = 0,1/K,\dots,1}` using the wrapper `qgraphon()`. +#' Each q_k is the quantile of k / K for k = 0, ..., K. +#' 5. Forms the matrix \eqn{Q} whose \eqn{(k,i)}‑th entry is +#' \deqn{F_v\!\bigl(q_{k+1} - a^\top X_i\bigr) - +#' F_v\!\bigl(q_{k} - a^\top X_i\bigr)}, +#' where \eqn{F_v} is the CDF of the latent variable \eqn{v}. The +#' construction is fully vectorised: the outer difference is built with +#' `outer()`, the CDF is applied to the whole matrix at once, and the +#' row‑wise differences are taken with `diff()`. +#' +#' @param seed Integer (or numeric) of length 1. Seed used to initialize the +#' random number generator for reproducible sampling of `X`. +#' @param a Numeric vector of length \eqn{p}. Coefficient vector that +#' multiplies the covariates; its length must equal the number of +#' columns of `X_matrix`. +#' @param n Positive integer. Number of i.i.d. covariate draws to be +#' generated. +#' @param K Positive integer. Number of divisions of the unit interval; +#' the resulting grid has length `K+1`. +#' @param sample_X_fn +#' Function with a single argument `n`. It must return an +#' \eqn{n \times p} matrix (or an object coercible to a matrix) of +#' covariate samples. +#' @param fv Density function of the latent variable \eqn{v}. Must be +#' vectorised (i.e. accept a numeric vector and return a numeric +#' vector of the same length). Typical examples are +#' `dnorm`, `dexp`, …. +#' @param Fv Cumulative distribution function of the latent variable +#' \eqn{v}. Also has to be vectorised. Typical examples are +#' `pnorm`, `pexp`, …. +#' +#' @return A numeric matrix **Q** of dimension `K × n`. The \eqn{j}-th row +#' (for `j = 1,…,K`) contains the increments of the CDF evaluated at +#' the graphon quantiles for each observation `i = 1,…,n`. The matrix +#' can be fed directly into downstream singular‑value or spectral +#' analyses. +#' +#' @details +#' * **Input validation** – The function stops with an informative error if any +#' argument does not meet the required type or dimension constraints. +#' * **Reproducible sampling** – `withr::with_seed()` guarantees that the seed +#' is restored after the call, leaving the user's global RNG untouched. +#' * **Vectorised construction of Q** – +#' \preformatted{ +#' adotX <- as.vector(X %*% a) # n‑vector +#' cdf_mat <- Fv(outer(graphon_quantiles, adotX, "-")) # (K+1) × n +#' Q <- diff(cdf_mat, lag = 1) # K × n +#' } +#' This replaces the double `for`‑loop in the original implementation and +#' yields a speed‑up of roughly an order of magnitude for moderate‑size +#' problems. +#' +#' @seealso +#' \code{\link{create_cond_density}} for the construction of the empirical +#' conditional density, +#' \code{\link{qgraphon}} for the quantile computation, +#' \code{\link{compute_extreme_singular_values}} for a wrapper that also +#' returns the smallest and largest singular values of `Q`. +#' +#' @examples +#' ## Simple reproducible example ------------------------------------------------ +#' set.seed(123) +#' ## a sampling function that returns a 2‑dimensional covariate matrix +#' sample_X <- function(m) matrix(rnorm(m * 2), ncol = 2) +#' +#' ## Compute Q for a normal latent variable +#' Q <- compute_matrix( +#' seed = 42, +#' a = c(1, -0.5), +#' n = 200, +#' K = 100, +#' sample_X_fn = sample_X, +#' fv = dnorm, +#' Fv = pnorm +#' ) +#' dim(Q) # should be 100 × 200 +#' head(Q) # a glimpse at the first few rows +#' +#' @export +compute_matrix <- function( + seed, + a, + n, + K, + sample_X_fn, + fv, + Fv +) { + ## 1.1 Check inputs ========================================================== + if (!is.numeric(seed) || length(seed) != 1) stop("'seed' must be a single number") + if (!is.numeric(a) || !is.vector(a)) stop("'a' must be a numeric vector") + if (!is.numeric(n) || length(n) != 1 || n <= 0) stop("'n' must be a positive integer") + if (!is.numeric(K) || length(K) != 1 || K <= 0) stop("'K' must be a positive integer") + if (!is.function(sample_X_fn)) stop("'sample_X_fn' must be a function") + if (!is.function(fv)) stop("'f_v' must be a function") + if (!is.function(Fv)) stop("'F_v' must be a function") + + ## 1.2 Generate the Matrix X of covariates =================================== + # The withr environment allows us to capsulate the global state like the seed + # and enables a better reproduction + X <- withr::with_seed(seed, { + as.matrix(sample_X_fn(n)) + }) + if (nrow(X) != n) stop("`sample_X_fn` must return exactly `n` rows") + if (ncol(X) != length(a)) { + stop("Number of columns of X (", ncol(X), ") must equal length(a) (", length(a), ")") + } + + ## 1.3 Create conditional density ============================================ + empir_cond_density <- create_cond_density(a, fv, Fv, X) + + ## 1.4 Compute the graphon quantiles ========================================= + k <- seq(0, K) / K + graphon_quantiles <- qgraphon(k, a = a, Fv = Fv, X_matrix = X) + + ## 1.5 Build the matrix Q ==================================================== + inner_products = as.vector(X %*% a) + + # outer(y, x, "-") gives a matrix with entry (j,i) = y[j] - x[i] + # then we apply the CDF `F_v` to the whole matrix at once. + # finally we take the difference of successive rows (j) to obtain the + # increments required by equation (3.1). + cdf_mat <- Fv(outer(graphon_quantiles, inner_products, "-")) # (K +1) x n matrix + Q <- diff(cdf_mat, lag=1) # operates along rows + + Q +} + +# 2. Compute largest and smallest singular value ------------------------------- +# TODO: Possible improvements include +# - use the package RSpectra for large dimensions +# - make a switch which value to choose +# - Include cards for very small singular values + +#' Compute the largest and smallest singular values of a matrix +#' +#' This helper extracts the extreme singular values of a numeric matrix. +#' It uses the base‑R \code{svd()} routine (with the singular vectors +#' suppressed) and returns a list containing the largest singular value and +#' the smallest (non‑zero) singular value. +#' +#' @param M A numeric matrix (or an object coercible to a matrix). The +#' singular values are computed for this matrix. +#' +#' @return A **list** with two components +#' \describe{ +#' \item{largest_singular_value}{The maximum singular value of \code{M}.} +#' \item{smallest_singular_value}{The minimum singular value of \code{M} +#' that is greater than zero. If all singular values are zero, +#' the function returns \code{0}.} +#' } +#' +#' @details +#' The singular value decomposition is performed with \code{svd(M, nu = 0, +#' nv = 0)} so that only the singular values (\code{$d}) are computed; this +#' saves memory because the left and right singular vectors are not needed. +#' +#' @examples +#' ## Small random matrix ---------------------------------------------------- +#' set.seed(123) +#' A <- matrix(rnorm(20), nrow = 4) +#' compute_minmax_sv(A) +#' +#' ## Rank‑deficient matrix (all singular values are zero) -------------------- +#' Z <- matrix(0, nrow = 3, ncol = 3) +#' compute_minmax_sv(Z) +#' +#' @export +compute_minmax_sv <- function(M) { + s <- svd(M, nu=0, nv=0)$d + + list( + largest_singular_value = max(s), + smallest_singular_value = min(s) # smallest non zero singular value + ) +} diff --git a/renv.lock b/renv.lock new file mode 100644 index 0000000..a61e615 --- /dev/null +++ b/renv.lock @@ -0,0 +1,68 @@ +{ + "R": { + "Version": "4.5.1", + "Repositories": [ + { + "Name": "CRAN", + "URL": "https://cloud.r-project.org" + } + ] + }, + "Packages": { + "renv": { + "Package": "renv", + "Version": "1.1.6", + "Source": "Repository", + "Type": "Package", + "Title": "Project Environments", + "Authors@R": "c( person(\"Kevin\", \"Ushey\", role = c(\"aut\", \"cre\"), email = \"kevin@rstudio.com\", comment = c(ORCID = \"0000-0003-2880-7407\")), person(\"Hadley\", \"Wickham\", role = c(\"aut\"), email = \"hadley@rstudio.com\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A dependency management toolkit for R. Using 'renv', you can create and manage project-local R libraries, save the state of these libraries to a 'lockfile', and later restore your library as required. Together, these tools can help make your projects more isolated, portable, and reproducible.", + "License": "MIT + file LICENSE", + "URL": "https://rstudio.github.io/renv/, https://github.com/rstudio/renv", + "BugReports": "https://github.com/rstudio/renv/issues", + "Imports": [ + "utils" + ], + "Suggests": [ + "BiocManager", + "cli", + "compiler", + "covr", + "cpp11", + "curl", + "devtools", + "generics", + "gitcreds", + "jsonlite", + "jsonvalidate", + "knitr", + "miniUI", + "modules", + "packrat", + "pak", + "R6", + "remotes", + "reticulate", + "rmarkdown", + "rstudioapi", + "shiny", + "testthat", + "uuid", + "waldo", + "yaml", + "webfakes" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.3", + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "true", + "Config/testthat/start-first": "bioconductor,python,install,restore,snapshot,retrieve,remotes", + "NeedsCompilation": "no", + "Author": "Kevin Ushey [aut, cre] (ORCID: ), Hadley Wickham [aut] (ORCID: ), Posit Software, PBC [cph, fnd]", + "Maintainer": "Kevin Ushey ", + "Repository": "CRAN" + } + } +} diff --git a/renv/.gitignore b/renv/.gitignore new file mode 100644 index 0000000..0ec0cbb --- /dev/null +++ b/renv/.gitignore @@ -0,0 +1,7 @@ +library/ +local/ +cellar/ +lock/ +python/ +sandbox/ +staging/ diff --git a/renv/activate.R b/renv/activate.R new file mode 100644 index 0000000..4eba67c --- /dev/null +++ b/renv/activate.R @@ -0,0 +1,1403 @@ + +local({ + + # the requested version of renv + version <- "1.1.6" + attr(version, "md5") <- "3036c4b273d882c56e8cdd660ebaf6f0" + attr(version, "sha") <- NULL + + # the project directory + project <- Sys.getenv("RENV_PROJECT") + if (!nzchar(project)) + project <- getwd() + + # use start-up diagnostics if enabled + diagnostics <- Sys.getenv("RENV_STARTUP_DIAGNOSTICS", unset = "FALSE") + if (diagnostics) { + start <- Sys.time() + profile <- tempfile("renv-startup-", fileext = ".Rprof") + utils::Rprof(profile) + on.exit({ + utils::Rprof(NULL) + elapsed <- signif(difftime(Sys.time(), start, units = "auto"), digits = 2L) + writeLines(sprintf("- renv took %s to run the autoloader.", format(elapsed))) + writeLines(sprintf("- Profile: %s", profile)) + print(utils::summaryRprof(profile)) + }, add = TRUE) + } + + # figure out whether the autoloader is enabled + enabled <- local({ + + # first, check config option + override <- getOption("renv.config.autoloader.enabled") + if (!is.null(override)) + return(override) + + # if we're being run in a context where R_LIBS is already set, + # don't load -- presumably we're being run as a sub-process and + # the parent process has already set up library paths for us + rcmd <- Sys.getenv("R_CMD", unset = NA) + rlibs <- Sys.getenv("R_LIBS", unset = NA) + if (!is.na(rlibs) && !is.na(rcmd)) + return(FALSE) + + # next, check environment variables + # prefer using the configuration one in the future + envvars <- c( + "RENV_CONFIG_AUTOLOADER_ENABLED", + "RENV_AUTOLOADER_ENABLED", + "RENV_ACTIVATE_PROJECT" + ) + + for (envvar in envvars) { + envval <- Sys.getenv(envvar, unset = NA) + if (!is.na(envval)) + return(tolower(envval) %in% c("true", "t", "1")) + } + + # enable by default + TRUE + + }) + + # bail if we're not enabled + if (!enabled) { + + # if we're not enabled, we might still need to manually load + # the user profile here + profile <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") + if (file.exists(profile)) { + cfg <- Sys.getenv("RENV_CONFIG_USER_PROFILE", unset = "TRUE") + if (tolower(cfg) %in% c("true", "t", "1")) + sys.source(profile, envir = globalenv()) + } + + return(FALSE) + + } + + # avoid recursion + if (identical(getOption("renv.autoloader.running"), TRUE)) { + warning("ignoring recursive attempt to run renv autoloader") + return(invisible(TRUE)) + } + + # signal that we're loading renv during R startup + options(renv.autoloader.running = TRUE) + on.exit(options(renv.autoloader.running = NULL), add = TRUE) + + # signal that we've consented to use renv + options(renv.consent = TRUE) + + # load the 'utils' package eagerly -- this ensures that renv shims, which + # mask 'utils' packages, will come first on the search path + library(utils, lib.loc = .Library) + + # unload renv if it's already been loaded + if ("renv" %in% loadedNamespaces()) + unloadNamespace("renv") + + # load bootstrap tools + ansify <- function(text) { + if (renv_ansify_enabled()) + renv_ansify_enhanced(text) + else + renv_ansify_default(text) + } + + renv_ansify_enabled <- function() { + + override <- Sys.getenv("RENV_ANSIFY_ENABLED", unset = NA) + if (!is.na(override)) + return(as.logical(override)) + + pane <- Sys.getenv("RSTUDIO_CHILD_PROCESS_PANE", unset = NA) + if (identical(pane, "build")) + return(FALSE) + + testthat <- Sys.getenv("TESTTHAT", unset = "false") + if (tolower(testthat) %in% "true") + return(FALSE) + + iderun <- Sys.getenv("R_CLI_HAS_HYPERLINK_IDE_RUN", unset = "false") + if (tolower(iderun) %in% "false") + return(FALSE) + + TRUE + + } + + renv_ansify_default <- function(text) { + text + } + + renv_ansify_enhanced <- function(text) { + + # R help links + pattern <- "`\\?(renv::(?:[^`])+)`" + replacement <- "`\033]8;;x-r-help:\\1\a?\\1\033]8;;\a`" + text <- gsub(pattern, replacement, text, perl = TRUE) + + # runnable code + pattern <- "`(renv::(?:[^`])+)`" + replacement <- "`\033]8;;x-r-run:\\1\a\\1\033]8;;\a`" + text <- gsub(pattern, replacement, text, perl = TRUE) + + # return ansified text + text + + } + + renv_ansify_init <- function() { + + envir <- renv_envir_self() + if (renv_ansify_enabled()) + assign("ansify", renv_ansify_enhanced, envir = envir) + else + assign("ansify", renv_ansify_default, envir = envir) + + } + + `%||%` <- function(x, y) { + if (is.null(x)) y else x + } + + catf <- function(fmt, ..., appendLF = TRUE) { + + quiet <- getOption("renv.bootstrap.quiet", default = FALSE) + if (quiet) + return(invisible()) + + msg <- sprintf(fmt, ...) + cat(msg, file = stdout(), sep = if (appendLF) "\n" else "") + + invisible(msg) + + } + + header <- function(label, + ..., + prefix = "#", + suffix = "-", + n = min(getOption("width"), 78)) + { + label <- sprintf(label, ...) + n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L) + if (n <= 0) + return(paste(prefix, label)) + + tail <- paste(rep.int(suffix, n), collapse = "") + paste0(prefix, " ", label, " ", tail) + + } + + heredoc <- function(text, leave = 0) { + + # remove leading, trailing whitespace + trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text) + + # split into lines + lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]] + + # compute common indent + indent <- regexpr("[^[:space:]]", lines) + common <- min(setdiff(indent, -1L)) - leave + text <- paste(substring(lines, common), collapse = "\n") + + # substitute in ANSI links for executable renv code + ansify(text) + + } + + bootstrap <- function(version, library) { + + friendly <- renv_bootstrap_version_friendly(version) + section <- header(sprintf("Bootstrapping renv %s", friendly)) + catf(section) + + # try to install renv from cache + md5 <- attr(version, "md5", exact = TRUE) + if (length(md5)) { + pkgpath <- renv_bootstrap_find(version) + if (length(pkgpath) && file.exists(pkgpath)) { + file.copy(pkgpath, library, recursive = TRUE) + return(invisible()) + } + } + + # attempt to download renv + catf("- Downloading renv ... ", appendLF = FALSE) + withCallingHandlers( + tarball <- renv_bootstrap_download(version), + error = function(err) { + catf("FAILED") + stop("failed to download:\n", conditionMessage(err)) + } + ) + catf("OK") + on.exit(unlink(tarball), add = TRUE) + + # now attempt to install + catf("- Installing renv ... ", appendLF = FALSE) + withCallingHandlers( + status <- renv_bootstrap_install(version, tarball, library), + error = function(err) { + catf("FAILED") + stop("failed to install:\n", conditionMessage(err)) + } + ) + catf("OK") + + # add empty line to break up bootstrapping from normal output + catf("") + return(invisible()) + } + + renv_bootstrap_tests_running <- function() { + getOption("renv.tests.running", default = FALSE) + } + + renv_bootstrap_repos <- function() { + + # get CRAN repository + cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") + + # check for repos override + repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) + if (!is.na(repos)) { + + # split on ';' if present + parts <- strsplit(repos, ";", fixed = TRUE)[[1L]] + + # split into named repositories if present + idx <- regexpr("=", parts, fixed = TRUE) + keys <- substring(parts, 1L, idx - 1L) + vals <- substring(parts, idx + 1L) + names(vals) <- keys + + # if we have a single unnamed repository, call it CRAN + if (length(vals) == 1L && identical(keys, "")) + names(vals) <- "CRAN" + + return(vals) + + } + + # check for lockfile repositories + repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity) + if (!inherits(repos, "error") && length(repos)) + return(repos) + + # retrieve current repos + repos <- getOption("repos") + + # ensure @CRAN@ entries are resolved + repos[repos == "@CRAN@"] <- cran + + # add in renv.bootstrap.repos if set + default <- c(FALLBACK = "https://cloud.r-project.org") + extra <- getOption("renv.bootstrap.repos", default = default) + repos <- c(repos, extra) + + # remove duplicates that might've snuck in + dupes <- duplicated(repos) | duplicated(names(repos)) + repos[!dupes] + + } + + renv_bootstrap_repos_lockfile <- function() { + + lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock") + if (!file.exists(lockpath)) + return(NULL) + + lockfile <- tryCatch(renv_json_read(lockpath), error = identity) + if (inherits(lockfile, "error")) { + warning(lockfile) + return(NULL) + } + + repos <- lockfile$R$Repositories + if (length(repos) == 0) + return(NULL) + + keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1)) + vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1)) + names(vals) <- keys + + return(vals) + + } + + renv_bootstrap_download <- function(version) { + + sha <- attr(version, "sha", exact = TRUE) + + methods <- if (!is.null(sha)) { + + # attempting to bootstrap a development version of renv + c( + function() renv_bootstrap_download_tarball(sha), + function() renv_bootstrap_download_github(sha) + ) + + } else { + + # attempting to bootstrap a release version of renv + c( + function() renv_bootstrap_download_tarball(version), + function() renv_bootstrap_download_cran_latest(version), + function() renv_bootstrap_download_cran_archive(version) + ) + + } + + for (method in methods) { + path <- tryCatch(method(), error = identity) + if (is.character(path) && file.exists(path)) + return(path) + } + + stop("All download methods failed") + + } + + renv_bootstrap_download_impl <- function(url, destfile) { + + mode <- "wb" + + # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715 + fixup <- + Sys.info()[["sysname"]] == "Windows" && + substring(url, 1L, 5L) == "file:" + + if (fixup) + mode <- "w+b" + + args <- list( + url = url, + destfile = destfile, + mode = mode, + quiet = TRUE + ) + + if ("headers" %in% names(formals(utils::download.file))) { + headers <- renv_bootstrap_download_custom_headers(url) + if (length(headers) && is.character(headers)) + args$headers <- headers + } + + do.call(utils::download.file, args) + + } + + renv_bootstrap_download_custom_headers <- function(url) { + + headers <- getOption("renv.download.headers") + if (is.null(headers)) + return(character()) + + if (!is.function(headers)) + stopf("'renv.download.headers' is not a function") + + headers <- headers(url) + if (length(headers) == 0L) + return(character()) + + if (is.list(headers)) + headers <- unlist(headers, recursive = FALSE, use.names = TRUE) + + ok <- + is.character(headers) && + is.character(names(headers)) && + all(nzchar(names(headers))) + + if (!ok) + stop("invocation of 'renv.download.headers' did not return a named character vector") + + headers + + } + + renv_bootstrap_download_cran_latest <- function(version) { + + spec <- renv_bootstrap_download_cran_latest_find(version) + type <- spec$type + repos <- spec$repos + + baseurl <- utils::contrib.url(repos = repos, type = type) + ext <- if (identical(type, "source")) + ".tar.gz" + else if (Sys.info()[["sysname"]] == "Windows") + ".zip" + else + ".tgz" + name <- sprintf("renv_%s%s", version, ext) + url <- paste(baseurl, name, sep = "/") + + destfile <- file.path(tempdir(), name) + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (inherits(status, "condition")) + return(FALSE) + + # report success and return + destfile + + } + + renv_bootstrap_download_cran_latest_find <- function(version) { + + # check whether binaries are supported on this system + binary <- + getOption("renv.bootstrap.binary", default = TRUE) && + !identical(.Platform$pkgType, "source") && + !identical(getOption("pkgType"), "source") && + Sys.info()[["sysname"]] %in% c("Darwin", "Windows") + + types <- c(if (binary) "binary", "source") + + # iterate over types + repositories + for (type in types) { + for (repos in renv_bootstrap_repos()) { + + # build arguments for utils::available.packages() call + args <- list(type = type, repos = repos) + + # add custom headers if available -- note that + # utils::available.packages() will pass this to download.file() + if ("headers" %in% names(formals(utils::download.file))) { + headers <- renv_bootstrap_download_custom_headers(repos) + if (length(headers) && is.character(headers)) + args$headers <- headers + } + + # retrieve package database + db <- tryCatch( + as.data.frame( + do.call(utils::available.packages, args), + stringsAsFactors = FALSE + ), + error = identity + ) + + if (inherits(db, "error")) + next + + # check for compatible entry + entry <- db[db$Package %in% "renv" & db$Version %in% version, ] + if (nrow(entry) == 0) + next + + # found it; return spec to caller + spec <- list(entry = entry, type = type, repos = repos) + return(spec) + + } + } + + # if we got here, we failed to find renv + fmt <- "renv %s is not available from your declared package repositories" + stop(sprintf(fmt, version)) + + } + + renv_bootstrap_download_cran_archive <- function(version) { + + name <- sprintf("renv_%s.tar.gz", version) + repos <- renv_bootstrap_repos() + urls <- file.path(repos, "src/contrib/Archive/renv", name) + destfile <- file.path(tempdir(), name) + + for (url in urls) { + + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (identical(status, 0L)) + return(destfile) + + } + + return(FALSE) + + } + + renv_bootstrap_find <- function(version) { + + path <- renv_bootstrap_find_cache(version) + if (length(path) && file.exists(path)) { + catf("- Using renv %s from global package cache", version) + return(path) + } + + } + + renv_bootstrap_find_cache <- function(version) { + + md5 <- attr(version, "md5", exact = TRUE) + if (is.null(md5)) + return() + + # infer path to renv cache + cache <- Sys.getenv("RENV_PATHS_CACHE", unset = "") + if (!nzchar(cache)) { + tools <- asNamespace("tools") + if (is.function(tools$R_user_dir)) { + root <- tools$R_user_dir("renv", "cache") + cache <- file.path(root, "cache") + } + } + + # start completing path to cache + file.path( + cache, + renv_bootstrap_cache_version(), + renv_bootstrap_platform_prefix(), + "renv", + version, + md5, + "renv" + ) + + } + + renv_bootstrap_download_tarball <- function(version) { + + # if the user has provided the path to a tarball via + # an environment variable, then use it + tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA) + if (is.na(tarball)) + return() + + # allow directories + if (dir.exists(tarball)) { + name <- sprintf("renv_%s.tar.gz", version) + tarball <- file.path(tarball, name) + } + + # bail if it doesn't exist + if (!file.exists(tarball)) { + + # let the user know we weren't able to honour their request + fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist." + msg <- sprintf(fmt, tarball) + warning(msg) + + # bail + return() + + } + + catf("- Using local tarball '%s'.", tarball) + tarball + + } + + renv_bootstrap_github_token <- function() { + for (envvar in c("GITHUB_TOKEN", "GITHUB_PAT", "GH_TOKEN")) { + envval <- Sys.getenv(envvar, unset = NA) + if (!is.na(envval)) + return(envval) + } + } + + renv_bootstrap_download_github <- function(version) { + + enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") + if (!identical(enabled, "TRUE")) + return(FALSE) + + # prepare download options + token <- renv_bootstrap_github_token() + if (is.null(token)) + token <- "" + + if (nzchar(Sys.which("curl")) && nzchar(token)) { + fmt <- "--location --fail --header \"Authorization: token %s\"" + extra <- sprintf(fmt, token) + saved <- options("download.file.method", "download.file.extra") + options(download.file.method = "curl", download.file.extra = extra) + on.exit(do.call(base::options, saved), add = TRUE) + } else if (nzchar(Sys.which("wget")) && nzchar(token)) { + fmt <- "--header=\"Authorization: token %s\"" + extra <- sprintf(fmt, token) + saved <- options("download.file.method", "download.file.extra") + options(download.file.method = "wget", download.file.extra = extra) + on.exit(do.call(base::options, saved), add = TRUE) + } + + url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version) + name <- sprintf("renv_%s.tar.gz", version) + destfile <- file.path(tempdir(), name) + + status <- tryCatch( + renv_bootstrap_download_impl(url, destfile), + condition = identity + ) + + if (!identical(status, 0L)) + return(FALSE) + + renv_bootstrap_download_augment(destfile) + + return(destfile) + + } + + # Add Sha to DESCRIPTION. This is stop gap until #890, after which we + # can use renv::install() to fully capture metadata. + renv_bootstrap_download_augment <- function(destfile) { + sha <- renv_bootstrap_git_extract_sha1_tar(destfile) + if (is.null(sha)) { + return() + } + + # Untar + tempdir <- tempfile("renv-github-") + on.exit(unlink(tempdir, recursive = TRUE), add = TRUE) + untar(destfile, exdir = tempdir) + pkgdir <- dir(tempdir, full.names = TRUE)[[1]] + + # Modify description + desc_path <- file.path(pkgdir, "DESCRIPTION") + desc_lines <- readLines(desc_path) + remotes_fields <- c( + "RemoteType: github", + "RemoteHost: api.github.com", + "RemoteRepo: renv", + "RemoteUsername: rstudio", + "RemotePkgRef: rstudio/renv", + paste("RemoteRef: ", sha), + paste("RemoteSha: ", sha) + ) + writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path) + + # Re-tar + local({ + old <- setwd(tempdir) + on.exit(setwd(old), add = TRUE) + + tar(destfile, compression = "gzip") + }) + invisible() + } + + # Extract the commit hash from a git archive. Git archives include the SHA1 + # hash as the comment field of the tarball pax extended header + # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html) + # For GitHub archives this should be the first header after the default one + # (512 byte) header. + renv_bootstrap_git_extract_sha1_tar <- function(bundle) { + + # open the bundle for reading + # We use gzcon for everything because (from ?gzcon) + # > Reading from a connection which does not supply a 'gzip' magic + # > header is equivalent to reading from the original connection + conn <- gzcon(file(bundle, open = "rb", raw = TRUE)) + on.exit(close(conn)) + + # The default pax header is 512 bytes long and the first pax extended header + # with the comment should be 51 bytes long + # `52 comment=` (11 chars) + 40 byte SHA1 hash + len <- 0x200 + 0x33 + res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len]) + + if (grepl("^52 comment=", res)) { + sub("52 comment=", "", res) + } else { + NULL + } + } + + renv_bootstrap_install <- function(version, tarball, library) { + + # attempt to install it into project library + dir.create(library, showWarnings = FALSE, recursive = TRUE) + output <- renv_bootstrap_install_impl(library, tarball) + + # check for successful install + status <- attr(output, "status") + if (is.null(status) || identical(status, 0L)) + return(status) + + # an error occurred; report it + header <- "installation of renv failed" + lines <- paste(rep.int("=", nchar(header)), collapse = "") + text <- paste(c(header, lines, output), collapse = "\n") + stop(text) + + } + + renv_bootstrap_install_impl <- function(library, tarball) { + + # invoke using system2 so we can capture and report output + bin <- R.home("bin") + exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R" + R <- file.path(bin, exe) + + args <- c( + "--vanilla", "CMD", "INSTALL", "--no-multiarch", + "-l", shQuote(path.expand(library)), + shQuote(path.expand(tarball)) + ) + + system2(R, args, stdout = TRUE, stderr = TRUE) + + } + + renv_bootstrap_platform_prefix_default <- function() { + + # read version component + version <- Sys.getenv("RENV_PATHS_VERSION", unset = "R-%v") + + # expand placeholders + placeholders <- list( + list("%v", format(getRversion()[1, 1:2])), + list("%V", format(getRversion()[1, 1:3])) + ) + + for (placeholder in placeholders) + version <- gsub(placeholder[[1L]], placeholder[[2L]], version, fixed = TRUE) + + # include SVN revision for development versions of R + # (to avoid sharing platform-specific artefacts with released versions of R) + devel <- + identical(R.version[["status"]], "Under development (unstable)") || + identical(R.version[["nickname"]], "Unsuffered Consequences") + + if (devel) + version <- paste(version, R.version[["svn rev"]], sep = "-r") + + version + + } + + renv_bootstrap_platform_prefix <- function() { + + # construct version prefix + version <- renv_bootstrap_platform_prefix_default() + + # build list of path components + components <- c(version, R.version$platform) + + # include prefix if provided by user + prefix <- renv_bootstrap_platform_prefix_impl() + if (!is.na(prefix) && nzchar(prefix)) + components <- c(prefix, components) + + # build prefix + paste(components, collapse = "/") + + } + + renv_bootstrap_platform_prefix_impl <- function() { + + # if an explicit prefix has been supplied, use it + prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA) + if (!is.na(prefix)) + return(prefix) + + # if the user has requested an automatic prefix, generate it + auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) + if (is.na(auto) && getRversion() >= "4.4.0") + auto <- "TRUE" + + if (auto %in% c("TRUE", "True", "true", "1")) + return(renv_bootstrap_platform_prefix_auto()) + + # empty string on failure + "" + + } + + renv_bootstrap_platform_prefix_auto <- function() { + + prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity) + if (inherits(prefix, "error") || prefix %in% "unknown") { + + msg <- paste( + "failed to infer current operating system", + "please file a bug report at https://github.com/rstudio/renv/issues", + sep = "; " + ) + + warning(msg) + + } + + prefix + + } + + renv_bootstrap_platform_os <- function() { + + sysinfo <- Sys.info() + sysname <- sysinfo[["sysname"]] + + # handle Windows + macOS up front + if (sysname == "Windows") + return("windows") + else if (sysname == "Darwin") + return("macos") + + # check for os-release files + for (file in c("/etc/os-release", "/usr/lib/os-release")) + if (file.exists(file)) + return(renv_bootstrap_platform_os_via_os_release(file, sysinfo)) + + # check for redhat-release files + if (file.exists("/etc/redhat-release")) + return(renv_bootstrap_platform_os_via_redhat_release()) + + "unknown" + + } + + renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) { + + # read /etc/os-release + release <- utils::read.table( + file = file, + sep = "=", + quote = c("\"", "'"), + col.names = c("Key", "Value"), + comment.char = "#", + stringsAsFactors = FALSE + ) + + vars <- as.list(release$Value) + names(vars) <- release$Key + + # get os name + os <- tolower(sysinfo[["sysname"]]) + + # read id + id <- "unknown" + for (field in c("ID", "ID_LIKE")) { + if (field %in% names(vars) && nzchar(vars[[field]])) { + id <- vars[[field]] + break + } + } + + # read version + version <- "unknown" + for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) { + if (field %in% names(vars) && nzchar(vars[[field]])) { + version <- vars[[field]] + break + } + } + + # join together + paste(c(os, id, version), collapse = "-") + + } + + renv_bootstrap_platform_os_via_redhat_release <- function() { + + # read /etc/redhat-release + contents <- readLines("/etc/redhat-release", warn = FALSE) + + # infer id + id <- if (grepl("centos", contents, ignore.case = TRUE)) + "centos" + else if (grepl("redhat", contents, ignore.case = TRUE)) + "redhat" + else + "unknown" + + # try to find a version component (very hacky) + version <- "unknown" + + parts <- strsplit(contents, "[[:space:]]")[[1L]] + for (part in parts) { + + nv <- tryCatch(numeric_version(part), error = identity) + if (inherits(nv, "error")) + next + + version <- nv[1, 1] + break + + } + + paste(c("linux", id, version), collapse = "-") + + } + + renv_bootstrap_library_root_name <- function(project) { + + # use project name as-is if requested + asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE") + if (asis) + return(basename(project)) + + # otherwise, disambiguate based on project's path + id <- substring(renv_bootstrap_hash_text(project), 1L, 8L) + paste(basename(project), id, sep = "-") + + } + + renv_bootstrap_library_root <- function(project) { + + prefix <- renv_bootstrap_profile_prefix() + + path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA) + if (!is.na(path)) + return(paste(c(path, prefix), collapse = "/")) + + path <- renv_bootstrap_library_root_impl(project) + if (!is.null(path)) { + name <- renv_bootstrap_library_root_name(project) + return(paste(c(path, prefix, name), collapse = "/")) + } + + renv_bootstrap_paths_renv("library", project = project) + + } + + renv_bootstrap_library_root_impl <- function(project) { + + root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA) + if (!is.na(root)) + return(root) + + type <- renv_bootstrap_project_type(project) + if (identical(type, "package")) { + userdir <- renv_bootstrap_user_dir() + return(file.path(userdir, "library")) + } + + } + + renv_bootstrap_validate_version <- function(version, description = NULL) { + + # resolve description file + # + # avoid passing lib.loc to `packageDescription()` below, since R will + # use the loaded version of the package by default anyhow. note that + # this function should only be called after 'renv' is loaded + # https://github.com/rstudio/renv/issues/1625 + description <- description %||% packageDescription("renv") + + # check whether requested version 'version' matches loaded version of renv + sha <- attr(version, "sha", exact = TRUE) + valid <- if (!is.null(sha)) + renv_bootstrap_validate_version_dev(sha, description) + else + renv_bootstrap_validate_version_release(version, description) + + if (valid) + return(TRUE) + + # the loaded version of renv doesn't match the requested version; + # give the user instructions on how to proceed + dev <- identical(description[["RemoteType"]], "github") + remote <- if (dev) + paste("rstudio/renv", description[["RemoteSha"]], sep = "@") + else + paste("renv", description[["Version"]], sep = "@") + + # display both loaded version + sha if available + friendly <- renv_bootstrap_version_friendly( + version = description[["Version"]], + sha = if (dev) description[["RemoteSha"]] + ) + + fmt <- heredoc(" + renv %1$s was loaded from project library, but this project is configured to use renv %2$s. + - Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile. + - Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library. + ") + catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote) + + FALSE + + } + + renv_bootstrap_validate_version_dev <- function(version, description) { + + expected <- description[["RemoteSha"]] + if (!is.character(expected)) + return(FALSE) + + pattern <- sprintf("^\\Q%s\\E", version) + grepl(pattern, expected, perl = TRUE) + + } + + renv_bootstrap_validate_version_release <- function(version, description) { + expected <- description[["Version"]] + is.character(expected) && identical(expected, version) + } + + renv_bootstrap_hash_text <- function(text) { + + hashfile <- tempfile("renv-hash-") + on.exit(unlink(hashfile), add = TRUE) + + writeLines(text, con = hashfile) + tools::md5sum(hashfile) + + } + + renv_bootstrap_load <- function(project, libpath, version) { + + # try to load renv from the project library + if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) + return(FALSE) + + # warn if the version of renv loaded does not match + renv_bootstrap_validate_version(version) + + # execute renv load hooks, if any + hooks <- getHook("renv::autoload") + for (hook in hooks) + if (is.function(hook)) + tryCatch(hook(), error = warnify) + + # load the project + renv::load(project) + + TRUE + + } + + renv_bootstrap_profile_load <- function(project) { + + # if RENV_PROFILE is already set, just use that + profile <- Sys.getenv("RENV_PROFILE", unset = NA) + if (!is.na(profile) && nzchar(profile)) + return(profile) + + # check for a profile file (nothing to do if it doesn't exist) + path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project) + if (!file.exists(path)) + return(NULL) + + # read the profile, and set it if it exists + contents <- readLines(path, warn = FALSE) + if (length(contents) == 0L) + return(NULL) + + # set RENV_PROFILE + profile <- contents[[1L]] + if (!profile %in% c("", "default")) + Sys.setenv(RENV_PROFILE = profile) + + profile + + } + + renv_bootstrap_profile_prefix <- function() { + profile <- renv_bootstrap_profile_get() + if (!is.null(profile)) + return(file.path("profiles", profile, "renv")) + } + + renv_bootstrap_profile_get <- function() { + profile <- Sys.getenv("RENV_PROFILE", unset = "") + renv_bootstrap_profile_normalize(profile) + } + + renv_bootstrap_profile_set <- function(profile) { + profile <- renv_bootstrap_profile_normalize(profile) + if (is.null(profile)) + Sys.unsetenv("RENV_PROFILE") + else + Sys.setenv(RENV_PROFILE = profile) + } + + renv_bootstrap_profile_normalize <- function(profile) { + + if (is.null(profile) || profile %in% c("", "default")) + return(NULL) + + profile + + } + + renv_bootstrap_path_absolute <- function(path) { + + substr(path, 1L, 1L) %in% c("~", "/", "\\") || ( + substr(path, 1L, 1L) %in% c(letters, LETTERS) && + substr(path, 2L, 3L) %in% c(":/", ":\\") + ) + + } + + renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) { + renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv") + root <- if (renv_bootstrap_path_absolute(renv)) NULL else project + prefix <- if (profile) renv_bootstrap_profile_prefix() + components <- c(root, renv, prefix, ...) + paste(components, collapse = "/") + } + + renv_bootstrap_project_type <- function(path) { + + descpath <- file.path(path, "DESCRIPTION") + if (!file.exists(descpath)) + return("unknown") + + desc <- tryCatch( + read.dcf(descpath, all = TRUE), + error = identity + ) + + if (inherits(desc, "error")) + return("unknown") + + type <- desc$Type + if (!is.null(type)) + return(tolower(type)) + + package <- desc$Package + if (!is.null(package)) + return("package") + + "unknown" + + } + + renv_bootstrap_user_dir <- function() { + dir <- renv_bootstrap_user_dir_impl() + path.expand(chartr("\\", "/", dir)) + } + + renv_bootstrap_user_dir_impl <- function() { + + # use local override if set + override <- getOption("renv.userdir.override") + if (!is.null(override)) + return(override) + + # use R_user_dir if available + tools <- asNamespace("tools") + if (is.function(tools$R_user_dir)) + return(tools$R_user_dir("renv", "cache")) + + # try using our own backfill for older versions of R + envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME") + for (envvar in envvars) { + root <- Sys.getenv(envvar, unset = NA) + if (!is.na(root)) + return(file.path(root, "R/renv")) + } + + # use platform-specific default fallbacks + if (Sys.info()[["sysname"]] == "Windows") + file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv") + else if (Sys.info()[["sysname"]] == "Darwin") + "~/Library/Caches/org.R-project.R/R/renv" + else + "~/.cache/R/renv" + + } + + renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) { + sha <- sha %||% attr(version, "sha", exact = TRUE) + parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L))) + paste(parts, collapse = "") + } + + renv_bootstrap_exec <- function(project, libpath, version) { + if (!renv_bootstrap_load(project, libpath, version)) + renv_bootstrap_run(project, libpath, version) + } + + renv_bootstrap_run <- function(project, libpath, version) { + + # perform bootstrap + bootstrap(version, libpath) + + # exit early if we're just testing bootstrap + if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA))) + return(TRUE) + + # try again to load + if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { + return(renv::load(project = project)) + } + + # failed to download or load renv; warn the user + msg <- c( + "Failed to find an renv installation: the project will not be loaded.", + "Use `renv::activate()` to re-initialize the project." + ) + + warning(paste(msg, collapse = "\n"), call. = FALSE) + + } + + renv_bootstrap_cache_version <- function() { + # NOTE: users should normally not override the cache version; + # this is provided just to make testing easier + Sys.getenv("RENV_CACHE_VERSION", unset = "v5") + } + + renv_bootstrap_cache_version_previous <- function() { + version <- renv_bootstrap_cache_version() + number <- as.integer(substring(version, 2L)) + paste("v", number - 1L, sep = "") + } + + renv_json_read <- function(file = NULL, text = NULL) { + + jlerr <- NULL + + # if jsonlite is loaded, use that instead + if ("jsonlite" %in% loadedNamespaces()) { + + json <- tryCatch(renv_json_read_jsonlite(file, text), error = identity) + if (!inherits(json, "error")) + return(json) + + jlerr <- json + + } + + # otherwise, fall back to the default JSON reader + json <- tryCatch(renv_json_read_default(file, text), error = identity) + if (!inherits(json, "error")) + return(json) + + # report an error + if (!is.null(jlerr)) + stop(jlerr) + else + stop(json) + + } + + renv_json_read_jsonlite <- function(file = NULL, text = NULL) { + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") + jsonlite::fromJSON(txt = text, simplifyVector = FALSE) + } + + renv_json_read_patterns <- function() { + + list( + + # objects + list("{", "\t\n\tobject(\t\n\t", TRUE), + list("}", "\t\n\t)\t\n\t", TRUE), + + # arrays + list("[", "\t\n\tarray(\t\n\t", TRUE), + list("]", "\n\t\n)\n\t\n", TRUE), + + # maps + list(":", "\t\n\t=\t\n\t", TRUE), + + # newlines + list("\\u000a", "\n", FALSE) + + ) + + } + + renv_json_read_envir <- function() { + + envir <- new.env(parent = emptyenv()) + + envir[["+"]] <- `+` + envir[["-"]] <- `-` + + envir[["object"]] <- function(...) { + result <- list(...) + names(result) <- as.character(names(result)) + result + } + + envir[["array"]] <- list + + envir[["true"]] <- TRUE + envir[["false"]] <- FALSE + envir[["null"]] <- NULL + + envir + + } + + renv_json_read_remap <- function(object, patterns) { + + # repair names if necessary + if (!is.null(names(object))) { + + nms <- names(object) + for (pattern in patterns) + nms <- gsub(pattern[[2L]], pattern[[1L]], nms, fixed = TRUE) + names(object) <- nms + + } + + # repair strings if necessary + if (is.character(object)) { + for (pattern in patterns) + object <- gsub(pattern[[2L]], pattern[[1L]], object, fixed = TRUE) + } + + # recurse for other objects + if (is.recursive(object)) + for (i in seq_along(object)) + object[i] <- list(renv_json_read_remap(object[[i]], patterns)) + + # return remapped object + object + + } + + renv_json_read_default <- function(file = NULL, text = NULL) { + + # read json text + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") + + # convert into something the R parser will understand + patterns <- renv_json_read_patterns() + transformed <- text + for (pattern in patterns) + transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE) + + # parse it + rfile <- tempfile("renv-json-", fileext = ".R") + on.exit(unlink(rfile), add = TRUE) + writeLines(transformed, con = rfile) + json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]] + + # evaluate in safe environment + result <- eval(json, envir = renv_json_read_envir()) + + # fix up strings if necessary -- do so only with reversible patterns + patterns <- Filter(function(pattern) pattern[[3L]], patterns) + renv_json_read_remap(result, patterns) + + } + + + # load the renv profile, if any + renv_bootstrap_profile_load(project) + + # construct path to library root + root <- renv_bootstrap_library_root(project) + + # construct library prefix for platform + prefix <- renv_bootstrap_platform_prefix() + + # construct full libpath + libpath <- file.path(root, prefix) + + # run bootstrap code + renv_bootstrap_exec(project, libpath, version) + + invisible() + +}) diff --git a/renv/settings.json b/renv/settings.json new file mode 100644 index 0000000..4aa5441 --- /dev/null +++ b/renv/settings.json @@ -0,0 +1,20 @@ +{ + "bioconductor.version": null, + "external.libraries": [], + "ignored.packages": [], + "package.dependency.fields": [ + "Imports", + "Depends", + "LinkingTo" + ], + "ppm.enabled": null, + "ppm.ignored.urls": [], + "r.version": null, + "snapshot.dev": false, + "snapshot.type": "implicit", + "use.cache": true, + "vcs.ignore.cellar": true, + "vcs.ignore.library": true, + "vcs.ignore.local": true, + "vcs.manage.ignores": true +}