R/utils.R

In MRS: Multi-Resolution Scanning for Cross-Sample and Cross-Group Differences

.validate_data <- function(X, G, n_groups, Omega) {
  X <- as.matrix(X)
  if (!is.numeric(X) || length(dim(X)) != 2L || nrow(X) == 0L || ncol(X) == 0L) {
    stop("'X' must be a non-empty numeric matrix.", call. = FALSE)
  }
  if (anyNA(X) || any(!is.finite(X))) {
    stop("'X' must contain only finite values.", call. = FALSE)
  }

  if (!is.numeric(G) || length(G) != nrow(X) || anyNA(G) ||
      any(!is.finite(G)) || any(G != floor(G))) {
    stop("'G' must contain one integer group label for each row of 'X'.", call. = FALSE)
  }
  n_groups <- .validate_integer(n_groups, "n_groups", lower = 2L)
  if (!identical(sort(unique(as.integer(G))), seq_len(n_groups))) {
    stop("'G' must use every integer label from 1 through 'n_groups'.", call. = FALSE)
  }
  G <- as.integer(G)

  if (is.character(Omega) && length(Omega) == 1L && identical(Omega, "default")) {
    Omega <- t(apply(X, 2L, range))
    widths <- Omega[, 2L] - Omega[, 1L]
    scales <- pmax(1, abs(Omega[, 1L]), abs(Omega[, 2L]))
    padding <- pmax(widths * 1e-7, sqrt(.Machine$double.eps) * scales)
    positive_upper <- Omega[, 2L] > 0
    Omega[positive_upper, 2L] <- Omega[positive_upper, 2L] * 1.0001
    Omega[!positive_upper, 2L] <- Omega[!positive_upper, 2L] + padding[!positive_upper]
  } else {
    Omega <- as.matrix(Omega)
    if (!is.numeric(Omega) || !identical(dim(Omega), c(ncol(X), 2L)) ||
        anyNA(Omega) || any(!is.finite(Omega))) {
      stop("'Omega' must be 'default' or a finite numeric matrix with one row per column of 'X' and two columns.", call. = FALSE)
    }
    if (any(Omega[, 1L] >= Omega[, 2L])) {
      stop("Each row of 'Omega' must have a lower bound smaller than its upper bound.", call. = FALSE)
    }
    empirical_bounds <- t(apply(X, 2L, range))
    if (any(empirical_bounds[, 1L] < Omega[, 1L]) ||
        any(empirical_bounds[, 2L] > Omega[, 2L])) {
      stop("'X' contains values outside 'Omega'.", call. = FALSE)
    }
  }

  list(X = X, G = G, n_groups = n_groups, Omega = Omega)
}

.validate_integer <- function(x, name, lower = -Inf, upper = Inf) {
  if (!is.numeric(x) || length(x) != 1L || is.na(x) || !is.finite(x) || x != floor(x) ||
      x < lower || x > upper) {
    stop(sprintf("'%s' must be a whole number between %s and %s.", name, lower, upper),
         call. = FALSE)
  }
  as.integer(x)
}

.validate_probability <- function(x, name) {
  if (!is.numeric(x) || length(x) != 1L || is.na(x) || !is.finite(x) || x < 0 || x > 1) {
    stop(sprintf("'%s' must be a number between 0 and 1.", name), call. = FALSE)
  }
  as.numeric(x)
}

.validate_flag <- function(x, name) {
  if (!is.logical(x) || length(x) != 1L || is.na(x)) {
    stop(sprintf("'%s' must be TRUE or FALSE.", name), call. = FALSE)
  }
  x
}

.validate_init_state <- function(init_state, eta, gamma) {
  if (is.null(init_state)) {
    init_state <- c((1 - eta) * (1 - gamma), (1 - eta) * gamma, eta)
  }
  if (!is.numeric(init_state) || length(init_state) != 3L || anyNA(init_state) ||
      any(!is.finite(init_state)) || any(init_state < 0) ||
      abs(sum(init_state) - 1) > sqrt(.Machine$double.eps)) {
    stop("'init_state' must contain three non-negative probabilities that sum to 1.",
         call. = FALSE)
  }
  as.numeric(init_state)
}

.reshape_tree <- function(tree) {
  n_nodes <- length(tree$Levels)
  tree$EffectSizes <- matrix(unlist(tree$EffectSizes, use.names = FALSE),
                             nrow = n_nodes, byrow = TRUE)
  tree$Regions <- matrix(unlist(tree$Regions, use.names = FALSE),
                         nrow = n_nodes, byrow = TRUE)
  tree
}