R/helper.R

In SpatPCA: Regularized Principal Component Analysis for Spatial Data

# This file was generated by Rcpp::compileAttributes
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
#'
#' Internal function: Set the number of cores for parallel computing
#'
#' @keywords internal
#' @param num_cores Number of number of cores for parallel computing. Default is NULL.
#' @return Logical
#'
setCores <- function(num_cores = NULL) {
  if (!is.null(num_cores)) {
    if (!is.numeric(num_cores)) {
      stop("Please enter valid type - but got ", class(num_cores))
    }
    
    default_number <- RcppParallel::defaultNumThreads()
    if (num_cores > default_number) {
      stop("The input number of cores is invalid - default is ",
           default_number)
    }
    if (num_cores < 1) {
      stop("The number of cores is not greater than 1 - but got ", num_cores)
    }
    tryCatch(
      RcppParallel::setThreadOptions(numThreads = num_cores),
      error = print
    )
  }
}

#'
#' Internal function: Scale one-dimension locations
#'
#' @keywords internal
#' @param location Location matrix
#' @return scaled location matrix
#'
scaleLocation <- function(location) {
  if (dim(location)[2] == 1) {
    min_location <- min(location)
    max_location <- max(location)
    scaled_location <-
      (location - min_location) / (max_location - min_location)
  } else {
    scaled_location <- location
  }
  return(scaled_location)
}

#'
#' Internal function: Validate new locations for a spatpca object
#'
#' @keywords internal
#' @param spatpca_object An `spatpca` class object
#' @param x_new New location matrix.
#' @return `NULL`.
#'
checkNewLocationsForSpatpcaObject <-
  function(spatpca_object, x_new) {
    if (!inherits(spatpca_object,  "spatpca")) {
      stop("Invalid object! Please enter a `spatpca` object")
    }
    if (is.null(x_new)) {
      stop("New locations cannot be NULL")
    }
    x_new <- as.matrix(x_new)
    if (ncol(x_new) != ncol(spatpca_object$scaled_x)) {
      stop(
        "Inconsistent dimension of locations - original dimension is ",
        ncol(spatpca_object$x)
      )
    }
  }

#'
#' Internal function: Validate input data for a spatpca object
#'
#' @keywords internal
#' @param Y Data matrix
#' @param x Location matrix.
#' @param M Number of folds for cross-validation
#' @return `NULL`.
#'
checkInputData <- function(Y, x, M) {
  x <- as.matrix(x)
  p <- ncol(Y)
  n <- nrow(Y)
  if (p < 3) {
    stop("Number of locations must be larger than 2.")
  }
  if (nrow(x) != p) {
    stop("The number of rows of x should be equal to the number of columns of Y.")
  }
  if (ncol(x) > 3) {
    stop("Dimension of locations must be less than 4.")
  }
  if (M >= n) {
    stop("Number of folds must be less than sample size.")
  }
}

#'
#' Internal function: Fetch the upper bound of the number of eigenfunctions
#'
#' @keywords internal
#' @param Y Data matrix
#' @param M Number of folds for cross-validation
#' @return integer
#'
fetchUpperBoundNumberEigenfunctions <- function(Y, M) {
  n <- nrow(Y)
  p <- ncol(Y)
  return(min(floor(n - n / M), p))
}

#'
#' Internal function: Set the number of eigenfunctions for a spatpca object
#'
#' @keywords internal
#' @param K Optional user-supplied number of eigenfunctions.
#' @param Y Data matrix
#' @param M Number of folds for cross-validation
#' @return integer
#'
setNumberEigenfunctions <- function(K, Y, M) {
  upper_bound <- fetchUpperBoundNumberEigenfunctions(Y, M)
  if (!is.null(K)) {
    if (K > upper_bound) {
      K <- upper_bound
      warning("K must be smaller than min(floor(n - n/M), p). Set K as ", K)
    }
  }
  return(K)
}

#'
#' Internal function: Set tuning parameter - tau1
#'
#' @keywords internal
#' @param tau1 Vector of a nonnegative smoothness parameter sequence. Default is NULL.
#' @param M Number of folds for cross-validation
#' @return Modified vector of a nonnegative smoothness parameter sequence.
#'
setTau1 <- function(tau1, M) {
  if (is.null(tau1)) {
    modified_tau1 <- c(0, exp(seq(log(1e-6), 0, length = 10)))
  } else {
    modified_tau1 <- tau1
  }
  
  if (M < 2) {
    return(max(modified_tau1))
  } else {
    return(modified_tau1)
  }
}

#'
#' Internal function: Set tuning parameter - tau2
#'
#' @keywords internal
#' @param tau2 Vector of a nonnegative sparseness parameter sequence. Default is NULL.
#' @param M Number of folds for cross-validation
#' @return Modified vector of a nonnegative sparseness parameter sequence.
#'
setTau2 <- function(tau2, M) {
  if (is.null(tau2)) {
    modified_tau2 <- 0
  } else {
    modified_tau2 <- tau2
  }
  if (M < 2) {
    return(max(modified_tau2))
  } else {
    return(modified_tau2)
  }
}

#'
#' Internal function: Set tuning parameter - l2
#'
#' @keywords internal
#' @param tau2 Vector of a nonnegative sparseness parameter sequence. Default is NULL.
#' @return Modified vector of a nonnegative tuning parameter sequence for ADMM use
#'
setL2 <- function(tau2) {
  if (length(tau2) == 1 && tau2 > 0) {
    return(c(0, exp(seq(
      log(tau2 / 1e4), log(tau2), length = 10
    ))))
  } else {
    return(1)
  }
}

#'
#' Internal function: Set tuning parameter - gamma
#'
#' @keywords internal
#' @param gamma Vector of a nonnegative hyper parameter sequence for tuning eigenvalues. Default is NULL.
#' @param Y Data matrix
#' @return Modified vector of a nonnegative hyper parameter sequence for tuning eigenvalues.
#'
setGamma <- function(gamma, Y) {
  if (is.null(gamma)) {
    svd_Y_partial <- svd(Y)
    max_gamma <- svd_Y_partial$d[1] ^ 2 / nrow(Y)
    return(c(0, exp(seq(
      log(max_gamma / 1e4), log(max_gamma), length = 10
    ))))
  } else {
    return(gamma)
  }
}

#'
#' Internal function: Detrend Y by column-wise centering
#'
#' @keywords internal
#' @param Y Data matrix
#' @return Detrended data matrix
#'
detrend <- function(Y, is_Y_detrended) {
  if (is_Y_detrended) {
    return(Y - rep(colMeans(Y), rep.int(nrow(Y), ncol(Y))))
  } else {
    return(Y)
  }
}