R/nulls-classes.R

In neuromapr: Spatial Null Models and Transforms for Brain Map Comparison

#' Create a null distribution object
#'
#' @param nulls Numeric matrix (n x n_perm) of surrogate values.
#' @param method Character string identifying the null model method.
#' @param observed Numeric vector of original data values.
#' @param params Named list of algorithm parameters.
#'
#' @return A `null_distribution` object.
#'
#' @name null_distribution
#' @examples
#' nulls <- matrix(rnorm(30), nrow = 3, ncol = 10)
#' nd <- new_null_distribution(nulls, "test", observed = c(1, 2, 3))
#' print(nd)
#' summary(nd)
#' @export
new_null_distribution <- function(nulls, method, observed, params = list()) {
  if (!is.matrix(nulls) || !is.numeric(nulls)) {
    cli::cli_abort("{.arg nulls} must be a numeric matrix.")
  }
  if (!is.character(method) || length(method) != 1L) {
    cli::cli_abort("{.arg method} must be a single character string.")
  }
  if (!is.numeric(observed)) {
    cli::cli_abort("{.arg observed} must be numeric.")
  }
  if (length(observed) != nrow(nulls)) {
    cli::cli_abort(paste(
      "{.arg observed} length ({length(observed)})",
      "must match rows in {.arg nulls} ({nrow(nulls)})."
    ))
  }
  structure(
    list(
      nulls = nulls,
      method = method,
      observed = observed,
      params = params,
      n_perm = ncol(nulls),
      n = nrow(nulls)
    ),
    class = c("null_distribution", "list")
  )
}

#' @noRd
#' @keywords internal
validate_null_distribution <- function(x) {
  if (!inherits(x, "null_distribution")) {
    cli::cli_abort("{.arg x} must be a {.cls null_distribution} object.")
  }
  if (!is.matrix(x$nulls)) {
    cli::cli_abort("{.field nulls} must be a matrix.")
  }
  if (length(x$observed) != nrow(x$nulls)) {
    cli::cli_abort(paste(
      "{.field observed} length ({length(x$observed)})",
      "must match rows in {.field nulls} ({nrow(x$nulls)})."
    ))
  }
  invisible(x)
}

#' @rdname null_distribution
#' @param x A `null_distribution` object.
#' @param ... Ignored.
#' @export
print.null_distribution <- function(x, ...) {
  cli::cli_h3("Null Distribution")
  cli::cli_ul(c(
    "Method: {x$method}",
    "Permutations: {x$n_perm}",
    "Observations: {x$n}"
  ))
  invisible(x)
}

#' @rdname null_distribution
#' @param object A `null_distribution` object.
#' @export
summary.null_distribution <- function(object, ...) {
  null_means <- rowMeans(object$nulls)
  null_sds <- apply(object$nulls, 1, stats::sd)
  list(
    method = object$method,
    n_perm = object$n_perm,
    n = object$n,
    null_mean = null_means,
    null_sd = null_sds,
    observed = object$observed
  )
}

#' @rdname null_distribution
#' @export
as.matrix.null_distribution <- function(x, ...) {
  x$nulls
}

#' @rdname null_distribution
#' @param parcel Integer index of the parcel to plot.
#' @export
plot.null_distribution <- function(x, parcel = 1L, ...) {
  df <- data.frame(value = x$nulls[parcel, ])
  obs <- x$observed[parcel]
  ggplot2::ggplot(df, ggplot2::aes(x = .data$value)) +
    ggplot2::geom_histogram(bins = 30) +
    ggplot2::geom_vline(
      xintercept = obs,
      linetype = "dashed",
      color = "firebrick"
    ) +
    ggplot2::labs(
      title = paste("Null distribution:", x$method),
      subtitle = paste("Parcel", parcel),
      x = "Value",
      y = "Count"
    )
}