R/RcppExports.R

Defines functions Rcpp_bipartite_match c_rsparsematrix c_rtisparsematrix c_sample c_rbinom c_runif c_rtimatrix c_rmatrix nnls Rcpp_dclust_sparse Rcpp_bipartition_dense Rcpp_bipartition_sparse Rcpp_nmf_dense Rcpp_nmf_sparse Rcpp_mse_missing_dense Rcpp_mse_missing_sparse Rcpp_mse_dense Rcpp_mse_sparse Rcpp_predict_dense Rcpp_predict_sparse

Documented in nnls

# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

Rcpp_predict_sparse <- function(A, mask, w, L1, L2, threads, mask_zeros, upper_bound = 0) {
    .Call(`_RcppML_Rcpp_predict_sparse`, A, mask, w, L1, L2, threads, mask_zeros, upper_bound)
}

Rcpp_predict_dense <- function(A_, mask, w, L1, L2, threads, mask_zeros, upper_bound = 0) {
    .Call(`_RcppML_Rcpp_predict_dense`, A_, mask, w, L1, L2, threads, mask_zeros, upper_bound)
}

Rcpp_mse_sparse <- function(A, mask, w, d, h, threads, mask_zeros) {
    .Call(`_RcppML_Rcpp_mse_sparse`, A, mask, w, d, h, threads, mask_zeros)
}

Rcpp_mse_dense <- function(A_, mask, w, d, h, threads, mask_zeros) {
    .Call(`_RcppML_Rcpp_mse_dense`, A_, mask, w, d, h, threads, mask_zeros)
}

Rcpp_mse_missing_sparse <- function(A, mask, w, d, h, threads) {
    .Call(`_RcppML_Rcpp_mse_missing_sparse`, A, mask, w, d, h, threads)
}

Rcpp_mse_missing_dense <- function(A_, mask, w, d, h, threads) {
    .Call(`_RcppML_Rcpp_mse_missing_dense`, A_, mask, w, d, h, threads)
}

Rcpp_nmf_sparse <- function(A, mask, tol, maxit, verbose, L1, L2, threads, w_init, link_matrix_h, mask_zeros, link_h, sort_model, upper_bound = 0) {
    .Call(`_RcppML_Rcpp_nmf_sparse`, A, mask, tol, maxit, verbose, L1, L2, threads, w_init, link_matrix_h, mask_zeros, link_h, sort_model, upper_bound)
}

Rcpp_nmf_dense <- function(A_, mask, tol, maxit, verbose, L1, L2, threads, w_init, link_matrix_h, mask_zeros, link_h, sort_model, upper_bound = 0) {
    .Call(`_RcppML_Rcpp_nmf_dense`, A_, mask, tol, maxit, verbose, L1, L2, threads, w_init, link_matrix_h, mask_zeros, link_h, sort_model, upper_bound)
}

Rcpp_bipartition_sparse <- function(A, tol, maxit, nonneg, samples, seed, verbose = FALSE, calc_dist = FALSE, diag = TRUE) {
    .Call(`_RcppML_Rcpp_bipartition_sparse`, A, tol, maxit, nonneg, samples, seed, verbose, calc_dist, diag)
}

Rcpp_bipartition_dense <- function(A, tol, maxit, nonneg, samples, seed, verbose = FALSE, calc_dist = FALSE, diag = TRUE) {
    .Call(`_RcppML_Rcpp_bipartition_dense`, A, tol, maxit, nonneg, samples, seed, verbose, calc_dist, diag)
}

Rcpp_dclust_sparse <- function(A, min_samples, min_dist, verbose, tol, maxit, nonneg, seed, threads) {
    .Call(`_RcppML_Rcpp_dclust_sparse`, A, min_samples, min_dist, verbose, tol, maxit, nonneg, seed, threads)
}

#' @title Non-negative least squares
#'
#' @description Solves the equation \code{a %*% x = b} for \code{x} subject to \eqn{x > 0}.
#'
#' @details
#' This is a very fast implementation of sequential coordinate descent non-negative least squares (NNLS), suitable for very small or very large systems.
#' The algorithm begins with a zero-filled initialization of \code{x}.
#'
#' Least squares by **sequential coordinate descent** is used to ensure the solution returned is exact. This algorithm was
#' introduced by Franc et al. (2005), and our implementation is a vectorized and optimized rendition of that found in the NNLM R package by Xihui Lin (2020).
#'
#' @param a symmetric positive definite matrix giving coefficients of the linear system
#' @param b matrix giving the right-hand side(s) of the linear system
#' @param L1 L1/LASSO penalty to be subtracted from \code{b}
#' @param L2 Ridge penalty by which to shrink the diagonal of \code{a}
#' @param cd_maxit maximum number of coordinate descent iterations
#' @param cd_tol stopping criteria, difference in \eqn{x} across consecutive solutions over the sum of \eqn{x}
#' @param upper_bound maximum value permitted in solution, set to \code{0} to impose no upper bound
#' @return vector or matrix giving solution for \code{x}
#' @export
#' @author Zach DeBruine
#' @seealso \code{\link{nmf}}, \code{\link{project}}
#' @md
#'
#' @references
#'
#' DeBruine, ZJ, Melcher, K, and Triche, TJ. (2021). "High-performance non-negative matrix factorization for large single-cell data." BioRXiv.
#'
#' Franc, VC, Hlavac, VC, and Navara, M. (2005). "Sequential Coordinate-Wise Algorithm for the Non-negative Least Squares Problem. Proc. Int'l Conf. Computer Analysis of Images and Patterns."
#'
#' Lin, X, and Boutros, PC (2020). "Optimization and expansion of non-negative matrix factorization." BMC Bioinformatics.
#'
#' Myre, JM, Frahm, E, Lilja DJ, and Saar, MO. (2017) "TNT-NN: A Fast Active Set Method for Solving Large Non-Negative Least Squares Problems". Proc. Computer Science.
#'
#' @examples
#' \dontrun{
#' # compare solution to base::solve for a random system
#' X <- matrix(runif(100), 10, 10)
#' a <- crossprod(X)
#' b <- crossprod(X, runif(10))
#' unconstrained_soln <- solve(a, b)
#' nonneg_soln <- nnls(a, b)
#' unconstrained_err <- mean((a %*% unconstrained_soln - b)^2)
#' nonnegative_err <- mean((a %*% nonneg_soln - b)^2)
#' unconstrained_err
#' nonnegative_err
#' all.equal(solve(a, b), nnls(a, b))
#'
#' # example adapted from multiway::fnnls example 1
#' X <- matrix(1:100,50,2)
#' y <- matrix(101:150,50,1)
#' beta <- solve(crossprod(X)) %*% crossprod(X, y)
#' beta
#' beta <- nnls(crossprod(X), crossprod(X, y))
#' beta
#'
#' # learn nmf model and do bvls projection
#' data(hawaiibirds)
#' w <- nmf(hawaiibirds$counts, 10)@w
#' h <- project(w, hawaiibirds$counts)
#' # now impose upper bound on solutions
#' h2 <- project(w, hawaiibirds$counts, upper_bound = 2)
#' }
nnls <- function(a, b, cd_maxit = 100L, cd_tol = 1e-8, L1 = 0, L2 = 0, upper_bound = 0) {
    .Call(`_RcppML_nnls`, a, b, cd_maxit, cd_tol, L1, L2, upper_bound)
}

c_rmatrix <- function(nrow, ncol, rng) {
    .Call(`_RcppML_c_rmatrix`, nrow, ncol, rng)
}

c_rtimatrix <- function(nrow, ncol, rng) {
    .Call(`_RcppML_c_rtimatrix`, nrow, ncol, rng)
}

c_runif <- function(n, min, max, rng, rng2) {
    .Call(`_RcppML_c_runif`, n, min, max, rng, rng2)
}

c_rbinom <- function(n, size, inv_probability, rng, rng2) {
    .Call(`_RcppML_c_rbinom`, n, size, inv_probability, rng, rng2)
}

c_sample <- function(n, size, replace, rng, rng2) {
    .Call(`_RcppML_c_sample`, n, size, replace, rng, rng2)
}

c_rtisparsematrix <- function(nrow, ncol, inv_probability, pattern_only, rng) {
    .Call(`_RcppML_c_rtisparsematrix`, nrow, ncol, inv_probability, pattern_only, rng)
}

c_rsparsematrix <- function(nrow, ncol, inv_probability, pattern_only, rng) {
    .Call(`_RcppML_c_rsparsematrix`, nrow, ncol, inv_probability, pattern_only, rng)
}

Rcpp_bipartite_match <- function(x) {
    .Call(`_RcppML_Rcpp_bipartite_match`, x)
}
zdebruine/RcppML documentation built on Sept. 13, 2023, 11:44 p.m.