R/utils.R

In opdisDownsampling: Optimal Distribution Preserving Down-Sampling of Bio-Medical Data

#' @title Determine optimal number of cores for parallel processing
#' @description Calculates the number of CPU cores to use for parallel operations,
#' leaving one core free for system operations and respecting user-specified limits.
#' @param max_cores Integer or NULL. Maximum number of cores to use. If NULL,
#' uses all available cores minus one (default: NULL).
#' @return Integer. Number of cores to use for parallel processing (minimum 1).
#' @details This function ensures at least one core remains available for system
#' operations by using \code{parallel::detectCores() - 1}. If \code{max_cores} is
#' specified, it returns the minimum of the detected cores and the user limit.
#' @keywords internal
#' @importFrom parallel detectCores
#' @examples
#' \dontrun{
#' # Use all available cores minus one
#' n_cores <- determine_n_cores()
#'
#' # Limit to maximum 4 cores
#' n_cores <- determine_n_cores(max_cores = 4)
#' }
determine_n_cores <- function(max_cores = NULL) {
  if (!is.null(max_cores)) {
    return(max(1, min(parallel::detectCores() - 1, max_cores)))
  }
  max(1, parallel::detectCores() - 1)
}

#' @title Apply function with text progress bar
#' @description Sequential version of lapply that displays a text progress bar
#' to monitor computation progress, useful for long-running operations.
#' @param X List or vector. Input data to iterate over.
#' @param FUN Function. Function to apply to each element of X.
#' @param ... Additional arguments passed to FUN.
#' @return List. Results of applying FUN to each element of X.
#' @details Creates a text progress bar using \code{txtProgressBar} and updates
#' it after processing each element. The progress bar is automatically closed
#' upon completion. This function is particularly useful when parallel processing
#' is not available or desired.
#' @keywords internal
#' @importFrom utils txtProgressBar setTxtProgressBar
#' @examples
#' \dontrun{
#' # Apply function with progress bar
#' results <- lapply_with_bar(1:100, function(x) {
#'   Sys.sleep(0.1) # Simulate computation
#'   x^2
#' })
#' }
lapply_with_bar <- function(X, FUN, ...) {
  pb <- txtProgressBar(min = 0, max = length(X), style = 3)
  result <- vector("list", length(X))
  for (i in seq_along(X)) {
    result[[i]] <- FUN(X[[i]], ...)
    setTxtProgressBar(pb, i)
  }
  close(pb)
  result
}

#' @title Find maximum value ignoring NaN/NA values
#' @description Finds the maximum value in data while ignoring NaN and NA values.
#' For matrices, returns column-wise maxima. For vectors, returns the overall maximum.
#' @param Data Numeric vector or matrix. Input data to find maximum values from.
#' @return Numeric. For vectors: single maximum value. For matrices: vector of
#' column-wise maximum values.
#' @details This function handles both vector and matrix inputs. For matrices,
#' it applies the maximum function column-wise using \code{apply} with
#' \code{na.rm = TRUE}. For vectors, it returns the single maximum value.
#' @keywords internal
#' @examples
#' \dontrun{
#' # Vector example
#' vec <- c(1, 2, NA, 4, NaN, 3)
#' nanmax(vec) # Returns 4
#'
#' # Matrix example
#' mat <- matrix(c(1, NA, 3, 2, NaN, 4), nrow = 2)
#' nanmax(mat) # Returns column maxima
#' }
nanmax <- function(Data) {
  if (length(dim(Data)) == 2) {
    # Matrix case: return column-wise maxima
    SpaltenMinima <- apply(Data, 2, function(x) max(x, na.rm = TRUE))
  } else {
    # Vector case: return overall maximum
    SpaltenMinima <- max(Data, na.rm = TRUE)
  }
  return(SpaltenMinima)
}

# ===== VALIDATION AND ERROR HANDLING FUNCTIONS =====

#' @title Validate reduced diagnostic results
#' @description Validates the structure and content of trial results from sample_and_analyze
#' @param ReducedDiag List of trial results to validate
#' @return Logical. TRUE if validation passes, otherwise stops with error
#' @keywords internal
validate_reduced_diag <- function(ReducedDiag) {
  if (length(ReducedDiag) == 0) {
    stop("opdisDownsampling: No valid results from sample_and_analyze.")
  }

  if (is.null(ReducedDiag[[1]])) {
    stop("opdisDownsampling: First trial result is NULL.")
  }

  if (!is.list(ReducedDiag[[1]]) ||
    is.null(ReducedDiag[[1]][[1]]) ||
    length(ReducedDiag[[1]][[1]]) == 0) {
    stop("opdisDownsampling: Invalid structure in trial results.")
  }

  TRUE
}

#' @title Validate statistical matrices
#' @description Validates statistical matrices for problematic values
#' @param matrices List of matrices to validate
#' @param matrix_names Character vector of matrix names for error messages
#' @param check_usage Logical vector indicating which matrices are actually used in analysis
#' @return Invisible NULL. Issues warnings for problematic matrices
#' @keywords internal
validate_matrices <- function(matrices, matrix_names, check_usage = rep(TRUE, length(matrices))) {
  for (i in seq_along(matrices)) {
    # Skip validation if this matrix is not used in the analysis
    if (!check_usage[i]) {
      next
    }

    # Check if all values are NA
    if (all(is.na(matrices[[i]]))) {
      warning(sprintf(
        "opdisDownsampling: Matrix '%s' contains all NA values.",
        matrix_names[i]
      ), call. = FALSE)
      next
    }

    # Check for rows with all NA
    rows_all_na <- apply(matrices[[i]], 1, function(x) all(is.na(x)))
    if (any(rows_all_na)) {
      n_bad_rows <- sum(rows_all_na)
      warning(sprintf(
        "opdisDownsampling: Matrix '%s' has %d row(s) with all NA values.",
        matrix_names[i], n_bad_rows
      ), call. = FALSE)
    }

    # Check for columns with all NA
    cols_all_na <- apply(matrices[[i]], 2, function(x) all(is.na(x)))
    if (any(cols_all_na)) {
      n_bad_cols <- sum(cols_all_na)
      warning(sprintf(
        "opdisDownsampling: Matrix '%s' has %d column(s) with all NA values.",
        matrix_names[i], n_bad_cols
      ), call. = FALSE)
    }

    # Check if too many NAs overall (e.g., >50%)
    na_proportion <- sum(is.na(matrices[[i]])) / length(matrices[[i]])
    if (na_proportion > 0.5 && na_proportion < 1.0) {
      warning(sprintf(
        "opdisDownsampling: Matrix '%s' contains %.1f%% NA values.",
        matrix_names[i], na_proportion * 100
      ), call. = FALSE)
    }
  }
}