├── inst └── GIT.HASH ├── .aspell └── moma.rds ├── src ├── Makevars.win ├── Makevars ├── moma_fivedlist.h ├── moma_solver_BICsearch.h ├── moma_logging.cpp ├── moma_prox_sortedL1.h ├── moma_base.h ├── moma_heap.h ├── moma_fivedlist.cpp ├── moma_prox_sortedL1.cpp ├── moma_solver_BICsearch.cpp ├── moma_prox_fusion_util.h ├── moma_prox_flsadp.h ├── moma_test_expose.cpp ├── moma_solver.h └── moma_heap.cpp ├── tests ├── testthat.R └── testthat │ ├── test_BIC.R │ ├── test_prox_sparse_fused_lasso.R │ ├── helper_moma_tests.R │ ├── test_argument_extended.R │ ├── test_prox_SLOPE.R │ ├── test_util.R │ ├── test_grid.R │ ├── test_MGB_BIC.R │ ├── test_MBG-single_problem.R │ ├── test_MGB_multirank.R │ ├── test_dof.R │ ├── test_logging.R │ ├── test_prox_fused_lasso.R │ ├── test_5Dlist_extractor.R │ ├── test_solve.R │ └── test_prox_unordered_fusion.R ├── man ├── figures │ ├── vignettes-pca-demo.png │ └── README-usage-ldademo.png ├── MoMA.Rd ├── second_diff_mat.Rd ├── moma_session_info.Rd ├── select_scheme.Rd ├── PCA_deflation.Rd ├── LDA_deflation.Rd ├── CCA_deflation.Rd ├── moma_logging.Rd ├── moma_pg_settings.Rd ├── moma_smoothness.Rd ├── slope.Rd ├── lasso.Rd ├── mcp.Rd ├── group_lasso.Rd ├── sparse_fused_lasso.Rd ├── cluster.Rd ├── scad.Rd ├── fused_lasso.Rd ├── moma_sparsity_options.Rd ├── l1_trend_filtering.Rd ├── moma_sfcca.Rd ├── moma_sflda.Rd └── moma_sfpca.Rd ├── CONTRIBUTORS ├── docs ├── reference │ ├── figures │ │ ├── vignettes-pca-demo.png │ │ └── README-usage-ldademo.png │ ├── MoMA.html │ └── moma_session_info.html ├── articles │ ├── moma-functional-data-analysis_files │ │ └── figure-html │ │ │ ├── unnamed-chunk-3-1.png │ │ │ ├── unnamed-chunk-4-1.png │ │ │ ├── unnamed-chunk-5-1.png │ │ │ └── unnamed-chunk-7-1.png │ └── index.html ├── pkgdown.yml ├── link.svg ├── docsearch.js ├── pkgdown.js ├── pkgdown.css ├── SUPPORT.html └── authors.html ├── .Rbuildignore ├── R ├── zzz.R ├── moma-package.R ├── internals.R ├── moma_5Dlist_extractor.R ├── moma_solve.R ├── logging.R ├── moma_expose.R └── RcppExports.R ├── .gitignore ├── NAMESPACE ├── vignettes ├── vignettes.bibtex ├── moma-LDA.Rmd ├── moma-PCA.Rmd └── moma-quick-start.Rmd ├── DESCRIPTION └── _pkgdown.yml /inst/GIT.HASH: -------------------------------------------------------------------------------- 1 | 92842d1720b5f96d119a81a7eb2c5afb7e00f722 2 | -------------------------------------------------------------------------------- /.aspell/moma.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/.aspell/moma.rds -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | CXX_STD = CXX11 2 | PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 3 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(MoMA) 3 | 4 | test_check("MoMA") 5 | -------------------------------------------------------------------------------- /man/figures/vignettes-pca-demo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/man/figures/vignettes-pca-demo.png -------------------------------------------------------------------------------- /man/figures/README-usage-ldademo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/man/figures/README-usage-ldademo.png -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Code Contributions 2 | =================== 3 | 4 | Bug reports and other feedback 5 | =============================== 6 | -------------------------------------------------------------------------------- /docs/reference/figures/vignettes-pca-demo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/docs/reference/figures/vignettes-pca-demo.png -------------------------------------------------------------------------------- /docs/reference/figures/README-usage-ldademo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/docs/reference/figures/README-usage-ldademo.png -------------------------------------------------------------------------------- /docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-3-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-3-1.png -------------------------------------------------------------------------------- /docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-4-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-4-1.png -------------------------------------------------------------------------------- /docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-5-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-5-1.png -------------------------------------------------------------------------------- /docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-7-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/DataSlingers/MoMA/HEAD/docs/articles/moma-functional-data-analysis_files/figure-html/unnamed-chunk-7-1.png -------------------------------------------------------------------------------- /docs/pkgdown.yml: -------------------------------------------------------------------------------- 1 | pandoc: '2.2' 2 | pkgdown: 1.3.0 3 | pkgdown_sha: ~ 4 | articles: 5 | moma-LDA: moma-LDA.html 6 | moma-PCA: moma-PCA.html 7 | moma-functional-data-analysis: moma-functional-data-analysis.html 8 | moma-quick-start: moma-quick-start.html 9 | 10 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^TODO$ 4 | ^ALGORITHM$ 5 | vignettes/moma-quick-start_cache/* 6 | vignettes/moma-quick-start_files/* 7 | ^docs$ 8 | ^_pkgdown\.yml$ 9 | ^.travis\.yml$ 10 | .gitignore.deploy 11 | README.Rmd 12 | README.md 13 | figs/* 14 | build_steps.R 15 | ^codecov\.yml$ 16 | LICENSE 17 | CONTRIBUTORS 18 | .github/* 19 | .vscode/* 20 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | CXX_STD = CXX11 2 | PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 3 | 4 | strip: $(SHLIB) 5 | if test -e "/usr/bin/strip" & test -e "/bin/uname" & [[ `uname` == "Linux" ]] ; then /usr/bin/strip --strip-debug *.o *.so; fi 6 | if test -e "/usr/bin/strip" & test -e "/bin/uname" & [[ `uname` == "Darwin" ]] ; then /usr/bin/strip -S *.o *.so; fi 7 | 8 | .phony: strip 9 | -------------------------------------------------------------------------------- /man/MoMA.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma-package.R 3 | \docType{package} 4 | \name{MoMA} 5 | \alias{MoMA} 6 | \alias{MoMA-package} 7 | \title{MoMA: Modern Multivariate Analysis in R} 8 | \description{ 9 | TODO 10 | } 11 | \details{ 12 | See the package vignettes for details of the algorithm, as well as 13 | comparisons to existing methods. 14 | } 15 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(...) { # nocov start 2 | if (interactive()) { 3 | msg <- c( 4 | "Thank you for using MoMA!", 5 | "The current logging level is", 6 | sQuote(paste0(moma_logger_level(), ".")), 7 | "To change this, see ?moma_logging." 8 | ) 9 | 10 | packageStartupMessage(paste(msg, collapse = " ")) 11 | } 12 | } # nocov end 13 | -------------------------------------------------------------------------------- /man/second_diff_mat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/util.R 3 | \name{second_diff_mat} 4 | \alias{second_diff_mat} 5 | \title{Second difference matrix} 6 | \usage{ 7 | second_diff_mat(n) 8 | } 9 | \arguments{ 10 | \item{n}{An integer. The size of the returned matrix.} 11 | } 12 | \description{ 13 | This function returns a second difference matrix of size \eqn{n}. 14 | } 15 | -------------------------------------------------------------------------------- /man/moma_session_info.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/internals.R 3 | \name{moma_session_info} 4 | \alias{moma_session_info} 5 | \title{Session Info used for Bug Reporting} 6 | \usage{ 7 | moma_session_info() 8 | } 9 | \value{ 10 | None. Called for side-effects (printed to the screen) 11 | only. 12 | } 13 | \description{ 14 | A helper function which prints information useful in 15 | bug reports. 16 | } 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Travis deploy file 2 | deployed* 3 | 4 | # RStudio and R working files 5 | .Rproj.user 6 | .Rhistory 7 | .RData 8 | .Ruserdata 9 | *.Rproj 10 | vignettes/*_cache/ 11 | vignettes/*_files/ 12 | vignettes/*.R 13 | 14 | # Platform specific compiled files 15 | src/*.gcda 16 | src/*.o 17 | src/*.so 18 | src/*.dll 19 | inst/doc 20 | 21 | # VS Code configuration files 22 | .vscode/* 23 | 24 | # Development scripts 25 | .github/* 26 | script/* 27 | .clang-format 28 | .travis.yml 29 | -------------------------------------------------------------------------------- /man/select_scheme.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{select_scheme} 4 | \alias{select_scheme} 5 | \title{Introduction to selection schemes in MoMA} 6 | \description{ 7 | Please see the description of the argument \code{select_scheme} in 8 | \code{\link{moma_sparsity_options}}. The \code{select_scheme} argument 9 | presents in functions listed in \code{\link{moma_sparsity_options}}, and the function 10 | \code{\link{moma_smoothness}}. 11 | } 12 | -------------------------------------------------------------------------------- /tests/testthat/test_BIC.R: -------------------------------------------------------------------------------- 1 | context("BIC tests") 2 | 3 | bic_lasso <- function(y, y_est) { 4 | p <- length(y) 5 | res <- norm(as.matrix(y - y_est), "2") 6 | df <- sum(y_est != 0) 7 | bic <- log(res * res / p) + log(p) / p * df 8 | return(bic) 9 | } 10 | 11 | test_that("Test for lasso BIC", { 12 | y <- c(1, 2, 3) 13 | y_est <- c(2, 2, 2) 14 | p <- length(y) 15 | expect_equal(test_BIC( 16 | y, y_est, 17 | "ISTA", 18 | 0, second_diff_mat(p), 19 | 0, add_default_prox_args(lasso()), 20 | p 21 | ), bic_lasso(y, y_est)) 22 | }) 23 | -------------------------------------------------------------------------------- /src/moma_fivedlist.h: -------------------------------------------------------------------------------- 1 | #ifndef moma_fivedlist_H 2 | #define moma_fivedlist_H 1 3 | #include "moma.h" 4 | 5 | class RcppFiveDList 6 | { 7 | int n_alpha_u; 8 | int n_lambda_u; 9 | int n_alpha_v; 10 | int n_lambda_v; 11 | int k; 12 | Rcpp::List flattened_list; 13 | 14 | public: 15 | RcppFiveDList(int n_alpha_u, int n_lambda_u, int n_alpha_v, int n_lambda_v, int k = 1); 16 | 17 | int insert(Rcpp::List object, 18 | int alpha_u_i, 19 | int lambda_u_i, 20 | int alpha_v_i, 21 | int lambda_v_i, 22 | int k_i = 0); 23 | 24 | Rcpp::List get_list(); 25 | }; 26 | 27 | #endif 28 | -------------------------------------------------------------------------------- /R/moma-package.R: -------------------------------------------------------------------------------- 1 | #' MoMA: Modern Multivariate Analysis in R 2 | #' 3 | #' TODO 4 | #' 5 | #' See the package vignettes for details of the algorithm, as well as 6 | #' comparisons to existing methods. 7 | #' 8 | #' @docType package 9 | #' @name MoMA 10 | #' @useDynLib MoMA 11 | NULL 12 | 13 | ## Importing evalCpp is a hack to ensure that Rcpp is initialized before MoMA 14 | ## and may not be necessary if MoMA adds dependencies on other packages which 15 | ## will in turn initialize Rcpp 16 | ## 17 | ## Failing to have this import leads to a fairly nasty bug where 18 | ## MoMA:::.onAttach() fails and, more often than not, hangs indefinitely 19 | #' @importFrom Rcpp evalCpp 20 | NULL 21 | -------------------------------------------------------------------------------- /man/PCA_deflation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_sfpca.R 3 | \name{PCA_deflation} 4 | \alias{PCA_deflation} 5 | \title{Deflation Schemes for PCA} 6 | \description{ 7 | In \code{MoMA} three deflation schemes are provided for PCA. 8 | Using terminology in the reference, they are Hotelling's deflation, 9 | two-way projection deflation, and Schur complement deflation. 10 | } 11 | \details{ 12 | See the parameter \code{deflation_scheme} argument in the function 13 | \code{moma_sfpca}. Also refer to the reference below 14 | for theoretical properties. 15 | } 16 | \references{ 17 | Michael Weylandt. "Multi-Rank Sparse and Functional PCA: Manifold Optimization and 18 | Iterative Deflation Techniques." arXiv:1907.12012v1, 2019. 19 | } 20 | -------------------------------------------------------------------------------- /tests/testthat/test_prox_sparse_fused_lasso.R: -------------------------------------------------------------------------------- 1 | context("Sparse fused lasso tests") 2 | 3 | test_that("Same results as the `flsa` package", { 4 | set.seed(43) 5 | if (requireNamespace("flsa")) { 6 | library(flsa) 7 | pset <- seq(2, 8) 8 | for (p in pset) { 9 | for (i in 1:20) { 10 | x <- 10 * runif(p) 11 | for (lambda in seq(0, 2, 0.1)) { 12 | for (lambda2 in seq(0, 2, 0.2)) { 13 | expect_equal( 14 | test_prox_spfusedlasso(x, lambda, lambda2 = lambda2), 15 | matrix(flsaGetSolution(flsa(x), lambda2 = lambda, lambda1 = lambda2)) 16 | ) 17 | } 18 | } 19 | } 20 | } 21 | } 22 | }) 23 | -------------------------------------------------------------------------------- /docs/link.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 8 | 12 | 13 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(moma_cluster) 4 | export(moma_fcca) 5 | export(moma_flda) 6 | export(moma_fpca) 7 | export(moma_fusedlasso) 8 | export(moma_grplasso) 9 | export(moma_l1tf) 10 | export(moma_lasso) 11 | export(moma_logger_level) 12 | export(moma_mcp) 13 | export(moma_pg_settings) 14 | export(moma_scad) 15 | export(moma_scca) 16 | export(moma_session_info) 17 | export(moma_sfcca) 18 | export(moma_sflda) 19 | export(moma_sfpca) 20 | export(moma_slda) 21 | export(moma_slope) 22 | export(moma_smoothness) 23 | export(moma_spca) 24 | export(moma_spfusedlasso) 25 | export(moma_twfcca) 26 | export(moma_twflda) 27 | export(moma_twfpca) 28 | export(moma_twscca) 29 | export(moma_twslda) 30 | export(moma_twspca) 31 | export(second_diff_mat) 32 | importFrom(Rcpp,evalCpp) 33 | importFrom(stats,setNames) 34 | importFrom(utils,packageDescription) 35 | importFrom(utils,sessionInfo) 36 | useDynLib(MoMA) 37 | -------------------------------------------------------------------------------- /tests/testthat/helper_moma_tests.R: -------------------------------------------------------------------------------- 1 | library(MoMA) 2 | library(stringr) 3 | 4 | expect_no_error <- function(object, ..., all = FALSE, info = NULL, label = NULL) { 5 | expect_error(object, regexp = NA, ..., all = all, info = info, label = label) 6 | } 7 | 8 | expect_no_warning <- function(object, ..., all = FALSE, info = NULL, label = NULL) { 9 | expect_warning(object, regexp = NA, ..., all = all, info = info, label = label) 10 | } 11 | 12 | expect_no_message <- function(object, ..., all = FALSE, info = NULL, label = NULL) { 13 | expect_message(object, regexp = NA, ..., all = all, info = info, label = label) 14 | } 15 | 16 | expect_str_contains <- function(object, expected, info = NULL, label = NULL) { 17 | if (!is.character(object)) object <- as.character(object) 18 | if (!is.character(expected)) expected <- as.character(expected) 19 | 20 | expect_true(all(str_detect(object, expected)), 21 | info = info, label = label 22 | ) 23 | } 24 | -------------------------------------------------------------------------------- /tests/testthat/test_argument_extended.R: -------------------------------------------------------------------------------- 1 | context("Test extended argument helpers") 2 | 3 | test_that("moma_* works", { 4 | expect_true(all( 5 | moma_lasso()$sparsity_type$nonneg == FALSE, 6 | moma_lasso()$sparsity_type$P == "LASSO", 7 | moma_lasso()$sparsity_type$nonneg == FALSE, 8 | class(moma_lasso()) == "moma_sparsity_type", 9 | moma_lasso(non_negative = TRUE)$sparsity_type$nonneg == TRUE, 10 | all(c("lambda", "select_scheme", "non_negative") %in% names(formals(moma_lasso))), 11 | moma_lasso()$lambda == 0, 12 | moma_lasso()$select_scheme == "grid" 13 | )) 14 | 15 | expect_warning( 16 | moma_lasso(TRUE), 17 | "extra argument will be disregarded" 18 | ) 19 | 20 | 21 | expect_true(all( 22 | moma_spfusedlasso(lambda2 = 2, lambda = seq(0, 10))$sparsity_type$lambda2 == 2, 23 | moma_spfusedlasso(lambda2 = 2, lambda = seq(0, 10))$lambda == seq(0, 10) 24 | )) 25 | }) 26 | -------------------------------------------------------------------------------- /tests/testthat/test_prox_SLOPE.R: -------------------------------------------------------------------------------- 1 | context("SLOPE") 2 | 3 | proxSortedL1 <- function(x, l) { 4 | 5 | # Modification: Choose HB type lambda 6 | lambda <- vector(mode = "numeric", length = length(x)) 7 | 8 | for (i in 1:length(x)) { 9 | lambda[i] <- qnorm(1 - i * 0.05 / 2 / length(x)) 10 | } 11 | 12 | lambda <- lambda * l 13 | 14 | # Compare to the SLOPE package on CRAN 15 | result <- SLOPE::prox_sorted_L1(x, lambda, method = "c") 16 | 17 | return(result) 18 | } 19 | 20 | test_that("Compared to the SLOPE package", { 21 | if (requireNamespace("SLOPE")) { 22 | set.seed(123) 23 | reps <- 100 24 | for (i in 1:reps) { 25 | x <- runif(10) 26 | for (lambda in seq(0, 3, 0.2)) { 27 | expect_equal( 28 | test_prox_slope(x, lambda), 29 | as.matrix(proxSortedL1(x, lambda)) 30 | ) 31 | } 32 | } 33 | } 34 | }) 35 | -------------------------------------------------------------------------------- /vignettes/vignettes.bibtex: -------------------------------------------------------------------------------- 1 | @ARTICLE{Eddelbuettel:2014, 2 | TITLE="\texttt{RcppArmadillo}: Accelerating \texttt{R} with High-Performance \texttt{C++} Linear Algebra", 3 | AUTHOR="Dirk Eddelbuettel and Conrad Sanderson", 4 | JOURNAL="Computational Statistics and Data Analysis", 5 | YEAR=2014, 6 | VOLUME=71, 7 | PAGES={1054-1063}, 8 | DOI="10.1016/j.csda.2013.02.005" 9 | } 10 | @ARTICLE{Eddelbuettel:2011, 11 | TITLE="\texttt{Rcpp}: Seamless \texttt{R} and \texttt{C++} Integration", 12 | AUTHOR="Dirk Eddelbuettel and Romain Fran\c{c}ois", 13 | JOURNAL="Journal of Statistical Software", 14 | YEAR=2011, 15 | VOLUME=40, 16 | NUMBER=8, 17 | DOI="10.18637/jss.v040.i08", 18 | PAGES={1-18} 19 | } 20 | @ARTICLE{Sanderson:2016, 21 | TITLE="\texttt{Armadillo}: A Template-Based \texttt{C++} Library for Linear Algebra", 22 | AUTHOR="Conrad Sanderson and Ryan Curtin", 23 | YEAR=2016, 24 | JOURNAL="Journal of Open Source Software", 25 | VOLUME=1, 26 | NUMBER=2, 27 | PAGES={26}, 28 | DOI="10.21105/joss.00026" 29 | } 30 | -------------------------------------------------------------------------------- /src/moma_solver_BICsearch.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef MOMA_SOLVER_BICSEARCH_H 3 | #define MOMA_SOLVER_BICSEARCH_H 1 4 | 5 | #include "moma_base.h" 6 | #include "moma_logging.h" 7 | #include "moma_solver.h" 8 | 9 | class BIC_searcher 10 | { 11 | public: 12 | typedef double (PR_solver::*Criterion)(arma::vec y, const arma::vec &est); 13 | BIC_searcher(){}; 14 | 15 | void bind(PR_solver *object, Criterion method); 16 | 17 | // current criterion 18 | double cur_criterion(arma::vec y, const arma::vec &est); 19 | 20 | ~BIC_searcher() 21 | { 22 | // No need to delete pr_solver 23 | MoMALogger::debug("Releasing a BIC_searcher object"); 24 | } 25 | 26 | Rcpp::List search(const arma::vec &y, // min_{u} || y - u || + ...penalty... 27 | const arma::vec &u, // start point 28 | const arma::vec &alpha_u, 29 | const arma::vec &lambda_u); 30 | 31 | private: 32 | PR_solver *pr_solver; 33 | Criterion cri; 34 | }; 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: MoMA 2 | Title: MoMA - Modern Multivariate Analysis in R 3 | Version: 0.1 4 | Date: 2018-05-07 5 | Authors@R: c( 6 | person("Michael", "Weylandt", email="michael.weylandt@rice.edu", role=c("aut", "cre")), 7 | person("Genevera", "Allen", email="gallen@rice.edu", role="aut"), 8 | person("Luofeng", "Liao", email="luofengl@student.unimelb.edu.au", role="aut"), 9 | person("Nicholas", "Johnson", role = "cph", comment = "src/moma_prox_flsadp.cpp") 10 | ) 11 | Description: Unified approach to modern multivariate analysis providing sparse, 12 | smooth, and structured versions of PCA, PLS, LDA, and CCA. 13 | License: GPL (>= 2) 14 | Imports: Rcpp, R6 15 | Suggests: 16 | knitr, 17 | rmarkdown, 18 | testthat, 19 | covr, 20 | devtools, 21 | stringr, 22 | flsa, 23 | cvxclustr, 24 | SLOPE 25 | LinkingTo: Rcpp (>= 0.12.0), RcppArmadillo (>= 0.8.300.1.0) 26 | RoxygenNote: 6.1.1 27 | VignetteBuilder: knitr 28 | URL: https://github.com/DataSlingers/MoMA 29 | BugReports: https://github.com/DataSlingers/MoMA/issues 30 | -------------------------------------------------------------------------------- /R/internals.R: -------------------------------------------------------------------------------- 1 | #' @importFrom utils packageDescription 2 | moma_git_hash <- function() { 3 | pd <- packageDescription("moma") 4 | gh_file <- system.file("GIT.HASH", package = "moma") 5 | 6 | if (!is.null(pd$RemoteSha)) { # devtools install 7 | return(pd$RemoteSha) 8 | } else if (file.exists(gh_file)) { 9 | return(readLines(gh_file)) 10 | } else { 11 | NA 12 | } 13 | } 14 | 15 | 16 | #' Session Info used for Bug Reporting 17 | #' 18 | #' A helper function which prints information useful in 19 | #' bug reports. 20 | #' 21 | #' @return None. Called for side-effects (printed to the screen) 22 | #' only. 23 | #' @export 24 | #' @importFrom utils sessionInfo 25 | moma_session_info <- function() { 26 | old_print <- options(max.print = 9999) 27 | on.exit(options(old_print)) 28 | 29 | cat("MoMA Git Hash: ", moma_git_hash(), "\n") 30 | 31 | if (requireNamespace("devtools")) { 32 | print(devtools::session_info("moma")) 33 | } else { 34 | print(sessionInfo()) 35 | } 36 | 37 | invisible(NULL) 38 | } 39 | -------------------------------------------------------------------------------- /src/moma_logging.cpp: -------------------------------------------------------------------------------- 1 | #include "moma.h" 2 | 3 | // [[Rcpp::export]] 4 | void moma_set_logger_level_cpp(int level) 5 | { 6 | auto logger_level = static_cast(level); 7 | MoMALogger::set_level(logger_level); 8 | } 9 | 10 | // [[Rcpp::export]] 11 | int moma_get_logger_level_cpp() 12 | { 13 | auto logger_level = static_cast(MoMALogger::get_level()); 14 | return logger_level; 15 | } 16 | 17 | // [[Rcpp::export]] 18 | void moma_log_cpp(int level, Rcpp::StringVector x) 19 | { 20 | auto msg_level = static_cast(level); 21 | std::string msg = Rcpp::as(x[0]); 22 | if (msg_level >= MoMALoggerLevel::ERRORS) 23 | { 24 | MoMALogger::error(msg); 25 | } 26 | else if (msg_level >= MoMALoggerLevel::WARNING) 27 | { 28 | MoMALogger::warning(msg); 29 | } 30 | else if (msg_level >= MoMALoggerLevel::MESSAGES) 31 | { 32 | MoMALogger::message(msg); 33 | } 34 | else if (msg_level >= MoMALoggerLevel::INFO) 35 | { 36 | MoMALogger::info(msg); 37 | } 38 | else if (msg_level >= MoMALoggerLevel::DEBUG) 39 | { 40 | MoMALogger::debug(msg); 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /src/moma_prox_sortedL1.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright 2013, M. Bogdan, E. van den Berg, W. Su, and E.J. Candes 3 | * 4 | * This file is part of SLOPE Toolbox version 1.0. 5 | * 6 | * The SLOPE Toolbox is free software: you can redistribute it 7 | * and/or modify it under the terms of the GNU General Public License 8 | * as published by the Free Software Foundation, either version 3 of 9 | * the License, or (at your option) any later version. 10 | * 11 | * The SLOPE Toolbox is distributed in the hope that it will 12 | * be useful, but WITHOUT ANY WARRANTY; without even the implied 13 | * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 | * See the GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with the SLOPE Toolbox. If not, see 18 | * . 19 | */ 20 | 21 | #ifndef MOMA_PROX_SORTEDL1 22 | #define MOMA_PROX_SORTEDL1 1 23 | 24 | #include "moma_base.h" 25 | 26 | int evaluateProx(const arma::vec &y, 27 | const arma::vec &lambda, 28 | arma::vec &x, 29 | int n, 30 | const arma::uvec &order); 31 | #endif // MOMA_PROX_SORTEDL1 32 | -------------------------------------------------------------------------------- /src/moma_base.h: -------------------------------------------------------------------------------- 1 | /* MoMA Base Header 2 | * 3 | * This is where we put all #defines and #includes which will be 4 | * seen by all other headers 5 | */ 6 | 7 | #ifndef MOMA_BASE_H 8 | #define MOMA_BASE_H 1 9 | 10 | #include 11 | #include 12 | 13 | // We only include RcppArmadillo.h which pulls Rcpp.h in for us 14 | #include "RcppArmadillo.h" 15 | 16 | // For difficult smoothing matrices, we may encounter artificially small 17 | // eigenvalues: we add a small "nugget" here to regularize the computations 18 | #define MOMA_EIGENVALUE_REGULARIZATION 0.01 19 | static constexpr double MOMA_INFTY = std::numeric_limits::infinity(); 20 | static const arma::vec MOMA_EMPTY_GRID_OF_LENGTH1 = -arma::ones(1); 21 | static const double MOMA_FLOATPOINT_EPS = 1e-8; 22 | #define MOMA_FUSEDLASSODP_BUFFERSIZE 5000 23 | enum class DeflationScheme 24 | { 25 | PCA_Hotelling = 1, 26 | CCA = 2, 27 | LDA = 3, 28 | PLS = 4, 29 | PCA_Schur_Complement = 5, 30 | PCA_Projection = 6 31 | }; 32 | 33 | enum class SelectionScheme 34 | { 35 | grid = 0, 36 | BIC = 1, 37 | // AIC = 2 38 | // eBIC = 3 39 | }; 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /R/moma_5Dlist_extractor.R: -------------------------------------------------------------------------------- 1 | get_5Dlist_elem <- function(x, alpha_u_i, lambda_u_i, alpha_v_i, lambda_v_i, rank_i = 1) { 2 | if (!inherits(x, "MoMA_5D_list")) { 3 | moma_error(sQuote("x"), " should be a ", sQuote("MoMA_5D_list"), " object.") 4 | } 5 | n_alpha_u <- dim(x)[1] 6 | n_lambda_u <- dim(x)[2] 7 | n_alpha_v <- dim(x)[3] 8 | n_lambda_v <- dim(x)[4] 9 | n_rank <- dim(x)[5] 10 | 11 | # NOTE: R index starts from 1 12 | if ( 13 | alpha_u_i <= 0 || alpha_u_i > n_alpha_u || 14 | lambda_u_i <= 0 || lambda_u_i > n_lambda_u || 15 | alpha_v_i <= 0 || alpha_v_i > n_alpha_v || 16 | lambda_v_i <= 0 || lambda_v_i > n_lambda_v || 17 | rank_i <= 0 || rank_i > n_rank 18 | ) { 19 | moma_error( 20 | "Invalid index (", alpha_u_i, ",", lambda_u_i, 21 | ",", alpha_v_i, ",", lambda_v_i, ",", rank_i, "), dim = ", 22 | dim(x) 23 | ) 24 | } 25 | 26 | return(x[ 27 | rank_i + n_rank * ( 28 | lambda_v_i - 1 + n_lambda_v * ( 29 | alpha_v_i - 1 + n_alpha_v * ( 30 | lambda_u_i - 1 + n_lambda_u * ( 31 | alpha_u_i - 1 32 | ) 33 | ) 34 | ) 35 | ) 36 | ]) 37 | } 38 | -------------------------------------------------------------------------------- /man/LDA_deflation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_sflda.R 3 | \name{LDA_deflation} 4 | \alias{LDA_deflation} 5 | \title{The Deflation Scheme for LDA} 6 | \description{ 7 | In \code{MoMA} one deflation scheme is provided for LDA. 8 | } 9 | \details{ 10 | Let \eqn{X} be a data matrix (properly scaled and centered), and \eqn{Y} 11 | be the indicator matrix showing which group a sample belongs to. 12 | \eqn{X} and \eqn{Y} should have the same number of columns. The penalized LDA problem is formulated as 13 | 14 | \eqn{ \min_{u,v} \, u^T X^T Y v + \lambda_u P_u(u) + \lambda_v P_v(v) } 15 | 16 | \eqn{ \text{s.t. } \| u \|_{I+\alpha_u \Omega_u} \leq 1, \| v \|_{I + \alpha_v \Omega_v} \leq 1. } 17 | 18 | In the discussion below, let \eqn{u,v} be the solution to the above problem. 19 | Let \eqn{c_x = Xu, c_y = Yv}. The deflation scheme is as follow: 20 | 21 | \eqn{X \leftarrow { X } - { c_x } \left( { c_x } ^ { T } { c_x } \right) ^ { - 1 } { c_x } ^ { T } { X } 22 | = ( I - { c_x } \left( { c_x } ^ { T } { c_x } \right) ^ { - 1 } { c_x } ^ { T } )X,} 23 | 24 | \eqn{ Y \text{ remains unchanged.}}. 25 | } 26 | \references{ 27 | De Bie T., Cristianini N., Rosipal R. (2005) Eigenproblems 28 | in Pattern Recognition. In: Handbook of Geometric Computing. Springer, Berlin, Heidelberg 29 | } 30 | -------------------------------------------------------------------------------- /vignettes/moma-LDA.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Linear Discriminant Analysis with MoMA" 3 | author: "Luofeng Liao" 4 | date: "`r Sys.Date()`" 5 | output: html_vignette 6 | bibliography: vignettes.bibtex 7 | vignette: > 8 | %\VignetteIndexEntry{Linear Discriminant Analysis with MoMA} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | %\VignetteEncoding{UTF-8} 11 | --- 12 | 13 | ```{r echo=FALSE,cache=FALSE} 14 | set.seed(1234) 15 | knitr::opts_chunk$set(cache = TRUE) 16 | ``` 17 | 18 | ## The `iris` Data Set 19 | 20 | Citing the R package `datasets`, "this famous (Fisher's or Anderson's) iris data set gives the measurements in centimeters of the variables sepal length and width and petal length and width, respectively, for 50 flowers from each of 3 species of iris. The species are Iris setosa, versicolor, and virginica." 21 | 22 | There are four features in the data set: `Sepal.Length`, `Sepal.Width`, `Petal.Length`, `Petal.Width`. 23 | 24 | ```{r eval = FALSE} 25 | library(MoMA) 26 | 27 | ## collect data 28 | X <- iris[, 1:4] 29 | grouping <- as.factor(rep(c("s", "c", "v"), rep(50, 3))) 30 | 31 | ## range of penalty 32 | lambda <- seq(0, 1, 0.1) 33 | 34 | ## run! 35 | a <- moma_sflda( 36 | X = X, 37 | Y_factor = grouping, 38 | x_sparse = moma_lasso(lambda = lambda), 39 | rank = 3 40 | ) 41 | 42 | plot(a) # start a Shiny app and play with it! 43 | ``` 44 | 45 | -------------------------------------------------------------------------------- /man/CCA_deflation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_sfcca.R 3 | \name{CCA_deflation} 4 | \alias{CCA_deflation} 5 | \title{The Deflation Scheme for CCA} 6 | \description{ 7 | In \code{MoMA} one deflation scheme is provided for CCA. 8 | } 9 | \details{ 10 | Let \eqn{X,Y} be two data matrices (properly scaled and centered) of the same number of 11 | rows. Each row represents a sample. The penalized CCA problem is formulated as 12 | 13 | \eqn{ \min_{u,v} \, u^T X^T Y v + \lambda_u P_u(u) + \lambda_v P_v(v) } 14 | 15 | \eqn{ \text{s.t. } \| u \|_{I+\alpha_u \Omega_u} \leq 1, \| v \|_{I + \alpha_v \Omega_v} \leq 1. } 16 | 17 | In the discussion below, let \eqn{u,v} be the solution to the above problem. 18 | Let \eqn{c_x = Xu, c_y = Yv}. The deflation scheme is as follow: 19 | 20 | \eqn{X \leftarrow { X } - { c_x } \left( { c_x } ^ { T } { c_x } \right) ^ { - 1 } { c_x } ^ { T } { X } 21 | = ( I - { c_x } \left( { c_x } ^ { T } { c_x } \right) ^ { - 1 } { c_x } ^ { T } )X,} 22 | 23 | \eqn{ Y \leftarrow { Y } - { c_y } \left( { c_y } ^ { T } { c_y } \right) ^ { - 1 } { c_y } ^ { T } { Y } 24 | = (I - { c_y } \left( { c_y } ^ { T } { c_y } \right) ^ { - 1 } { c_y } ^ { T } ) Y}. 25 | } 26 | \references{ 27 | De Bie T., Cristianini N., Rosipal R. (2005) Eigenproblems 28 | in Pattern Recognition. In: Handbook of Geometric Computing. Springer, Berlin, Heidelberg 29 | } 30 | -------------------------------------------------------------------------------- /src/moma_heap.h: -------------------------------------------------------------------------------- 1 | #ifndef MOMA_HEAP 2 | #define MOMA_HEAP 1 3 | #include "moma_base.h" 4 | #include "moma_logging.h" 5 | 6 | class HeapNode 7 | { 8 | public: 9 | HeapNode(int i = -1, double l = -1.0) : id(i), lambda(l){}; 10 | HeapNode &operator=(const HeapNode &source) 11 | { 12 | id = source.id; 13 | lambda = source.lambda; 14 | return *this; 15 | } 16 | int id; // value: id-th beta 17 | double lambda; // key: for id-th group and its next groupto merge at lambda 18 | void print() { MoMALogger::debug("") << "lambda: " << lambda << "id: " << id; } 19 | }; 20 | 21 | // comparision between heap nodes 22 | bool gt(const HeapNode &left, const HeapNode &right); 23 | 24 | class FusedGroups; 25 | class Heap 26 | { 27 | public: 28 | Heap(int n = 0); 29 | void heap_print(); 30 | HeapNode heap_peek_min(); 31 | bool is_empty(); 32 | void heapify(); 33 | std::vector heap_storage; 34 | void remove(int id, FusedGroups *fg); 35 | 36 | int change_lambda_by_id(int id, double new_lambda, FusedGroups *fg); 37 | bool is_minheap(); 38 | 39 | private: 40 | void swap(int i, int j, FusedGroups *fg); 41 | void siftup(int i, FusedGroups *fg); 42 | void siftdown(int current_node, FusedGroups *fg); 43 | 44 | int min_child(int i); 45 | 46 | // A constant, where the non-existing 47 | // child is assumed to be located. 48 | // Used only in function `min_child` 49 | const int NO_CHILD = -11; 50 | }; 51 | #endif 52 | -------------------------------------------------------------------------------- /man/moma_logging.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/logging.R 3 | \name{moma_logger_level} 4 | \alias{moma_logger_level} 5 | \alias{moma_logging} 6 | \title{MoMA Package Logging Functionality} 7 | \usage{ 8 | moma_logger_level(level = c("ERROR", "WARNING", "MESSAGE", "INFO", 9 | "DEBUG")) 10 | } 11 | \arguments{ 12 | \item{level}{The desired new log level. Available levels are \itemize{ 13 | \item \code{ERROR} - corresponding to \code{base::stop}; 14 | \item \code{WARNING} - corresponding to \code{base::warning}; 15 | \item \code{MESSAGE} - corresponding to \code{base::message}; 16 | \item \code{INFO}; and 17 | \item \code{DEBUG.} 18 | } If omitted, the log level is not changed (and the current level is still 19 | returned invisibly.) See below for details about the different levels.} 20 | } 21 | \value{ 22 | The previous log level (invisibly). 23 | } 24 | \description{ 25 | Control the global logging level for the \code{moma} package. 26 | } 27 | \details{ 28 | The \code{moma} package has a multi-level logging system, with a single 29 | global log level; (which applies to both \code{R} and \code{C++} level 30 | functionality.) the levels are, in decreasing order, \code{ERROR}, 31 | \code{WARNING}, \code{MESSAGE} (default), \code{INFO}, \code{DEBUG}. 32 | 33 | To change the amount of output from the \code{moma} package, the 34 | \code{moma_logger_level} function can be used to adjust the global 35 | log level. The \code{INFO} and \code{DEBUG} levels can be quite verbose 36 | and may significantly slow down the package. 37 | } 38 | -------------------------------------------------------------------------------- /tests/testthat/test_util.R: -------------------------------------------------------------------------------- 1 | context("Tests for Util.R") 2 | 3 | test_that("is_* functions", { 4 | expect_true(all( 5 | is_finite_numeric_scalar(1), 6 | !is_finite_numeric_scalar(c()), 7 | is_finite_numeric_scalar(c(1)), 8 | !is_finite_numeric_scalar("a"), 9 | !is_finite_numeric_scalar(Inf), 10 | !is_finite_numeric_scalar(NaN), 11 | !is_finite_numeric_scalar(NA) 12 | )) 13 | 14 | expect_true(all( 15 | # compatible with `is_finite_numeric_scalar` 16 | is_valid_parameters(1), 17 | !is_valid_parameters(c()), 18 | is_valid_parameters(c(1)), 19 | !is_valid_parameters("a"), 20 | !is_valid_parameters(Inf), 21 | !is_valid_parameters(NaN), 22 | !is_valid_parameters(NA), 23 | 24 | !is_valid_parameters(list()), 25 | !is_valid_parameters(c("a", 1)), 26 | !is_valid_parameters(list(1, list(1, 2, 3))), 27 | 28 | !is_valid_parameters(c(1, Inf)), 29 | !is_valid_parameters(c(Inf, 1)), 30 | !is_valid_parameters(c(1, NA)), 31 | !is_valid_parameters(c(NA)), 32 | !is_valid_parameters(c(1, NaN)), 33 | !is_valid_parameters(c(NaN, 1)), 34 | 35 | is_valid_parameters(seq(0, 10)), 36 | is_valid_parameters(matrix(c(1, 2, 3, 4), 2)), 37 | is_valid_parameters(c(1, 2, 3)), 38 | is_valid_parameters(list(1, 2, 3)) 39 | )) 40 | 41 | 42 | expect_true(all( 43 | !is_valid_select_str(1), 44 | !is_valid_select_str("a"), 45 | is_valid_select_str("g"), 46 | is_valid_select_str("b"), 47 | !is_valid_select_str("bb"), 48 | !is_valid_select_str("") 49 | )) 50 | }) 51 | -------------------------------------------------------------------------------- /man/moma_pg_settings.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{moma_pg_settings} 4 | \alias{moma_pg_settings} 5 | \title{Algorithm settings for solving the penalized SVD problem} 6 | \usage{ 7 | moma_pg_settings(..., EPS = 1e-10, MAX_ITER = 1000, 8 | EPS_inner = 1e-10, MAX_ITER_inner = 1e+05, solver = c("ista", 9 | "fista", "onestepista")) 10 | } 11 | \arguments{ 12 | \item{...}{To force users to specify arguments by names.} 13 | 14 | \item{EPS}{Precision for outer loop.} 15 | 16 | \item{MAX_ITER}{The maximum number of iterations for outer loop.} 17 | 18 | \item{EPS_inner}{Precision for inner loop.} 19 | 20 | \item{MAX_ITER_inner}{The maximum number of iterations for inner loop.} 21 | 22 | \item{solver}{A string in \code{c("ista", "fista", "onestepista")}, representing ISTA (Iterative Shrinkage-Thresholding Algorithm), 23 | FISTA (Fast 24 | Iterative Shrinkage-Thresholding Algorithm) and One-step ISTA (an approximated 25 | version of ISTA) respectively.} 26 | } 27 | \value{ 28 | A \code{moma_pg_settings} object, which is a list containing the above parameters. 29 | } 30 | \description{ 31 | This function is used to specify the \code{pg_settings} argument 32 | in the \code{moma_*pca}, \code{moma_*cca}, and \code{moma_*lda} 33 | family of functions. 34 | } 35 | \details{ 36 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 37 | penalized regression problems iteratively (outer loop). Each penalized regression (inner loop) 38 | is solved using one of the three algorithms: ISTA (Iterative Shrinkage-Thresholding Algorithm), 39 | FISTA (Fast Iterative Shrinkage-Thresholding Algorithm) and 40 | One-step ISTA (an approximated version of ISTA). 41 | } 42 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | template: 2 | params: 3 | bootswatch: flatly 4 | 5 | navbar: 6 | type: inverse 7 | right: 8 | - icon: fa-github fa-lg 9 | href: https://github.com/DataSlingers/MoMA 10 | left: 11 | - text: Intro 12 | href: articles/moma-quick-start.html 13 | - text: Reference 14 | href: reference/index.html 15 | - text: Articles 16 | menu: 17 | - text: Funtional Data Analysis 18 | href: articles/moma-functional-data-analysis.html 19 | - text: Principal Component Anlaysis 20 | href: articles/moma-PCA.html 21 | - text: Linear Discriminant Analysis 22 | href: articles/moma-LDA.html 23 | 24 | reference: 25 | - title: Home Page 26 | desc: ~ 27 | contents: 28 | - 'MoMA' 29 | - title: Sparsity Choices 30 | desc: ~ 31 | contents: 32 | - 'moma_sparsity_options' 33 | - '`lasso`' 34 | - '`mcp`' 35 | - '`scad`' 36 | - '`fused_lasso`' 37 | - '`sparse_fused_lasso`' 38 | - '`slope`' 39 | - '`group_lasso`' 40 | - '`l1_trend_filtering`' 41 | - '`cluster`' 42 | - title: Smoothness Choices 43 | desc: ~ 44 | contents: 45 | - '`moma_smoothness`' 46 | - '`second_diff_mat`' 47 | - title: Selection Scheme of Tuning Parameters 48 | desc: ~ 49 | contents: 50 | - '`select_scheme`' 51 | - title: Deflation Schemes 52 | desc: ~ 53 | contents: 54 | - '`PCA_deflation`' 55 | - '`CCA_deflation`' 56 | - '`LDA_deflation`' 57 | - title: Multivariate Models 58 | desc: ~ 59 | contents: 60 | - '`moma_R6`' 61 | - '`moma_sfcca`' 62 | - '`moma_sflda`' 63 | - '`moma_sfpca`' 64 | - title: Logging 65 | desc: ~ 66 | contents: 67 | - '`moma_logger_level`' 68 | - '`moma_session_info`' 69 | - title: Algorithm Settings 70 | desc: ~ 71 | contents: 72 | - '`moma_pg_settings`' 73 | -------------------------------------------------------------------------------- /src/moma_fivedlist.cpp: -------------------------------------------------------------------------------- 1 | #include "moma_fivedlist.h" 2 | 3 | RcppFiveDList::RcppFiveDList(int n_alpha_u, int n_lambda_u, int n_alpha_v, int n_lambda_v, int k) 4 | : n_alpha_u(n_alpha_u), 5 | n_lambda_u(n_lambda_u), 6 | n_alpha_v(n_alpha_v), 7 | n_lambda_v(n_lambda_v), 8 | k(k), 9 | flattened_list(n_alpha_u * n_alpha_v * n_lambda_u * n_lambda_v * k) 10 | { 11 | flattened_list.attr("dim") = 12 | Rcpp::NumericVector::create(n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v, k); 13 | flattened_list.attr("class") = "MoMA_5D_list"; 14 | }; 15 | 16 | int RcppFiveDList::insert(Rcpp::List object, 17 | int alpha_u_i, 18 | int lambda_u_i, 19 | int alpha_v_i, 20 | int lambda_v_i, 21 | int k_i) 22 | { 23 | // insert object in the alpha_u_i-th position along the alpha_u-axis 24 | // and so on 25 | if (alpha_u_i < 0 || alpha_u_i >= n_alpha_u || lambda_u_i < 0 || lambda_u_i >= n_lambda_u || 26 | alpha_v_i < 0 || alpha_v_i >= n_alpha_v || lambda_v_i < 0 || lambda_v_i >= n_lambda_v || 27 | k_i < 0 || k_i >= k) 28 | { 29 | MoMALogger::error("Invalid index is passed to RcppFiveDList::insert. ") 30 | << "Dimension is (" << n_alpha_u << ", " << n_lambda_u << ", " << n_alpha_v << ", " 31 | << n_lambda_v << "," << k << "), received (" << alpha_u_i << ", " << lambda_u_i << ", " 32 | << alpha_v_i << ", " << lambda_v_i << ", " << k_i << ")."; 33 | } 34 | 35 | flattened_list(k_i + k * (lambda_v_i + 36 | n_lambda_v * (alpha_v_i + 37 | n_alpha_v * (lambda_u_i + n_lambda_u * (alpha_u_i))))) = 38 | object; 39 | return 0; 40 | } 41 | 42 | Rcpp::List RcppFiveDList::get_list() 43 | { 44 | return flattened_list; 45 | } 46 | -------------------------------------------------------------------------------- /src/moma_prox_sortedL1.cpp: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright 2013, M. Bogdan, E. van den Berg, W. Su, and E.J. Candes 3 | * 4 | * This file is part of SLOPE Toolbox version 1.0. 5 | * 6 | * The SLOPE Toolbox is free software: you can redistribute it 7 | * and/or modify it under the terms of the GNU General Public License 8 | * as published by the Free Software Foundation, either version 3 of 9 | * the License, or (at your option) any later version. 10 | * 11 | * The SLOPE Toolbox is distributed in the hope that it will 12 | * be useful, but WITHOUT ANY WARRANTY; without even the implied 13 | * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 | * See the GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with the SLOPE Toolbox. If not, see 18 | * . 19 | */ 20 | 21 | #include "moma_prox_sortedL1.h" 22 | #include "moma_logging.h" 23 | 24 | // This is a slight modified version of the code provided by 25 | // M. Bogdan, E. van den Berg, W. Su, and E.J. Candes 26 | // http://statweb.stanford.edu/~candes/SortedL1/ 27 | 28 | int evaluateProx(const arma::vec &y, 29 | const arma::vec &lambda, 30 | arma::vec &x, 31 | int n, 32 | const arma::uvec &order) 33 | { 34 | double d; 35 | 36 | arma::vec s(n); 37 | arma::vec w(n); 38 | arma::uvec idx_i(n); 39 | arma::uvec idx_j(n); 40 | 41 | int i, j, k; 42 | 43 | k = 0; 44 | for (i = 0; i < n; i++) 45 | { 46 | idx_i(k) = i; 47 | idx_j(k) = i; 48 | s(k) = y(i) - lambda(i); 49 | w(k) = s(k); 50 | 51 | while ((k > 0) && (w[k - 1] <= w(k))) 52 | { 53 | k--; 54 | idx_j(k) = i; 55 | s(k) += s[k + 1]; 56 | w(k) = s(k) / (i - idx_i(k) + 1); 57 | } 58 | 59 | k++; 60 | } 61 | 62 | for (j = 0; j < k; j++) 63 | { 64 | d = w(j); 65 | if (d < 0) 66 | { 67 | d = 0; 68 | } 69 | for (i = idx_i(j); i <= idx_j(j); i++) 70 | { 71 | x[order(i)] = d; 72 | } 73 | } 74 | 75 | return 0; 76 | } 77 | -------------------------------------------------------------------------------- /docs/docsearch.js: -------------------------------------------------------------------------------- 1 | $(function() { 2 | 3 | // register a handler to move the focus to the search bar 4 | // upon pressing shift + "/" (i.e. "?") 5 | $(document).on('keydown', function(e) { 6 | if (e.shiftKey && e.keyCode == 191) { 7 | e.preventDefault(); 8 | $("#search-input").focus(); 9 | } 10 | }); 11 | 12 | $(document).ready(function() { 13 | // do keyword highlighting 14 | /* modified from https://jsfiddle.net/julmot/bL6bb5oo/ */ 15 | var mark = function() { 16 | 17 | var referrer = document.URL ; 18 | var paramKey = "q" ; 19 | 20 | if (referrer.indexOf("?") !== -1) { 21 | var qs = referrer.substr(referrer.indexOf('?') + 1); 22 | var qs_noanchor = qs.split('#')[0]; 23 | var qsa = qs_noanchor.split('&'); 24 | var keyword = ""; 25 | 26 | for (var i = 0; i < qsa.length; i++) { 27 | var currentParam = qsa[i].split('='); 28 | 29 | if (currentParam.length !== 2) { 30 | continue; 31 | } 32 | 33 | if (currentParam[0] == paramKey) { 34 | keyword = decodeURIComponent(currentParam[1].replace(/\+/g, "%20")); 35 | } 36 | } 37 | 38 | if (keyword !== "") { 39 | $(".contents").unmark({ 40 | done: function() { 41 | $(".contents").mark(keyword); 42 | } 43 | }); 44 | } 45 | } 46 | }; 47 | 48 | mark(); 49 | }); 50 | }); 51 | 52 | /* Search term highlighting ------------------------------*/ 53 | 54 | function matchedWords(hit) { 55 | var words = []; 56 | 57 | var hierarchy = hit._highlightResult.hierarchy; 58 | // loop to fetch from lvl0, lvl1, etc. 59 | for (var idx in hierarchy) { 60 | words = words.concat(hierarchy[idx].matchedWords); 61 | } 62 | 63 | var content = hit._highlightResult.content; 64 | if (content) { 65 | words = words.concat(content.matchedWords); 66 | } 67 | 68 | // return unique words 69 | var words_uniq = [...new Set(words)]; 70 | return words_uniq; 71 | } 72 | 73 | function updateHitURL(hit) { 74 | 75 | var words = matchedWords(hit); 76 | var url = ""; 77 | 78 | if (hit.anchor) { 79 | url = hit.url_without_anchor + '?q=' + escape(words.join(" ")) + '#' + hit.anchor; 80 | } else { 81 | url = hit.url + '?q=' + escape(words.join(" ")); 82 | } 83 | 84 | return url; 85 | } 86 | -------------------------------------------------------------------------------- /src/moma_solver_BICsearch.cpp: -------------------------------------------------------------------------------- 1 | #include "moma_solver_BICsearch.h" 2 | 3 | void BIC_searcher::bind(PR_solver *object, Criterion method) 4 | { 5 | pr_solver = object; 6 | cri = method; 7 | } 8 | 9 | double BIC_searcher::cur_criterion(arma::vec y, const arma::vec &est) 10 | { 11 | return (pr_solver->*cri)(y, est); 12 | } 13 | 14 | // Return a Rcpp::List: 15 | // Rcpp::Named("lambda") = opt_lambda_u, 16 | // Rcpp::Named("alpha") = opt_alpha_u, 17 | // Rcpp::Named("vector") = working_selected_u, 18 | // Rcpp::Named("bic") = minbic_u 19 | Rcpp::List BIC_searcher::search(const arma::vec &y, // min_{u} || y - u || + ...penalty... 20 | const arma::vec &initial_u, // start point 21 | const arma::vec &alpha_u, 22 | const arma::vec &lambda_u) 23 | { 24 | arma::vec working_selected_u; 25 | arma::vec working_u = initial_u; 26 | double working_bic_u; 27 | double minbic_u = MOMA_INFTY; 28 | double opt_alpha_u; 29 | double opt_lambda_u; 30 | for (int i = 0; i < alpha_u.n_elem; i++) 31 | { 32 | // Put lambda_u in the inner loop to avoid reconstructing S many times 33 | for (int j = 0; j < lambda_u.n_elem; j++) 34 | { 35 | pr_solver->set_penalty(lambda_u(j), alpha_u(i)); 36 | // working_u is the solution of the previous problem 37 | working_u = pr_solver->solve(y, working_u); 38 | working_bic_u = cur_criterion(y, working_u); 39 | MoMALogger::debug("(curBIC, minBIC, lambda, alpha) = (") 40 | << working_bic_u << "," << minbic_u << "," << lambda_u(j) << "," << alpha_u(i) 41 | << ")"; 42 | if (working_bic_u < minbic_u) 43 | { 44 | minbic_u = working_bic_u; 45 | working_selected_u = working_u; 46 | opt_lambda_u = lambda_u(j); 47 | opt_alpha_u = alpha_u(i); 48 | } 49 | } 50 | } 51 | MoMALogger::debug("Finish greedy BIC, chosen (minBIC, alpha, lambda) = (") 52 | << minbic_u << ", " << opt_alpha_u << ", " << opt_lambda_u << ")."; 53 | 54 | return Rcpp::List::create( 55 | Rcpp::Named("lambda") = opt_lambda_u, Rcpp::Named("alpha") = opt_alpha_u, 56 | Rcpp::Named("vector") = working_selected_u, Rcpp::Named("bic") = minbic_u); 57 | }; 58 | -------------------------------------------------------------------------------- /man/moma_smoothness.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{moma_smoothness} 4 | \alias{moma_smoothness} 5 | \title{Smoothness-inducing Term} 6 | \usage{ 7 | moma_smoothness(Omega = NULL, ..., alpha = 0, select_scheme = "g") 8 | } 9 | \arguments{ 10 | \item{Omega}{A matrix of appropriate size. A common choice is the second difference matrix. 11 | See \code{\link{second_diff_mat}}.} 12 | 13 | \item{...}{Force users to specify arguments by names.} 14 | 15 | \item{alpha}{A vector containing penalty values} 16 | 17 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 18 | 19 | MoMA provides a flexible framework for regularized multivariate analysis 20 | with several tuning parameters for different forms of regularization. 21 | To assist the user in selecting these parameters (\code{alpha_u}, 22 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 23 | two selection modes: grid search ("g") and nested BIC search ("b"). 24 | Grid search means we solve the problem 25 | for all combinations of parameter values provided by the user. 26 | 27 | To explain nested BIC search, we need to look into how the algorithm runs. 28 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 29 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 30 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 31 | For each regression problem, we can select the optimal parameters 32 | based on BIC. 33 | 34 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 35 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 36 | current estimate of \emph{u}, and then do the same thing for problem v, 37 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 38 | the above until convergence or the maximal number of iterations has been reached. 39 | 40 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 41 | in the paper cited below.} 42 | } 43 | \description{ 44 | This function specifies the value of the \code{u_smooth,v_smooth} arguments in the 45 | \code{moma_*pca} series of functions, and the \code{x_smooth,y_smooth} arguments 46 | in the \code{moma_*cca} and \code{moma_*lda} series of functions. 47 | } 48 | -------------------------------------------------------------------------------- /tests/testthat/test_grid.R: -------------------------------------------------------------------------------- 1 | context("`cpp_moma_grid_search`` is equivalent to run `MoMA::solve` many times") 2 | 3 | test_that("Using cpp_moma_grid_search is equivalent to run MoMA::solve multiple times", { 4 | set.seed(332) 5 | n <- 7 # set n != p to avoid bugs 6 | p <- 11 7 | X <- matrix(runif(n * p), n) 8 | 9 | # generate p.d. matrices 10 | O_v <- crossprod(matrix(runif(p * p), p, p)) 11 | O_u <- crossprod(matrix(runif(n * n), n, n)) 12 | 13 | # run tests 14 | # NOTE: there's no need to test for large 15 | # lambda's and alpha's because in those 16 | # cases u and v are zeros 17 | sp_set <- seq(0, 3, 0.5) 18 | sm_set <- seq(0, 3, 0.5) 19 | 20 | # WARNING: cannot add scad or mcp here 21 | # I guess because they are non-convex, so 22 | # there is slight difference in the results 23 | 24 | # TODO: Add l1tf 25 | for (sptype in c(lasso, fusedlasso)) { 26 | ista.cv <- moma_svd(X, 27 | Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm_set, 28 | lambda_u = 0, lambda_v = sp_set, u_sparsity = lasso(), v_sparsity = sptype(), 29 | pg_settings = moma_pg_settings(EPS = 1e-14, MAX_ITER = 1e+5, solver = "ista", EPS_inner = 1e-9) 30 | ) 31 | fista.cv <- moma_svd(X, 32 | Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm_set, 33 | lambda_u = 0, lambda_v = sp_set, u_sparsity = lasso(), v_sparsity = sptype(), 34 | pg_settings = moma_pg_settings(EPS = 1e-14, MAX_ITER = 1e+5, solver = "fista", EPS_inner = 1e-9) 35 | ) 36 | cnt <- 1 37 | for (sp in sp_set) { 38 | for (sm in sm_set) { 39 | ista <- moma_svd(X, 40 | Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm, 41 | lambda_u = 0, lambda_v = sp, u_sparsity = lasso(), v_sparsity = sptype(), 42 | pg_settings = moma_pg_settings(EPS = 1e-14, MAX_ITER = 1e+5, solver = "ista", EPS_inner = 1e-9) 43 | ) 44 | fista <- moma_svd(X, 45 | Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm, 46 | lambda_u = 0, lambda_v = sp, u_sparsity = lasso(), v_sparsity = sptype(), 47 | pg_settings = moma_pg_settings(EPS = 1e-14, MAX_ITER = 1e+5, solver = "fista", EPS_inner = 1e-9) 48 | ) 49 | 50 | # Cannot use expect_equal here due to numerical error 51 | expect_lte(sum((ista$v[, 1] - ista.cv$v[, cnt])^2), 1e-7) 52 | expect_lte(sum((fista$v[, 1] - fista.cv$v[, cnt])^2), 1e-7) 53 | cnt <- cnt + 1 54 | } 55 | } 56 | } 57 | }) 58 | -------------------------------------------------------------------------------- /man/slope.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{slope} 4 | \alias{slope} 5 | \alias{moma_slope} 6 | \title{SLOPE (sorted \eqn{\ell}-one penalized estimation)} 7 | \usage{ 8 | moma_slope(..., lambda = 0, select_scheme = "g") 9 | } 10 | \arguments{ 11 | \item{...}{Force users to specify arguments by names.} 12 | 13 | \item{lambda}{A vector containing penalty values} 14 | 15 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 16 | 17 | MoMA provides a flexible framework for regularized multivariate analysis 18 | with several tuning parameters for different forms of regularization. 19 | To assist the user in selecting these parameters (\code{alpha_u}, 20 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 21 | two selection modes: grid search ("g") and nested BIC search ("b"). 22 | Grid search means we solve the problem 23 | for all combinations of parameter values provided by the user. 24 | 25 | To explain nested BIC search, we need to look into how the algorithm runs. 26 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 27 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 28 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 29 | For each regression problem, we can select the optimal parameters 30 | based on BIC. 31 | 32 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 33 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 34 | current estimate of \emph{u}, and then do the same thing for problem v, 35 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 36 | the above until convergence or the maximal number of iterations has been reached. 37 | 38 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 39 | in the paper cited below.} 40 | } 41 | \value{ 42 | A \code{moma_sparsity_type} object, which contains a list containing the string "SLOPE". 43 | } 44 | \description{ 45 | Use this function to set the penalty function to SLOPE - Sorted L-One Penalized Estimation 46 | \deqn{\lambda P (x) = \lambda \sum _ { i = 1 } ^ { n } \lambda _ { i } | x | _ { ( i ) } .} 47 | where \eqn{\lambda_i = \Phi ^ { - 1 } ( 1 - q _ { i } ) , q _ { i } = i \cdot q / 2 p, q = 0.05.} 48 | Here \eqn{q} is the false discovery rate (FDR). 49 | } 50 | \references{ 51 | Bogdan, Malgorzata, et al. "SLOPE - Adaptive Variable Selection via Convex Optimization." 52 | The Annals of Applied Statistics 9.3 (2015): 1103. \doi{10.1214/15-AOAS842}. 53 | } 54 | -------------------------------------------------------------------------------- /man/lasso.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{lasso} 4 | \alias{lasso} 5 | \alias{moma_lasso} 6 | \title{LASSO (least absolute shrinkage and selection operator)} 7 | \usage{ 8 | moma_lasso(..., non_negative = FALSE, ..., lambda = 0, 9 | select_scheme = "g") 10 | } 11 | \arguments{ 12 | \item{...}{Forces users to specify all arguments by name.} 13 | 14 | \item{non_negative}{A Boolean value. Set \code{TRUE} to add non-negativity 15 | constraint.} 16 | 17 | \item{lambda}{A vector containing penalty values} 18 | 19 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 20 | 21 | MoMA provides a flexible framework for regularized multivariate analysis 22 | with several tuning parameters for different forms of regularization. 23 | To assist the user in selecting these parameters (\code{alpha_u}, 24 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 25 | two selection modes: grid search ("g") and nested BIC search ("b"). 26 | Grid search means we solve the problem 27 | for all combinations of parameter values provided by the user. 28 | 29 | To explain nested BIC search, we need to look into how the algorithm runs. 30 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 31 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 32 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 33 | For each regression problem, we can select the optimal parameters 34 | based on BIC. 35 | 36 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 37 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 38 | current estimate of \emph{u}, and then do the same thing for problem v, 39 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 40 | the above until convergence or the maximal number of iterations has been reached. 41 | 42 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 43 | in the paper cited below.} 44 | } 45 | \value{ 46 | A \code{moma_sparsity_type} object, which is a list containing the value of \code{non_negative} 47 | } 48 | \description{ 49 | Use this function to set the penalty function to LASSO 50 | \deqn{\lambda \sum | x_{i} | = \lambda \| x \|_1 ,} 51 | where \eqn{\lambda} is set by the \code{lambda} argument below. 52 | } 53 | \references{ 54 | Tibshirani, Robert. "Regression Shrinkage and Selection via the Lasso." 55 | Journal of the Royal Statistical Society: Series B (Methodological) 58.1 (1996): 267-288. \doi{10.1111/j.2517-6161.1996.tb02080.x}. 56 | } 57 | -------------------------------------------------------------------------------- /tests/testthat/test_MGB_BIC.R: -------------------------------------------------------------------------------- 1 | context("`cpp_multirank_BIC_grid_search` as greedy BIC") 2 | 3 | set.seed(123) 4 | X <- matrix(runif(12), 3, 4) * 10 5 | 6 | # They are mutually prime. This is useful for testing 7 | # the size of the 5D list 8 | n_alpha_u <- 7 9 | n_alpha_v <- 5 10 | n_lambda_u <- 3 11 | n_lambda_v <- 2 12 | rank <- 3 13 | 14 | # Penalties should not be too high. Otherwise 15 | # u and v becomes vectors of zeros, and defaltion 16 | # is thus trivial. 17 | alpha_u <- seq(0, 3, length.out = n_alpha_u) 18 | alpha_v <- seq(0, 3, length.out = n_alpha_v) 19 | lambda_u <- seq(0, 3, length.out = n_lambda_u) 20 | lambda_v <- seq(0, 3, length.out = n_lambda_v) 21 | 22 | # public_arglist_wo_rank_and_selection does not specify two things: rank 23 | # and selection strategy for each parameter. They 24 | # are specified in each test case. 25 | public_arglist_wo_rank_and_selection <- c( 26 | list( 27 | X = X, 28 | alpha_u = alpha_u, alpha_v = alpha_v, 29 | Omega_u = second_diff_mat(3), Omega_v = second_diff_mat(4), 30 | lambda_u = lambda_u, lambda_v = lambda_v, 31 | prox_arg_list_u = add_default_prox_args(lasso()), 32 | prox_arg_list_v = add_default_prox_args(lasso()) 33 | ), 34 | moma_pg_settings() 35 | ) 36 | 37 | test_that("Returns correct vectors for chosen parameters", { 38 | result <- do.call( 39 | cpp_multirank_BIC_grid_search, 40 | c( 41 | public_arglist_wo_rank_and_selection, 42 | list( 43 | select_scheme_alpha_u = 0, # grid 44 | select_scheme_alpha_v = 0, # grid 45 | select_scheme_lambda_u = 1, # bic 46 | select_scheme_lambda_v = 1 # bic 47 | ) 48 | ) 49 | ) 50 | 51 | # Loop order in C++ is (outmost) au, lu, av, lv (innermost) 52 | expect_equal(dim(result), c(7, 1, 5, 1, 1)) 53 | 54 | for (i in 1:n_alpha_u) { 55 | for (j in 1:n_alpha_v) { 56 | res_i_j <- get_5Dlist_elem(result, i, 1, j, 1)[[1]] 57 | opt_alpha_u <- res_i_j$u$alpha 58 | opt_alpha_v <- res_i_j$v$alpha 59 | opt_lambda_u <- res_i_j$u$lambda 60 | opt_lambda_v <- res_i_j$v$lambda 61 | 62 | arglist_unary_penalty <- modifyList( 63 | public_arglist_wo_rank_and_selection, 64 | list( 65 | alpha_u = opt_alpha_u, alpha_v = opt_alpha_v, 66 | lambda_u = opt_lambda_u, lambda_v = opt_lambda_v 67 | ) 68 | ) 69 | 70 | result_directcall <- do.call( 71 | cpp_moma_multi_rank, 72 | arglist_unary_penalty 73 | ) 74 | 75 | expect_equal(result_directcall$u, res_i_j$u$vector) 76 | expect_equal(result_directcall$v, res_i_j$v$vector) 77 | } 78 | } 79 | }) 80 | -------------------------------------------------------------------------------- /src/moma_prox_fusion_util.h: -------------------------------------------------------------------------------- 1 | #ifndef MOMA_PROX_FUSION_UTIL 2 | #define MOMA_PROX_FUSION_UTIL 1 3 | #include "moma_base.h" 4 | #include "moma_heap.h" 5 | class FusedGroups; 6 | class Group 7 | { 8 | public: 9 | // range of the group, note they are continuous 10 | int head; 11 | int tail; 12 | // When two groups (say A and B) merge, 13 | // `parent` of the last node of group B will point to A 14 | // Note all nodes are initialized with `parent` pointing to itself 15 | int parent; 16 | // The following infomation is valid only when `parent` points to itself 17 | double lambda; 18 | double beta; 19 | double slope; 20 | int map_to_heap; 21 | friend class FusedGroups; 22 | Group(int h = -1, 23 | int t = -1, 24 | int p = -1, 25 | double lambda = -1, 26 | double beta = -1, 27 | double slope = 0) 28 | : head(h), tail(t), parent(p), lambda(lambda), beta(beta), slope(slope){}; 29 | void print() 30 | { 31 | MoMALogger::debug("") << "[" << head << "," << tail << "] map_to_heap: " << map_to_heap 32 | << "(lambda:" << lambda << ",beta:" << beta << ",slope: " << slope 33 | << ")"; 34 | } 35 | }; 36 | 37 | class FusedGroups 38 | { 39 | public: 40 | // Constructor 41 | FusedGroups(const arma::vec &x); 42 | // Merge the next two nodes. 43 | // Note if multiple pairs of nodes is to be merged at the same lambda, only 44 | // one pair will be merged 45 | void merge(); 46 | // Return the next lambda at which merge happens 47 | double next_lambda(); 48 | // Check if all beta's are merged 49 | bool all_merged(); 50 | // Evaluate beta by extending the lines 51 | arma::vec find_beta_at(double target_lam); 52 | 53 | // Manipulation on a group 54 | void print(); 55 | bool is_valid(int this_node); 56 | int pre_group(int this_group); 57 | int next_group(int this_group); 58 | int group_size(int this_group); 59 | 60 | // Calculation concerning lines 61 | double line_value_at(double x, double y, double slope, double x_); 62 | double lines_meet_at(double x1, double x2, double k1, double k2, double y1, double y2); 63 | 64 | // Some constants 65 | // Used when the group includes beta_1 66 | const int NO_PRE = -2; 67 | // Used when the group includes beta_p 68 | const int NO_NEXT = -3; 69 | static const int NOT_IN_HEAP = -4; 70 | // This constant is used in the function 71 | // lines_meet_at, where we might bump 72 | // into situation that the two lines are 73 | // parallel. In order to deal with this, 74 | // we return MOMA_INFTY. 75 | 76 | // A vector stroing all the beta values 77 | std::vector g; 78 | Heap heap; 79 | }; 80 | #endif 81 | -------------------------------------------------------------------------------- /vignettes/moma-PCA.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Principal Component Analysis with MoMA" 3 | author: "Luofeng Liao" 4 | date: "`r Sys.Date()`" 5 | output: html_vignette 6 | bibliography: vignettes.bibtex 7 | vignette: > 8 | %\VignetteIndexEntry{Principal Component Analysis with MoMA} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | %\VignetteEncoding{UTF-8} 11 | --- 12 | 13 | ```{r echo=FALSE,cache=FALSE} 14 | set.seed(1234) 15 | knitr::opts_chunk$set(cache = TRUE) 16 | ``` 17 | 18 | ## The `mtcar` Data Set 19 | 20 | Citing the R documentation of the `mtcar` (Motor Trend Car Road Tests) data set, "the data was extracted from the 1974 Motor Trend US magazine, and comprises fuel consumption and 10 aspects of automobile design and performance for 32 automobiles (1973–74 models)". 21 | 22 | The data format is as follows. 23 | 24 | ``` 25 | [, 1] mpg: Miles/(US) gallon 26 | [, 2] cyl: Number of cylinders 27 | [, 3] disp: Displacement (cu.in.) 28 | [, 4] hp: Gross horsepower 29 | [, 5] drat: Rear axle ratio 30 | [, 6] wt: Weight (1000 lbs) 31 | [, 7] qsec: 1/4 mile time 32 | [, 8] vs: Engine (0 = V-shaped, 1 = straight) 33 | [, 9] am: Transmission (0 = automatic, 1 = manual) 34 | [,10] gear: Number of forward gears 35 | [,11] carb: Number of carburetors 36 | ``` 37 | 38 | Suppose we are interested in creating new "features" that 39 | 40 | * are linear combinations of known features, 41 | 42 | * cpature as much information as possible, and 43 | 44 | * comprise of only some of the known features. 45 | 46 | Then we can use the `moma_spca()` function (Sparse Principal Component Analysis). 47 | 48 | ```{r message=FALSE} 49 | library(MoMA) 50 | 51 | # Get rid of two categorical variables: 52 | # X[, 8]: Engine (0 = V-shaped, 1 = straight) 53 | # X[, 9]: Transmission (0 = automatic, 1 = manual 54 | X <- as.matrix(datasets::mtcars[, c(1:7, 10, 11)]) 55 | lambda_len <- 30 56 | 57 | a <- moma_spca(X, 58 | center = TRUE, scale = TRUE, 59 | v_sparse = moma_lasso( 60 | lambda = seq(0, 5, length.out = lambda_len) 61 | ), 62 | rank = 2 63 | ) 64 | ``` 65 | 66 | 67 | ## Access the Results 68 | 69 | #### Get the loadings by `get_mat_by_index()$V`. 70 | ```{r} 71 | ld_10 <- a$get_mat_by_index(lambda_v = 10) 72 | 73 | cat("chosen lambda for the first PC = ", ld_10$chosen_lambda_v[1], "\n") 74 | cat("chosen lambda for the second PC = ", ld_10$chosen_lambda_v[2], "\n") 75 | print(ld_10$V) 76 | ``` 77 | 78 | #### Project New Data 79 | 80 | Project new data onto the space spanned by new principal components. 81 | 82 | ```{r} 83 | # Let's pretend the first ten rows of `mtcars` are new data 84 | newX <- X[1:10, ] 85 | 86 | # `rank = 2`: the dimension of projected space 87 | # `lambda_v`: an integer, the penalty level 88 | a$left_project(newX = newX, rank = 2, lambda_v = 5)$proj_data 89 | ``` 90 | 91 | #### Start a Shiny App 92 | 93 | Start a Shiny App and see how penalty levels affect loadings and the 2-D projection of original data. 94 | 95 | ```{r eval = FALSE} 96 | plot(a) 97 | ``` 98 | 99 | -------------------------------------------------------------------------------- /man/mcp.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{mcp} 4 | \alias{mcp} 5 | \alias{moma_mcp} 6 | \title{MCP (minimax concave penalty)} 7 | \usage{ 8 | moma_mcp(..., gamma = 3, non_negative = FALSE, ..., lambda = 0, 9 | select_scheme = "g") 10 | } 11 | \arguments{ 12 | \item{...}{Forces users to specify all arguments by name.} 13 | 14 | \item{gamma}{Non-convexity. Must be larger than 1.} 15 | 16 | \item{non_negative}{A Boolean value. Set to \code{TRUE} to add non-negativity 17 | constraint.} 18 | 19 | \item{lambda}{A vector containing penalty values} 20 | 21 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 22 | 23 | MoMA provides a flexible framework for regularized multivariate analysis 24 | with several tuning parameters for different forms of regularization. 25 | To assist the user in selecting these parameters (\code{alpha_u}, 26 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 27 | two selection modes: grid search ("g") and nested BIC search ("b"). 28 | Grid search means we solve the problem 29 | for all combinations of parameter values provided by the user. 30 | 31 | To explain nested BIC search, we need to look into how the algorithm runs. 32 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 33 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 34 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 35 | For each regression problem, we can select the optimal parameters 36 | based on BIC. 37 | 38 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 39 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 40 | current estimate of \emph{u}, and then do the same thing for problem v, 41 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 42 | the above until convergence or the maximal number of iterations has been reached. 43 | 44 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 45 | in the paper cited below.} 46 | } 47 | \value{ 48 | A \code{moma_sparsity_type} object, which is a list containing the value of \code{non_negative} 49 | and \code{gamma}. 50 | } 51 | \description{ 52 | Use this function to set the penalty function to MCP 53 | \deqn{ P (x; \lambda, \gamma) = 54 | \left\{\begin{array}{ll}{\lambda|x|-\frac{x^{2}}{2 \gamma},} & { 55 | \text { if }|x| \leq \gamma \lambda} \\ {\frac{1}{2} \gamma 56 | \lambda^{2},} & {\text { if }|x|>\gamma \lambda}\end{array}\right.,} 57 | where \eqn{\lambda} is set by the \code{lambda} argument below. 58 | } 59 | \references{ 60 | Zhang, Cun-Hui. "Nearly Unbiased Variable 61 | Selection under Minimax Concave Penalty." The Annals of Statistics 38.2 (2010): 894-942. \doi{10.1214/09-AOS729}. 62 | } 63 | -------------------------------------------------------------------------------- /man/group_lasso.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{group_lasso} 4 | \alias{group_lasso} 5 | \alias{moma_grplasso} 6 | \title{Group LASSO} 7 | \usage{ 8 | moma_grplasso(..., g, non_negative = FALSE, ..., lambda = 0, 9 | select_scheme = "g") 10 | } 11 | \arguments{ 12 | \item{...}{Forces users to specify all arguments by name.} 13 | 14 | \item{g}{A vector of integer or characters, or a factor itself. It gets transformed 15 | to factor eventually to indicate grouping.} 16 | 17 | \item{non_negative}{A Boolean value. Set it to \code{TRUE} to add non-negativity 18 | constraint.} 19 | 20 | \item{lambda}{A vector containing penalty values} 21 | 22 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 23 | 24 | MoMA provides a flexible framework for regularized multivariate analysis 25 | with several tuning parameters for different forms of regularization. 26 | To assist the user in selecting these parameters (\code{alpha_u}, 27 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 28 | two selection modes: grid search ("g") and nested BIC search ("b"). 29 | Grid search means we solve the problem 30 | for all combinations of parameter values provided by the user. 31 | 32 | To explain nested BIC search, we need to look into how the algorithm runs. 33 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 34 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 35 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 36 | For each regression problem, we can select the optimal parameters 37 | based on BIC. 38 | 39 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 40 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 41 | current estimate of \emph{u}, and then do the same thing for problem v, 42 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 43 | the above until convergence or the maximal number of iterations has been reached. 44 | 45 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 46 | in the paper cited below.} 47 | } 48 | \value{ 49 | A \code{moma_sparsity_type} object, which is a list containing the values of \code{non_negative} 50 | and \code{g}. 51 | } 52 | \description{ 53 | Use this function to set the penalty function to group lasso 54 | \deqn{\lambda \sum_{g \in Group} \| x_g \|_1,} 55 | where \eqn{\lambda} is set by the \code{lambda} argument below, \eqn{x_g} is 56 | the vector comprised of elements of \eqn{x} picked out by the indices set \eqn{g}. 57 | } 58 | \references{ 59 | Yuan, Ming, and Yi Lin. "Model Selection and Estimation in Regression 60 | with Grouped Variables." Journal of the Royal Statistical Society: 61 | Series B (Statistical Methodology) 68.1 (2006): 49-67. \doi{10.1111/j.1467-9868.2005.00532.x}. 62 | } 63 | -------------------------------------------------------------------------------- /man/sparse_fused_lasso.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{sparse_fused_lasso} 4 | \alias{sparse_fused_lasso} 5 | \alias{moma_spfusedlasso} 6 | \title{Sparse fused LASSO} 7 | \usage{ 8 | moma_spfusedlasso(..., lambda2, ..., lambda = 0, select_scheme = "g") 9 | } 10 | \arguments{ 11 | \item{...}{Forces users to specify all arguments by name.} 12 | 13 | \item{lambda2}{A scalar. The level of penalty on the absolute values of the coefficients. 14 | Note that it remains fixed when searching over \code{lambda}, rather than 15 | changes with \code{lambda} in a way that the \code{lambda} / \code{lambda_2} 16 | ratio remains fixed (which is the defualt behavior in the package 17 | \code{glmnet}).} 18 | 19 | \item{lambda}{A vector containing penalty values} 20 | 21 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 22 | 23 | MoMA provides a flexible framework for regularized multivariate analysis 24 | with several tuning parameters for different forms of regularization. 25 | To assist the user in selecting these parameters (\code{alpha_u}, 26 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 27 | two selection modes: grid search ("g") and nested BIC search ("b"). 28 | Grid search means we solve the problem 29 | for all combinations of parameter values provided by the user. 30 | 31 | To explain nested BIC search, we need to look into how the algorithm runs. 32 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 33 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 34 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 35 | For each regression problem, we can select the optimal parameters 36 | based on BIC. 37 | 38 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 39 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 40 | current estimate of \emph{u}, and then do the same thing for problem v, 41 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 42 | the above until convergence or the maximal number of iterations has been reached. 43 | 44 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 45 | in the paper cited below.} 46 | } 47 | \value{ 48 | A \code{moma_sparsity_type} object, which is a list containing the value of \code{lambda_2}. 49 | } 50 | \description{ 51 | Use this function to set the penalty function to sparse fused lasso 52 | \deqn{\lambda \sum | x_{i} - x_{i-1} | + \lambda_2 \sum |x_{i} | ,} 53 | where \eqn{\lambda} is set by the \code{lambda} argument below, and \eqn{\lambda_2} 54 | is specified in by the \code{lambda_2} argument. 55 | } 56 | \references{ 57 | Tibshirani, Robert, et al. "Sparsity and Smoothness via the Fused Lasso." 58 | Journal of the Royal Statistical Society: Series B (Statistical Methodology) 67.1 (2005): 91-108. 59 | \doi{10.1111/j.1467-9868.2005.00490.x}. 60 | } 61 | -------------------------------------------------------------------------------- /man/cluster.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{cluster} 4 | \alias{cluster} 5 | \alias{moma_cluster} 6 | \title{Cluster penalty} 7 | \usage{ 8 | moma_cluster(..., w = NULL, ADMM = FALSE, acc = FALSE, eps = 1e-10, 9 | ..., lambda = 0, select_scheme = "g") 10 | } 11 | \arguments{ 12 | \item{...}{Forces users to specify all arguments by name.} 13 | 14 | \item{w}{A symmetric square matrix. \code{w[i, j]} is the \eqn{w_{ij}} described above.} 15 | 16 | \item{ADMM}{A Boolean value. Set to \code{TRUE} to use ADMM, set to \code{FALSE} to use AMA. Defaults to FALSE.} 17 | 18 | \item{acc}{A Boolean value. Set to \code{TRUE} to use the accelerated version of the algorithm. 19 | Currently we support accelerated AMA only.} 20 | 21 | \item{eps}{A small numeric value. The precision used when solving the proximal operator.} 22 | 23 | \item{lambda}{A vector containing penalty values} 24 | 25 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 26 | 27 | MoMA provides a flexible framework for regularized multivariate analysis 28 | with several tuning parameters for different forms of regularization. 29 | To assist the user in selecting these parameters (\code{alpha_u}, 30 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 31 | two selection modes: grid search ("g") and nested BIC search ("b"). 32 | Grid search means we solve the problem 33 | for all combinations of parameter values provided by the user. 34 | 35 | To explain nested BIC search, we need to look into how the algorithm runs. 36 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 37 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 38 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 39 | For each regression problem, we can select the optimal parameters 40 | based on BIC. 41 | 42 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 43 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 44 | current estimate of \emph{u}, and then do the same thing for problem v, 45 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 46 | the above until convergence or the maximal number of iterations has been reached. 47 | 48 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 49 | in the paper cited below.} 50 | } 51 | \value{ 52 | A \code{moma_sparsity_type} object, which is a list containing the values of \code{w}, 53 | \code{ADMM}, \code{acc} and \code{eps}. 54 | } 55 | \description{ 56 | Use this function to set the penalty function to 57 | \deqn{\lambda \sum w_{ij} | x_{i} - x_{j} |,} 58 | where \eqn{\lambda} is set by the \code{lambda} argument below. 59 | } 60 | \references{ 61 | Chi, Eric C., and Kenneth Lange. "Splitting Methods for Convex Clustering." 62 | Journal of Computational and Graphical Statistics 24.4 (2015): 994-1013. \doi{10.1080/10618600.2014.948181}. 63 | } 64 | -------------------------------------------------------------------------------- /man/scad.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{scad} 4 | \alias{scad} 5 | \alias{moma_scad} 6 | \title{SCAD (smoothly clipped absolute deviation)} 7 | \usage{ 8 | moma_scad(..., gamma = 3.7, non_negative = FALSE, ..., lambda = 0, 9 | select_scheme = "g") 10 | } 11 | \arguments{ 12 | \item{...}{Forces users to specify all arguments by name.} 13 | 14 | \item{gamma}{Non-convexity. Must be larger than 2.} 15 | 16 | \item{non_negative}{A Boolean value. Set to \code{TRUE} to add non-negativity 17 | constraint.} 18 | 19 | \item{lambda}{A vector containing penalty values} 20 | 21 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 22 | 23 | MoMA provides a flexible framework for regularized multivariate analysis 24 | with several tuning parameters for different forms of regularization. 25 | To assist the user in selecting these parameters (\code{alpha_u}, 26 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 27 | two selection modes: grid search ("g") and nested BIC search ("b"). 28 | Grid search means we solve the problem 29 | for all combinations of parameter values provided by the user. 30 | 31 | To explain nested BIC search, we need to look into how the algorithm runs. 32 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 33 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 34 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 35 | For each regression problem, we can select the optimal parameters 36 | based on BIC. 37 | 38 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 39 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 40 | current estimate of \emph{u}, and then do the same thing for problem v, 41 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 42 | the above until convergence or the maximal number of iterations has been reached. 43 | 44 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 45 | in the paper cited below.} 46 | } 47 | \value{ 48 | A \code{moma_sparsity_type} object, which is a list containing the values of \code{non_negative} 49 | and \code{gamma}. 50 | } 51 | \description{ 52 | Use this function to set the penalty function to SCAD 53 | \deqn{ P (x; \lambda, \gamma) = \left\{\begin{array}{ll}{ 54 | \lambda|x|} & {\text { if }|x| \leq \lambda} \\ {\frac{2 \gamma \lambda|x|-x^{2}- 55 | \lambda^{2}}{2(\gamma-1)}} & {\text { if } \lambda<|x|<\gamma \lambda} \\ 56 | {\frac{\lambda^{2}(\gamma+1)}{2}} & {\text { if }|x| \geq \gamma \lambda}\end{array}\right.,} 57 | where \eqn{\lambda} is set by the \code{lambda} argument below. 58 | } 59 | \references{ 60 | Fan, Jianqing, and Runze Li. "Variable Selection 61 | via Nonconcave Penalized Likelihood and Its Oracle Properties." Journal of 62 | the American Statistical Association 96.456 (2001): 1348-1360. \doi{10.1198/016214501753382273}. 63 | } 64 | -------------------------------------------------------------------------------- /man/fused_lasso.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{fused_lasso} 4 | \alias{fused_lasso} 5 | \alias{moma_fusedlasso} 6 | \title{Fused LASSO} 7 | \usage{ 8 | moma_fusedlasso(..., algo = c("path", "dp"), ..., lambda = 0, 9 | select_scheme = "g") 10 | } 11 | \arguments{ 12 | \item{...}{Forces users to specify all arguments by name.} 13 | 14 | \item{algo}{A string being either "path" or "dp". Defaults to "path". Partial matching 15 | is supported. Two solving algorithms 16 | are provided. When "path" is chosen, the algorithm by 17 | Hoefling, H. (2010) is used. When "dp" is chosen, the algorithm by Johnson, N. A. (2013) is used.} 18 | 19 | \item{lambda}{A vector containing penalty values} 20 | 21 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 22 | 23 | MoMA provides a flexible framework for regularized multivariate analysis 24 | with several tuning parameters for different forms of regularization. 25 | To assist the user in selecting these parameters (\code{alpha_u}, 26 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 27 | two selection modes: grid search ("g") and nested BIC search ("b"). 28 | Grid search means we solve the problem 29 | for all combinations of parameter values provided by the user. 30 | 31 | To explain nested BIC search, we need to look into how the algorithm runs. 32 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 33 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 34 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 35 | For each regression problem, we can select the optimal parameters 36 | based on BIC. 37 | 38 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 39 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 40 | current estimate of \emph{u}, and then do the same thing for problem v, 41 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 42 | the above until convergence or the maximal number of iterations has been reached. 43 | 44 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 45 | in the paper cited below.} 46 | } 47 | \value{ 48 | A \code{moma_sparsity_type} object, which is an empty list. 49 | } 50 | \description{ 51 | Use this function to set the penalty function to fused lasso 52 | \deqn{\lambda \sum | x_{i} - x_{i-1} |,} 53 | where \eqn{\lambda} is set by the \code{lambda} argument below. 54 | } 55 | \references{ 56 | Tibshirani, Robert, et al. "Sparsity and Smoothness via the Fused Lasso." 57 | Journal of the Royal Statistical Society: Series B (Statistical Methodology) 67.1 (2005): 91-108. 58 | \doi{10.1111/j.1467-9868.2005.00490.x}. 59 | 60 | Hoefling, H. (2010). A path algorithm 61 | for the fused lasso signal approximator. Journal of Computational and Graphical 62 | Statistics, 19(4), 984-1006. \doi{10.1198/jcgs.2010.09208}. 63 | 64 | Johnson, N. A. (2013). A dynamic programming algorithm for the 65 | fused lasso and l 0-segmentation. Journal of Computational and Graphical 66 | Statistics, 22(2), 246-260. \doi{10.1080/10618600.2012.681238}. 67 | } 68 | -------------------------------------------------------------------------------- /man/moma_sparsity_options.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{moma_sparsity_options} 4 | \alias{moma_sparsity_options} 5 | \title{Sparsity-inducing penalty in \code{MoMA}} 6 | \arguments{ 7 | \item{...}{Force users to specify arguments by names.} 8 | 9 | \item{lambda}{A vector containing penalty values} 10 | 11 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 12 | 13 | MoMA provides a flexible framework for regularized multivariate analysis 14 | with several tuning parameters for different forms of regularization. 15 | To assist the user in selecting these parameters (\code{alpha_u}, 16 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 17 | two selection modes: grid search ("g") and nested BIC search ("b"). 18 | Grid search means we solve the problem 19 | for all combinations of parameter values provided by the user. 20 | 21 | To explain nested BIC search, we need to look into how the algorithm runs. 22 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 23 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 24 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 25 | For each regression problem, we can select the optimal parameters 26 | based on BIC. 27 | 28 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 29 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 30 | current estimate of \emph{u}, and then do the same thing for problem v, 31 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 32 | the above until convergence or the maximal number of iterations has been reached. 33 | 34 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 35 | in the paper cited below.} 36 | } 37 | \description{ 38 | In the package \code{MoMA}, we support the following sparsity-inducing 39 | penalty functions. 40 | \itemize{ 41 | \item{\code{\link{moma_lasso}}}: sparsity 42 | \item{\code{\link{moma_mcp}}}: non-convex sparsity 43 | \item{\code{\link{moma_scad}}}: non-convex sparsity 44 | \item{\code{\link{moma_slope}}}: sparsity 45 | \item{\code{\link{moma_grplasso}}}: group-wise sparsity 46 | \item{\code{\link{moma_fusedlasso}}}: piecewise constant, or ordered fusion 47 | \item{\code{\link{moma_spfusedlasso}}}: sparsity and piece-wise constant 48 | \item{\code{\link{moma_l1tf}}}: piecewise polynomial (default to piecewise linear) 49 | \item{\code{\link{moma_cluster}}}: unordered fusion 50 | } 51 | These functions specify the value of the \code{u_sparse,v_sparse} arguments in the 52 | \code{moma_*pca} series of functions, and the \code{x_sparse,y_sparse} arguments 53 | in the \code{moma_*cca} and \code{moma_*lda} series of functions. 54 | } 55 | \details{ 56 | All functions 57 | above share two common parameters: \code{lambda} and \code{select_scheme}, which are 58 | described in the Arguments section. 59 | } 60 | \references{ 61 | G. I. Allen and M. Weylandt, "Sparse and Functional Principal 62 | Components Analysis," 2019 IEEE Data Science Workshop (DSW), 63 | Minneapolis, MN, USA, 2019, pp. 11-16. \doi{10.1109/DSW.2019.8755778}. 64 | } 65 | -------------------------------------------------------------------------------- /man/l1_trend_filtering.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_arguments.R 3 | \name{l1_trend_filtering} 4 | \alias{l1_trend_filtering} 5 | \alias{moma_l1tf} 6 | \title{L1 trend filtering} 7 | \usage{ 8 | moma_l1tf(..., l1tf_k = 1, ..., lambda = 0, select_scheme = "g") 9 | } 10 | \arguments{ 11 | \item{...}{Forces users to specify all arguments by name.} 12 | 13 | \item{l1tf_k}{Use (\eqn{k+1})-difference matrix in trend filtering. Note \eqn{k = 0} 14 | implies piecewise constant, \eqn{k=1} implies piecewise linear, \eqn{k=2} 15 | piecewise quadratic etc.} 16 | 17 | \item{lambda}{A vector containing penalty values} 18 | 19 | \item{select_scheme}{A char being either "b" (nested BIC search) or "g" (grid search). 20 | 21 | MoMA provides a flexible framework for regularized multivariate analysis 22 | with several tuning parameters for different forms of regularization. 23 | To assist the user in selecting these parameters (\code{alpha_u}, 24 | \code{alpha_v}, \code{lambda_u}, \code{lambda_v}), we provide 25 | two selection modes: grid search ("g") and nested BIC search ("b"). 26 | Grid search means we solve the problem 27 | for all combinations of parameter values provided by the user. 28 | 29 | To explain nested BIC search, we need to look into how the algorithm runs. 30 | To find an (approximate) solution to a penalized SVD (Singular Value Decomposition) problem is to solve two 31 | penalized regression problems iteratively. Let's call them problem u and problem v, which give 32 | improving estimates of the right singular vector, \emph{u}, and the left singular vector, \emph{v}, respectively. 33 | For each regression problem, we can select the optimal parameters 34 | based on BIC. 35 | 36 | The nested BIC search is essentially two 2-D searches. We start from SVD solutions, and then find the optimal 37 | parameters for problem u, given current estimate of \emph{v}. Using the result from previous step, update 38 | current estimate of \emph{u}, and then do the same thing for problem v, 39 | that is, to find the optimal parameters for problem v given current estimate of \emph{u}. Repeat 40 | the above until convergence or the maximal number of iterations has been reached. 41 | 42 | Users are welcome to refer to section 3.1: Selection of Regularization Parameters 43 | in the paper cited below.} 44 | } 45 | \value{ 46 | A \code{moma_sparsity_type} object, which is an empty list. 47 | } 48 | \description{ 49 | Use this function to set the penalty function to l1 trend filtering. An 50 | important special case is when \eqn{k=1}. In this case the penalty 51 | term becomes 52 | \deqn{\lambda \sum | x_{i-1} - 2x_{i} + x_{i+1} |,} 53 | where \eqn{\lambda} is set by the \code{lambda} argument below. 54 | } 55 | \details{ 56 | The general formula of the penalty term for \eqn{k \in N} can be found in 57 | the paper cited in Reference. For other values of \eqn{k} please refer to the following table: 58 | \tabular{llll}{ 59 | \tab \eqn{k = 0} \tab \eqn{k = 1} \tab \eqn{k = 2} 60 | \cr 61 | Type of sparsity \tab piecewise constant \tab peicewise linear \tab piecewise quadratic 62 | } 63 | } 64 | \references{ 65 | Tibshirani, Ryan J. "Adaptive Piecewise Polynomial Estimation via Trend 66 | Filtering." The Annals of Statistics 42.1 (2014): 285-323. \doi{10.1214/13-AOS1189}. 67 | 68 | Aaditya Ramdas & Ryan J. Tibshirani (2016) Fast and Flexible ADMM 69 | Algorithms for Trend Filtering, Journal of Computational and Graphical Statistics, 70 | 25:3, 839-858. \doi{10.1080/10618600.2015.1054033}. 71 | } 72 | -------------------------------------------------------------------------------- /R/moma_solve.R: -------------------------------------------------------------------------------- 1 | sfpca <- function(X, 2 | # sparsity 3 | P_v = "none", 4 | P_u = "none", 5 | lambda_v = 0, # a vector or scalar, same for lambda_u, alpha_u/v 6 | lambda_u = 0, 7 | gamma_v = 3, 8 | gamma_u = 3, 9 | # non-negativity 10 | nonneg_u = FALSE, 11 | nonneg_v = FALSE, 12 | # grouping 13 | group_u = MOMA_EMPTYVEC, 14 | group_v = MOMA_EMPTYVEC, 15 | # sparse fused lasso 16 | lambda2_u = 0, # penalty on the abs value of parameters 17 | lambda2_v = 0, 18 | # unordered fusion 19 | w_u = MOMA_EMPTYMAT, 20 | w_v = MOMA_EMPTYMAT, 21 | ADMM_u = FALSE, 22 | ADMM_v = FALSE, 23 | acc_u = FALSE, 24 | acc_v = FALSE, 25 | prox_eps_u = 1e-10, 26 | prox_eps_v = 1e-10, 27 | # trend filtering 28 | l1tf_k_u = 1, 29 | l1tf_k_v = 1, 30 | # smoothness 31 | Omega_u = NULL, 32 | Omega_v = NULL, 33 | alpha_u = 0, 34 | alpha_v = 0, 35 | # algorithm parameters 36 | EPS = 1e-10, 37 | MAX_ITER = 1000, 38 | EPS_inner = 1e-10, 39 | MAX_ITER_inner = 1e+5, 40 | solver = "ista", 41 | k = 1) { 42 | if (!is.null(X) && !is.matrix(X)) { 43 | moma_error("X must be a matrix.") 44 | } 45 | n <- dim(X)[1] 46 | p <- dim(X)[2] 47 | 48 | 49 | P_u <- toupper(P_u) 50 | P_v <- toupper(P_v) 51 | solver <- toupper(solver) 52 | 53 | alpha_u <- as.vector(alpha_u) 54 | alpha_v <- as.vector(alpha_v) 55 | lambda_u <- as.vector(lambda_u) 56 | lambda_v <- as.vector(lambda_v) 57 | 58 | Omega_u <- Omega_u %||% diag(dim(X)[1]) 59 | Omega_v <- Omega_v %||% diag(dim(X)[2]) 60 | 61 | prox_arg_list_u <- list( 62 | w = w_u, 63 | Omega = Omega_u, 64 | alpha = alpha_u, 65 | lambda = lambda_u, 66 | P = P_u, 67 | gamma = gamma_u, 68 | lambda2 = lambda2_u, 69 | ADMM = ADMM_u, 70 | acc = acc_u, 71 | prox_eps = prox_eps_u, 72 | l1tf_k = l1tf_k_u, 73 | nonneg = nonneg_u, 74 | group = group_u 75 | ) 76 | prox_arg_list_v <- list( 77 | w = w_v, 78 | Omega = Omega_v, 79 | alpha = alpha_v, 80 | lambda = lambda_v, 81 | P = P_v, 82 | gamma = gamma_v, 83 | lambda2 = lambda2_v, 84 | ADMM = ADMM_v, 85 | acc = acc_v, 86 | prox_eps = prox_eps_v, 87 | l1tf_k = l1tf_k_v, 88 | nonneg = nonneg_v, 89 | group = group_v 90 | ) 91 | return(cpp_moma_multi_rank( 92 | X = X, 93 | alpha_u = alpha_u, alpha_v = alpha_v, 94 | Omega_u = Omega_u, Omega_v = Omega_v, 95 | lambda_u = lambda_u, lambda_v = lambda_v, 96 | prox_arg_list_u = prox_arg_list_u, 97 | prox_arg_list_v = prox_arg_list_v, 98 | EPS = EPS, MAX_ITER = MAX_ITER, 99 | EPS_inner = EPS_inner, MAX_ITER_inner = MAX_ITER_inner, 100 | solver = solver, 101 | rank = k 102 | )) 103 | } 104 | -------------------------------------------------------------------------------- /tests/testthat/test_MBG-single_problem.R: -------------------------------------------------------------------------------- 1 | context("`cpp_multirank_BIC_grid_search` as solving a single problem") 2 | 3 | set.seed(123) 4 | X <- matrix(runif(12), 3, 4) * 10 5 | 6 | # They are mutually prime. This is useful for testing 7 | # the size of the 5D list 8 | n_alpha_u <- 7 9 | n_alpha_v <- 5 10 | n_lambda_u <- 5 11 | n_lambda_v <- 5 12 | rank <- 1 13 | 14 | # Penalties should not be too high. Otherwise 15 | # u and v becomes vectors of zeros, and defaltion 16 | # is thus trivial. 17 | alpha_u <- seq(0, 10, length.out = n_alpha_u) 18 | alpha_v <- seq(0, 10, length.out = n_alpha_v) 19 | lambda_u <- seq(0, 10, length.out = n_lambda_u) 20 | lambda_v <- seq(0, 10, length.out = n_lambda_v) 21 | 22 | # public_arglist_wo_penalty does not specify 23 | public_arglist_wo_penalty <- c( 24 | list( 25 | X = X, 26 | # alpha_u = alpha_u, alpha_v = alpha_v, 27 | Omega_u = second_diff_mat(3), Omega_v = second_diff_mat(4), 28 | # lambda_u = lambda_u, lambda_v = lambda_v, 29 | prox_arg_list_u = add_default_prox_args(lasso()), 30 | prox_arg_list_v = add_default_prox_args(lasso()), 31 | rank = 1 32 | ), 33 | moma_pg_settings() 34 | ) 35 | 36 | # Tests for greedy BIC 37 | test_that("`cpp_multirank_BIC_grid_search` solves a single MoMA problem", { 38 | # four grid requests 39 | 40 | zero_cnt <- 0 41 | 42 | for (av in alpha_v) { 43 | for (au in alpha_u) { 44 | for (lv in lambda_v) { 45 | for (lu in lambda_u) { 46 | public_arglist_w_penalty <- c( 47 | public_arglist_wo_penalty, 48 | list( 49 | alpha_u = au, 50 | alpha_v = av, 51 | lambda_u = lu, 52 | lambda_v = lv 53 | ) 54 | ) 55 | 56 | result <- do.call( 57 | cpp_multirank_BIC_grid_search, 58 | public_arglist_w_penalty 59 | ) 60 | 61 | result_directcall <- do.call( 62 | cpp_moma_multi_rank, 63 | public_arglist_w_penalty 64 | ) 65 | 66 | if (sum(result_directcall$u) == 0) { 67 | zero_cnt <- zero_cnt + 1 68 | } 69 | 70 | expect_equal(result_directcall$u, get_5Dlist_elem(result, 1, 1, 1, 1)[[1]]$u$vector) 71 | expect_equal(result_directcall$v, get_5Dlist_elem(result, 1, 1, 1, 1)[[1]]$v$vector) 72 | } 73 | } 74 | } 75 | } 76 | 77 | 78 | # Make sure penalty levels spread evenly from 79 | # those that zeros everything to those that are 80 | # all zeros 81 | expect_lte(zero_cnt / (n_lambda_u * n_lambda_v * n_alpha_u * n_alpha_v), 0.1) 82 | }) 83 | 84 | test_that("`cpp_multirank_BIC_grid_search`: a naive case", { 85 | arglist_x_w_penalty <- modifyList( 86 | public_arglist_wo_penalty, 87 | list( 88 | X = matrix(1), 89 | Omega_u = matrix(0), 90 | Omega_v = matrix(0), 91 | alpha_u = 0, 92 | alpha_v = 0, 93 | lambda_u = 0, 94 | lambda_v = 0 95 | ) 96 | ) 97 | 98 | result <- do.call( 99 | cpp_multirank_BIC_grid_search, 100 | arglist_x_w_penalty 101 | )[[1]] 102 | 103 | expect_equal(result$u$vector, as.matrix(1)) 104 | expect_equal(result$v$vector, as.matrix(1)) 105 | expect_equal(result$d, 1) 106 | }) 107 | -------------------------------------------------------------------------------- /tests/testthat/test_MGB_multirank.R: -------------------------------------------------------------------------------- 1 | context("`cpp_multirank_BIC_grid_search` as multirank") 2 | 3 | set.seed(123) 4 | X <- matrix(runif(12), 3, 4) * 10 5 | 6 | # They are mutually prime. This is useful for testing 7 | # the size of the 5D list 8 | n_alpha_u <- 2 9 | n_alpha_v <- 3 10 | n_lambda_u <- 5 11 | n_lambda_v <- 7 12 | 13 | # Penalties should not be too high. Otherwise 14 | # u and v becomes vectors of zeros, and defaltion 15 | # is thus trivial. 16 | alpha_u <- seq(0, 1, length.out = n_alpha_u) 17 | alpha_v <- seq(0, 1, length.out = n_alpha_v) 18 | lambda_u <- seq(0, 1, length.out = n_lambda_u) 19 | lambda_v <- seq(0, 1, length.out = n_lambda_v) 20 | 21 | # public_arglist_wo_rank_and_selection does not specify two things: rank 22 | # and selection strategy for each parameter. They 23 | # are specified in each test case. 24 | public_arglist_wo_rank_and_selection <- c( 25 | list( 26 | X = X, 27 | alpha_u = alpha_u, alpha_v = alpha_v, 28 | Omega_u = second_diff_mat(3), Omega_v = second_diff_mat(4), 29 | lambda_u = lambda_u, lambda_v = lambda_v, 30 | prox_arg_list_u = add_default_prox_args(lasso()), prox_arg_list_v = add_default_prox_args(lasso()) 31 | ), 32 | moma_pg_settings() 33 | ) 34 | 35 | # Tests for multirank 36 | test_that("cpp_multirank_BIC_grid_search receives rank <= 0", { 37 | # case 1: rank=0 38 | arglist_w_rank <- c( 39 | public_arglist_wo_rank_and_selection, 40 | list( 41 | rank = 0 42 | ) 43 | ) 44 | 45 | expect_error( 46 | do.call(cpp_multirank_BIC_grid_search, arglist_w_rank), 47 | "rank in MoMA::grid_BIC_mix should >= 1" 48 | ) 49 | 50 | # case 2: rank=-1 51 | arglist_w_rank$rank <- -1 52 | expect_error( 53 | do.call(cpp_multirank_BIC_grid_search, arglist_w_rank), 54 | "rank in MoMA::grid_BIC_mix should >= 1" 55 | ) 56 | }) 57 | 58 | test_that("cpp_multirank_BIC_grid_search returns multi-rank solution", { 59 | # four grid requests 60 | rank <- 3 61 | 62 | public_arglist_w_rank <- 63 | modifyList( 64 | public_arglist_wo_rank_and_selection, 65 | list(rank = rank) 66 | ) 67 | 68 | result <- do.call( 69 | cpp_multirank_BIC_grid_search, 70 | public_arglist_w_rank 71 | ) 72 | 73 | for (i in 1:n_alpha_u) { 74 | for (j in 1:n_alpha_v) { 75 | for (n in 1:n_lambda_u) { 76 | for (m in 1:n_lambda_v) { 77 | arglist_unary_penalty_wo_selection <- 78 | modifyList( 79 | public_arglist_wo_rank_and_selection, 80 | list( 81 | alpha_u = alpha_u[i], 82 | alpha_v = alpha_v[j], 83 | lambda_u = lambda_u[n], 84 | lambda_v = lambda_v[m], 85 | rank = rank 86 | ) 87 | ) 88 | 89 | # call cpp_moma_multi_rank 90 | result_directcall <- do.call( 91 | cpp_moma_multi_rank, 92 | arglist_unary_penalty_wo_selection 93 | ) 94 | 95 | for (rank_i in 1:rank) { 96 | res <- get_5Dlist_elem(result, alpha_u_i = i, lambda_u_i = n, alpha_v_i = j, lambda_v_i = m, rank_i)[[1]] 97 | expect_equal(abs(matrix(result_directcall$u[, rank_i])), abs(res$u$vector)) 98 | } 99 | } 100 | } 101 | } 102 | } 103 | }) 104 | -------------------------------------------------------------------------------- /tests/testthat/test_dof.R: -------------------------------------------------------------------------------- 1 | context("Test degree of freedom") 2 | 3 | 4 | test_that("DoF of fused lasso", { 5 | # constant 6 | x <- c(1, 1, 1, 1) 7 | expect_equal(1, test_df_orderedfusion(x)) 8 | 9 | # fused group at the start 10 | x <- c(1, 1, 1, 2, 1) 11 | expect_equal(3, test_df_orderedfusion(x)) 12 | 13 | # fused group at the end 14 | x <- c(1, 2, 1, 1, 1, 1) 15 | expect_equal(3, test_df_orderedfusion(x)) 16 | 17 | # multiple fused groups 18 | x <- c(1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 6) 19 | expect_equal(6, test_df_orderedfusion(x)) 20 | 21 | # no fusion happens 22 | x <- seq(20) 23 | expect_equal(20, test_df_orderedfusion(x)) 24 | }) 25 | 26 | test_that("DoF of sparse fused lasso", { 27 | # constant 28 | x <- c(1, 1, 1, 1) 29 | expect_equal(1, test_df_spfusedlasso(x)) 30 | 31 | # fused group at the beginning 32 | x <- c(1, 1, 1, 2, 1) 33 | expect_equal(3, test_df_spfusedlasso(x)) 34 | 35 | # fused group at the end 36 | x <- c(1, 2, 1, 1, 1, 1) 37 | expect_equal(3, test_df_spfusedlasso(x)) 38 | 39 | # multiple fused groups 40 | x <- c(1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 6) 41 | expect_equal(6, test_df_spfusedlasso(x)) 42 | 43 | # no fusion happens 44 | x <- seq(20) 45 | expect_equal(20, test_df_spfusedlasso(x)) 46 | 47 | # zeros at the beginning 48 | x <- c(0, 0, 1, 2, 1, 1) 49 | expect_equal(3, test_df_spfusedlasso(x)) 50 | 51 | # zeros in the middle 52 | x <- c(1, 0, 0, 2, 1, 1) 53 | expect_equal(3, test_df_spfusedlasso(x)) 54 | 55 | # multiple groups of zeros in the middle 56 | x <- c(1, 0, 0, 2, 0, 0, 0, 3, 3, 0, 1, 1) 57 | expect_equal(4, test_df_spfusedlasso(x)) 58 | 59 | # zeros in the end 60 | x <- c(1, 0, 0, 2, 1, 1, 0) 61 | expect_equal(3, test_df_spfusedlasso(x)) 62 | }) 63 | 64 | 65 | test_that("DoF of linear trend filtering", { 66 | x <- c(1, 1, 1, 1) 67 | expect_equal(2, test_df_l1gf(x, 1)) 68 | 69 | # given any line (knot = 0) it should return DoF = 2 70 | x <- seq(0, 20, 0.3) 71 | for (rep in 1:10) { 72 | alpha <- runif(1) 73 | beta <- runif(1) 74 | xx <- alpha * x + beta 75 | expect_equal(2, test_df_l1gf(x, 1)) 76 | } 77 | 78 | # one knot 79 | x <- seq(0, 20, 0.3) 80 | x <- 2 * abs(x - x[37]) - 2 81 | expect_equal(3, test_df_l1gf(x, 1)) 82 | 83 | # three knots 84 | x <- seq(0, 20, 0.3) 85 | x <- 2 * abs(x - x[37]) - 2 86 | x <- 2 * abs(x - x[10]) - 2 87 | ## plot(x) 88 | expect_equal(5, test_df_l1gf(x, 1)) 89 | 90 | # Find out knots using `diff`` 91 | x <- runif(40) 92 | change_in_sec_diff <- sum(abs(diff(diff(x))) > 1e-10) 93 | expect_equal(change_in_sec_diff + 1 + 1, test_df_l1gf(x, 2)) 94 | }) 95 | 96 | 97 | test_that("DoF of quadratic trend filtering", { 98 | 99 | # constant 100 | x <- c(1, 1, 1, 1, 1) 101 | expect_equal(3, test_df_l1gf(x, 2)) 102 | 103 | # given any line it should return DoF = 3 104 | x <- seq(0, 20, 0.3) 105 | for (rep in 1:10) { 106 | alpha <- runif(1) 107 | beta <- runif(1) 108 | xx <- alpha * x + beta 109 | expect_equal(3, test_df_l1gf(x, 2)) 110 | } 111 | 112 | # given any quadratic curve it should return DoF = 3 113 | x <- seq(0, 20, 0.3) 114 | for (rep in 1:10) { 115 | alpha <- runif(1) 116 | beta <- runif(1) 117 | c <- runif(1) 118 | xx <- alpha * x^2 + beta * x + c 119 | expect_equal(3, test_df_l1gf(x, 2)) 120 | } 121 | 122 | # Find out knots using `diff`` 123 | change_in_sec_diff <- sum(abs(diff(diff(diff(x)))) > 1e-10) 124 | 125 | expect_equal(change_in_sec_diff + 2 + 1, test_df_l1gf(x, 2)) 126 | }) 127 | -------------------------------------------------------------------------------- /src/moma_prox_flsadp.h: -------------------------------------------------------------------------------- 1 | #ifndef MOMA_PROX_FLSADP 2 | #define MOMA_PROX_FLSADP 1 3 | 4 | #include "moma_base.h" 5 | 6 | // Copyright (c) 2012, Nicholas A. Johnson 7 | // All rights reserved. 8 | 9 | // Redistribution and use in source and binary forms, with or without 10 | // modification, are permitted provided that the following conditions are met: 11 | // 1. Redistributions of source code must retain the above copyright 12 | // notice, this list of conditions and the following disclaimer. 13 | // 2. Redistributions in binary form must reproduce the above copyright 14 | // notice, this list of conditions and the following disclaimer in the 15 | // documentation and/or other materials provided with the distribution. 16 | // 3. All advertising materials mentioning features or use of this software 17 | // must display the following acknowledgement: 18 | // This product includes software developed by Nicholas A. Johnson. 19 | // 4. Neither the name of Nicholas A. Johnson nor the 20 | // names of its contributors may be used to endorse or promote products 21 | // derived from this software without specific prior written permission. 22 | 23 | // THIS SOFTWARE IS PROVIDED BY Nicholas A. Johnson ''AS IS'' AND ANY 24 | // EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 25 | // WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 | // DISCLAIMED. IN NO EVENT SHALL Nicholas A. Johnson BE LIABLE FOR ANY 27 | // DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 28 | // (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 29 | // LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 30 | // ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | // (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 32 | // SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | 34 | // This file is an adapted version of the package cited above. 35 | // Better modularity and readability. Commments are added 36 | // in order to explain the algorithm. Avoid explicit 37 | // memory management. 38 | 39 | // Reference: 40 | // Johnson, Nicholas A. 41 | // "A dynamic programming algorithm for the fused lasso and l 0-segmentation." 42 | // Journal of Computational and Graphical Statistics 22.2 (2013): 246-260. 43 | 44 | struct MsgElt 45 | { 46 | // the location of the knot 47 | double x_; 48 | // the sign variable that tells us 49 | // whether this was a left or right end-point of the 50 | // segment 51 | bool sgn_; 52 | // a delta which can be used to reconstruct the function 53 | // if we move from the first knot to the last or from 54 | // the last to the first 55 | double lin_; 56 | double quad_; 57 | }; 58 | 59 | class Msg 60 | { 61 | public: 62 | std::vector buf_; 63 | arma::vec back_pointers; 64 | int start_idx_; 65 | int len_; 66 | 67 | MsgElt init_knot_; 68 | MsgElt end_knot_; 69 | 70 | void InitMsg(int n, int init_sz, double lin, double quad, double lambda2); 71 | void UpdMsg(double lambda2, double lin, double quad, int bp_idx); 72 | void UpdMsgOpt(double lambda2, double lin, double quad, int bp_idx); 73 | double Argmax(double *max_val); 74 | 75 | // This data structure supports prepend and append; 76 | // To implement this, first allocate a long array, 77 | // then start filling data in the middle and extend to both ends. Shift 78 | // the space filled with data towards the center of the array periodically 79 | void ShiftMsg(int check_freq); 80 | arma::vec BackTrace(int seq_len, double last_msg_max); 81 | }; 82 | 83 | arma::vec myflsadp(const arma::vec &x, 84 | double lambda2, 85 | int init_buf_sz = MOMA_FUSEDLASSODP_BUFFERSIZE); 86 | 87 | #endif // MOMA_PROX_FLSADP 88 | -------------------------------------------------------------------------------- /R/logging.R: -------------------------------------------------------------------------------- 1 | # Logging infrastructure for MoMA 2 | 3 | ## This must be kept consistent with src/moma_logging.h::MoMAoggerLevel 4 | LEVELS <- c( 5 | ERROR = 40, 6 | WARNING = 30, 7 | MESSAGE = 20, 8 | INFO = 10, 9 | DEBUG = 00 10 | ) 11 | 12 | 13 | #' MoMA Package Logging Functionality 14 | #' 15 | #' Control the global logging level for the \code{moma} package. 16 | #' 17 | #' @importFrom stats setNames 18 | #' @export 19 | #' @param level The desired new log level. Available levels are \itemize{ 20 | #' \item \code{ERROR} - corresponding to \code{base::stop}; 21 | #' \item \code{WARNING} - corresponding to \code{base::warning}; 22 | #' \item \code{MESSAGE} - corresponding to \code{base::message}; 23 | #' \item \code{INFO}; and 24 | #' \item \code{DEBUG.} 25 | #' } If omitted, the log level is not changed (and the current level is still 26 | #' returned invisibly.) See below for details about the different levels. 27 | #' @return The previous log level (invisibly). 28 | #' @rdname moma_logging 29 | #' @aliases moma_logging moma_logger_level 30 | #' @details The \code{moma} package has a multi-level logging system, with a single 31 | #' global log level; (which applies to both \code{R} and \code{C++} level 32 | #' functionality.) the levels are, in decreasing order, \code{ERROR}, 33 | #' \code{WARNING}, \code{MESSAGE} (default), \code{INFO}, \code{DEBUG}. 34 | #' 35 | #' To change the amount of output from the \code{moma} package, the 36 | #' \code{moma_logger_level} function can be used to adjust the global 37 | #' log level. The \code{INFO} and \code{DEBUG} levels can be quite verbose 38 | #' and may significantly slow down the package. 39 | moma_logger_level <- function(level = c( 40 | "ERROR", 41 | "WARNING", 42 | "MESSAGE", 43 | "INFO", 44 | "DEBUG" 45 | )) { 46 | LEVELS_REV <- setNames(names(LEVELS), LEVELS) 47 | 48 | old_level <- LEVELS_REV[as.character(moma_get_logger_level_cpp())] 49 | names(old_level) <- NULL 50 | 51 | if (!missing(level)) { 52 | level <- match.arg(level) 53 | moma_set_logger_level_cpp(LEVELS[level]) 54 | return(invisible(old_level)) 55 | } 56 | 57 | old_level 58 | } 59 | 60 | moma_error <- function(..., call = TRUE) { 61 | msg <- paste(list(...), collapse = "") 62 | 63 | ## Try to add R level calling info 64 | if (identical(call, TRUE)) { 65 | tryCatch({ 66 | msg <- paste0(msg, " (Called from ", as.character(as.list(sys.call(-1))[[1]]), ")") 67 | }, error = function(e) {}) 68 | } else if (is.character(call)) { 69 | msg <- paste0(msg, " (Called from ", call, ")") 70 | } 71 | 72 | moma_log_cpp(LEVELS["ERROR"], msg) 73 | } 74 | 75 | moma_warning <- function(..., call = TRUE) { 76 | msg <- paste(list(...), collapse = "") 77 | 78 | ## Try to add R level calling info 79 | if (identical(call, TRUE)) { 80 | tryCatch({ 81 | msg <- paste0(msg, " (Called from ", as.character(as.list(sys.call(-1))[[1]]), ")") 82 | }, error = function(e) {}) 83 | } else if (is.character(call)) { 84 | msg <- paste0(msg, " (Called from ", call, ")") 85 | } 86 | 87 | moma_log_cpp(LEVELS["WARNING"], msg) 88 | } 89 | 90 | moma_message <- function(...) { 91 | msg <- paste(list(...), collapse = "") 92 | moma_log_cpp(LEVELS["MESSAGE"], msg) 93 | } 94 | 95 | moma_info <- function(...) { 96 | msg <- paste(list(...), collapse = "") 97 | moma_log_cpp(LEVELS["INFO"], msg) 98 | } 99 | 100 | moma_debug <- function(...) { 101 | msg <- paste(list(...), collapse = "") 102 | moma_log_cpp(LEVELS["DEBUG"], msg) 103 | } 104 | -------------------------------------------------------------------------------- /docs/pkgdown.js: -------------------------------------------------------------------------------- 1 | /* http://gregfranko.com/blog/jquery-best-practices/ */ 2 | (function($) { 3 | $(function() { 4 | 5 | $("#sidebar") 6 | .stick_in_parent({offset_top: 40}) 7 | .on('sticky_kit:bottom', function(e) { 8 | $(this).parent().css('position', 'static'); 9 | }) 10 | .on('sticky_kit:unbottom', function(e) { 11 | $(this).parent().css('position', 'relative'); 12 | }); 13 | 14 | $('body').scrollspy({ 15 | target: '#sidebar', 16 | offset: 60 17 | }); 18 | 19 | $('[data-toggle="tooltip"]').tooltip(); 20 | 21 | var cur_path = paths(location.pathname); 22 | var links = $("#navbar ul li a"); 23 | var max_length = -1; 24 | var pos = -1; 25 | for (var i = 0; i < links.length; i++) { 26 | if (links[i].getAttribute("href") === "#") 27 | continue; 28 | // Ignore external links 29 | if (links[i].host !== location.host) 30 | continue; 31 | 32 | var nav_path = paths(links[i].pathname); 33 | 34 | var length = prefix_length(nav_path, cur_path); 35 | if (length > max_length) { 36 | max_length = length; 37 | pos = i; 38 | } 39 | } 40 | 41 | // Add class to parent
  • , and enclosing
  • if in dropdown 42 | if (pos >= 0) { 43 | var menu_anchor = $(links[pos]); 44 | menu_anchor.parent().addClass("active"); 45 | menu_anchor.closest("li.dropdown").addClass("active"); 46 | } 47 | }); 48 | 49 | function paths(pathname) { 50 | var pieces = pathname.split("/"); 51 | pieces.shift(); // always starts with / 52 | 53 | var end = pieces[pieces.length - 1]; 54 | if (end === "index.html" || end === "") 55 | pieces.pop(); 56 | return(pieces); 57 | } 58 | 59 | // Returns -1 if not found 60 | function prefix_length(needle, haystack) { 61 | if (needle.length > haystack.length) 62 | return(-1); 63 | 64 | // Special case for length-0 haystack, since for loop won't run 65 | if (haystack.length === 0) { 66 | return(needle.length === 0 ? 0 : -1); 67 | } 68 | 69 | for (var i = 0; i < haystack.length; i++) { 70 | if (needle[i] != haystack[i]) 71 | return(i); 72 | } 73 | 74 | return(haystack.length); 75 | } 76 | 77 | /* Clipboard --------------------------*/ 78 | 79 | function changeTooltipMessage(element, msg) { 80 | var tooltipOriginalTitle=element.getAttribute('data-original-title'); 81 | element.setAttribute('data-original-title', msg); 82 | $(element).tooltip('show'); 83 | element.setAttribute('data-original-title', tooltipOriginalTitle); 84 | } 85 | 86 | if(ClipboardJS.isSupported()) { 87 | $(document).ready(function() { 88 | var copyButton = ""; 89 | 90 | $(".examples, div.sourceCode").addClass("hasCopyButton"); 91 | 92 | // Insert copy buttons: 93 | $(copyButton).prependTo(".hasCopyButton"); 94 | 95 | // Initialize tooltips: 96 | $('.btn-copy-ex').tooltip({container: 'body'}); 97 | 98 | // Initialize clipboard: 99 | var clipboardBtnCopies = new ClipboardJS('[data-clipboard-copy]', { 100 | text: function(trigger) { 101 | return trigger.parentNode.textContent; 102 | } 103 | }); 104 | 105 | clipboardBtnCopies.on('success', function(e) { 106 | changeTooltipMessage(e.trigger, 'Copied!'); 107 | e.clearSelection(); 108 | }); 109 | 110 | clipboardBtnCopies.on('error', function() { 111 | changeTooltipMessage(e.trigger,'Press Ctrl+C or Command+C to copy'); 112 | }); 113 | }); 114 | } 115 | })(window.jQuery || window.$) 116 | -------------------------------------------------------------------------------- /man/moma_sfcca.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_sfcca.R 3 | \name{moma_sfcca} 4 | \alias{moma_sfcca} 5 | \alias{moma_scca} 6 | \alias{moma_twscca} 7 | \alias{moma_fcca} 8 | \alias{moma_twfcca} 9 | \title{Sparse and functional CCA} 10 | \usage{ 11 | moma_sfcca(X, ..., Y, center = TRUE, scale = FALSE, 12 | x_sparse = moma_empty(), y_sparse = moma_empty(), 13 | x_smooth = moma_smoothness(), y_smooth = moma_smoothness(), 14 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 15 | 16 | moma_scca(X, ..., Y, center = TRUE, scale = FALSE, 17 | x_sparse = moma_empty(), y_sparse = moma_empty(), 18 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 19 | 20 | moma_twscca(X, ..., Y, center = TRUE, scale = FALSE, 21 | x_sparse = moma_empty(), y_sparse = moma_empty(), 22 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 23 | 24 | moma_fcca(X, ..., Y, center = TRUE, scale = FALSE, 25 | x_smooth = moma_smoothness(), y_smooth = moma_smoothness(), 26 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 27 | 28 | moma_twfcca(X, ..., Y, center = TRUE, scale = FALSE, 29 | x_smooth = moma_smoothness(), y_smooth = moma_smoothness(), 30 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 31 | } 32 | \arguments{ 33 | \item{X, Y}{A data matrix, each row representing a sample, and each column a feature.} 34 | 35 | \item{...}{Force users to specify arguments by names.} 36 | 37 | \item{center}{A logical value indicating whether the variables should be shifted to be zero centered. 38 | Defaults to \code{TRUE}.} 39 | 40 | \item{scale}{A logical value indicating whether the variables should be scaled to have unit variance. 41 | Defaults to \code{FALSE}.} 42 | 43 | \item{x_sparse, y_sparse}{An object of class inheriting from "\code{moma_sparsity_type}". Most conveniently 44 | specified by functions described in \code{\link{moma_sparsity_options}}. It specifies the type of sparsity-inducing 45 | penalty function used in the model. Note that for \code{moma_scca}, these two parameters must not be 46 | specified at the same time. For \code{moma_fcca} and \code{moma_twfcca}, they must not be specified.} 47 | 48 | \item{x_smooth, y_smooth}{An object of class inheriting from "\code{moma_smoothness_type}". Most conveniently 49 | specified by functions described in \code{moma_smoothness}. It specifies the type of smoothness 50 | terms used in the model. Note that for \code{moma_fcca}, these two parameters must not be 51 | specified at the same time. For \code{moma_scca} and \code{moma_twscca}, they must not be specified.} 52 | 53 | \item{pg_settings}{An object of class inheriting from "\code{moma_pg_settings}". Most conviently 54 | specified by functions described in \code{\link{moma_pg_settings}}. It specifies the type of algorithm 55 | used to solve the problem, acceptable level of precision, and the maximum number of iterations allowed.} 56 | 57 | \item{max_bic_iter}{A positive integer. Defaults to 5. The maximum number of iterations allowed 58 | in nested greedy BIC selection scheme.} 59 | 60 | \item{rank}{A positive integer. Defaults to 1. The maximal rank, i.e., maximal number of principal components to be used.} 61 | } 62 | \description{ 63 | \code{moma_sfcca} creates an \code{SFCCA} R6 object and returns it. Type \code{?CCA_deflation} for 64 | description of problem formulation and deflation scheme. 65 | 66 | \code{moma_scca} is a function for performing one-way sparse CCA. 67 | 68 | \code{moma_twscca} is a function for performing two-way sparse CCA. 69 | 70 | \code{moma_fcca} is a function for performing one-way functional CCA. 71 | 72 | \code{moma_twfcca} is a function for performing two-way functional CCA. 73 | } 74 | \section{Functions}{ 75 | \itemize{ 76 | \item \code{moma_scca}: a function for performing one-way sparse CCA. 77 | 78 | \item \code{moma_twscca}: a function for performing two-way sparse CCA 79 | 80 | \item \code{moma_fcca}: a function for performing one-way functional CCA 81 | 82 | \item \code{moma_twfcca}: a function for performing two-way functional CCA 83 | }} 84 | 85 | -------------------------------------------------------------------------------- /tests/testthat/test_logging.R: -------------------------------------------------------------------------------- 1 | library(stringr) 2 | context("Logging Tests") 3 | 4 | test_that("Logging controls work", { 5 | expect_error(moma_logger_level("BAD LEVEL")) 6 | 7 | moma_logger_level("INFO") 8 | expect_equal("INFO", moma_logger_level()) 9 | 10 | moma_logger_level("MESSAGE") 11 | }) 12 | 13 | test_that("INFO and DEBUG message print as expected", { 14 | moma_logger_level("MESSAGE") 15 | 16 | expect_silent(MoMA:::moma_info("A message")) 17 | expect_silent(MoMA:::moma_debug("A message")) 18 | 19 | moma_logger_level("DEBUG") 20 | 21 | expect_output(MoMA:::moma_info("A message"), "[INFO]") 22 | expect_output(MoMA:::moma_info("A message"), "A message") 23 | 24 | expect_output(MoMA:::moma_debug("The message"), "[DEBUG]") 25 | expect_output(MoMA:::moma_debug("The message"), "The message") 26 | 27 | moma_logger_level("MESSAGE") 28 | }) 29 | 30 | test_that("Supressing messages works", { 31 | # At INFO level, everything is shown in R 32 | moma_logger_level("INFO") 33 | 34 | expect_error(MoMA:::moma_error("ERROR")) 35 | expect_warning(MoMA:::moma_warning("WARNING")) 36 | expect_message(MoMA:::moma_message("MESSAGE")) 37 | 38 | # At MESSAGE level, everything is shown in R 39 | moma_logger_level("MESSAGE") 40 | 41 | expect_error(MoMA:::moma_error("ERROR")) 42 | expect_warning(MoMA:::moma_warning("WARNING")) 43 | expect_message(MoMA:::moma_message("MESSAGE")) 44 | 45 | # At WARNING level, we don't get a message 46 | moma_logger_level("WARNING") 47 | 48 | expect_error(MoMA:::moma_error("ERROR")) 49 | expect_warning(MoMA:::moma_warning("WARNING")) 50 | expect_no_message(MoMA:::moma_message("MESSAGE")) 51 | 52 | # At ERROR level, we don't get a message or warning 53 | moma_logger_level("ERROR") 54 | 55 | expect_error(MoMA:::moma_error("ERROR")) 56 | expect_no_warning(MoMA:::moma_warning("WARNING")) 57 | expect_no_message(MoMA:::moma_message("MESSAGE")) 58 | 59 | moma_logger_level("MESSAGE") 60 | }) 61 | 62 | test_that("No extra newlines", { 63 | moma_logger_level("DEBUG") 64 | 65 | e <- tryCatch(MoMA:::moma_error("MY ERROR"), error = identity) 66 | expect_equal(str_count(e$message, "\n"), 1) 67 | 68 | e <- tryCatch(MoMA:::moma_warning("MY WARNING"), warning = identity) 69 | expect_equal(str_count(e$message, "\n"), 1) 70 | 71 | e <- tryCatch(MoMA:::moma_message("MY MESSAGE"), message = identity) 72 | expect_equal(str_count(e$message, "\n"), 1) 73 | 74 | e <- tryCatch(MoMA:::moma_error("MY ERROR\nON TWO LINES"), error = identity) 75 | expect_equal(str_count(e$message, "\n"), 2) 76 | 77 | moma_logger_level("MESSAGE") 78 | }) 79 | 80 | test_that("Function capture works at R level", { 81 | moma_logger_level("MESSAGE") 82 | 83 | f <- function(x) { 84 | MoMA:::moma_error("ERROR MESSAGE") 85 | } 86 | 87 | e <- tryCatch(f(), error = identity) 88 | expect_str_contains(e$message, "ERROR MESSAGE") 89 | expect_str_contains(e$message, "(Called from f)") 90 | expect_true(is.null(e$call)) 91 | expect_true(is.null(e$cppstack)) 92 | 93 | f <- function(x) { 94 | MoMA:::moma_error("ERROR MESSAGE", call = FALSE) 95 | } 96 | e <- tryCatch(f(), error = identity) 97 | 98 | expect_false(grepl("\\(Called from f\\)", e$message)) 99 | 100 | f <- function(x) { 101 | MoMA:::moma_error("ERROR MESSAGE", call = "my func") 102 | } 103 | e <- tryCatch(f(), error = identity) 104 | 105 | expect_true(grepl("\\(Called from my func\\)", e$message)) 106 | 107 | f <- function(x) { 108 | MoMA:::moma_warning("WARNING MESSAGE", call = FALSE) 109 | } 110 | e <- tryCatch(f(), warning = identity) 111 | 112 | expect_false(grepl("\\(Called from f\\)", e$message)) 113 | 114 | f <- function(x) { 115 | MoMA:::moma_warning("WARNING MESSAGE", call = "my func") 116 | } 117 | e <- tryCatch(f(), warning = identity) 118 | 119 | expect_true(grepl("\\(Called from my func\\)", e$message)) 120 | }) 121 | -------------------------------------------------------------------------------- /tests/testthat/test_prox_fused_lasso.R: -------------------------------------------------------------------------------- 1 | context("Ordered Fused lasso tests") 2 | 3 | test_that("A numeric example: Ordered fused lasso should return correct values under different lambdas", { 4 | set.seed(34) 5 | x <- 10 * runif(10) 6 | # result generated by flsa 7 | # These lambdas are the knots where merges happen. 8 | 9 | # library(flsa) 10 | # flsa::flsaTopDown(x) 11 | goal <- matrix(c( 12 | 4.447685, 5.447685, 6.447685, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593, 13 | 9.985404, 8.417172, 7.417172, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593, 14 | 8.848940, 8.417172, 7.417172, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593, 15 | 2.384260, 3.328699, 4.328699, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, 16 | 2.273138, 3.328699, 4.328699, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, 17 | 8.477694, 6.477694, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, 18 | 2.825617, 4.825617, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, 19 | 7.176086, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, 20 | 3.960512, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, 21 | 5.746595, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 22 | ), 23 | nrow = 10, 24 | byrow = T 25 | ) 26 | lambdas <- seq(0, 10, 1) 27 | for (l in 1:10) { 28 | expect_lte(norm(test_prox_fusedlassopath(x, lambdas[l]) - matrix(goal[, l], nrow = 10)), 1e-5) 29 | } 30 | }) 31 | 32 | test_that("Equals to mean when lambda is large enough", { 33 | l <- 1e+100 34 | set.seed(34) 35 | for (i in 1000) { 36 | x <- 10 * runif(10) 37 | proxed.x <- test_prox_fusedlassopath(x, l) 38 | for (i in 1:9) { 39 | expect_equal(proxed.x[i], proxed.x[i + 1]) 40 | } 41 | expect_equal(mean(x), proxed.x[1]) 42 | } 43 | }) 44 | 45 | test_that("Same results as the `flsa` package", { 46 | set.seed(43) 47 | if (requireNamespace("flsa")) { 48 | library(flsa) 49 | 50 | # Problem size ranging from 2 to 200 51 | for (p in seq(2, 200, 10)) { 52 | # Repeat 10 times 53 | for (i in 1:10) { 54 | x <- 10 * runif(p) 55 | # Penalty levels 56 | for (lambda in seq(0, 5, 0.5)) { 57 | expect_equal( 58 | test_prox_fusedlassopath(x, lambda), 59 | t(flsa::flsaGetSolution(flsa::flsa(x), lambda2 = lambda)) 60 | ) 61 | } 62 | } 63 | } 64 | } 65 | }) 66 | 67 | test_that("DP approach should give the same results as the `flsa` package", { 68 | set.seed(43) 69 | if (requireNamespace("flsa")) { 70 | library(flsa) 71 | 72 | # Problem size ranging from 2 to 200 73 | for (p in seq(2, 200, 10)) { 74 | # Repeat 10 times 75 | for (i in 1:10) { 76 | x <- 10 * runif(p) 77 | # Penalty levels 78 | for (lambda in seq(0, 5, 0.5)) { 79 | expect_equal( 80 | test_prox_fusedlassodp(x, lambda), 81 | t(flsa::flsaGetSolution(flsa::flsa(x), lambda2 = lambda)) 82 | ) 83 | if (lambda == 5) { 84 | # make sure we test the entire path 85 | expect(sum(abs(test_prox_fusedlassodp(x, lambda))), 0) 86 | } 87 | } 88 | } 89 | } 90 | } 91 | }) 92 | 93 | test_that("Test DP approach buffer size", { 94 | set.seed(43) 95 | if (requireNamespace("flsa")) { 96 | library(flsa) 97 | lambda <- 1 98 | # Problem size 99 | for (p in c(10000000)) { 100 | # Repeat 10 times 101 | for (i in 1:10) { 102 | x <- 10 * runif(p) 103 | # Path algorithm takes 10 seconds to solve each. 104 | # DP takes 0.5 seconds. 105 | expect_equal( 106 | test_prox_fusedlassodp(x, lambda), 107 | test_prox_fusedlassopath(x, lambda) 108 | ) 109 | } 110 | } 111 | } 112 | }) 113 | -------------------------------------------------------------------------------- /R/moma_expose.R: -------------------------------------------------------------------------------- 1 | moma_svd <- function( 2 | X, 3 | u_sparsity = empty(), v_sparsity = empty(), lambda_u = 0, lambda_v = 0, # lambda_u/_v is a vector or scalar 4 | Omega_u = NULL, Omega_v = NULL, alpha_u = 0, alpha_v = 0, # so is alpha_u/_v 5 | pg_settings = moma_pg_settings(), 6 | k = 1, # number of pairs of singular vecters 7 | select = c("gridsearch", "nestedBIC")) { 8 | if (!inherits(alpha_u, c("numeric", "integer")) || 9 | !inherits(alpha_v, c("numeric", "integer")) || 10 | !inherits(lambda_u, c("numeric", "integer")) || 11 | !inherits(lambda_v, c("numeric", "integer"))) { 12 | moma_error(paste0( 13 | "All penalty levels (", 14 | sQuote("lambda_u"), ", ", 15 | sQuote("lambda_v"), ", ", 16 | sQuote("alpha_u"), ", ", 17 | sQuote("alpha_v"), 18 | ") must be numeric." 19 | )) 20 | } 21 | 22 | select <- match.arg(select) 23 | all_para <- c(alpha_u, alpha_v, lambda_u, lambda_v) 24 | 25 | # verify all alphas and lambdas are positive numbers 26 | if (any(all_para < 0) || any(!is.finite(all_para))) { 27 | moma_error( 28 | "All penalty levels (", 29 | sQuote("lambda_u"), ", ", 30 | sQuote("lambda_v"), ", ", 31 | sQuote("alpha_u"), ", ", 32 | sQuote("alpha_v"), 33 | ") must be non-negative numeric." 34 | ) 35 | } 36 | 37 | # from scalar to vector 38 | alpha_u <- as.vector(alpha_u) 39 | alpha_v <- as.vector(alpha_v) 40 | lambda_u <- as.vector(lambda_u) 41 | lambda_v <- as.vector(lambda_v) 42 | 43 | if (!is.matrix(X)) { 44 | moma_error("X must be a matrix.") 45 | } 46 | if (any(!is.finite(X))) { 47 | moma_error("X must not have NaN, NA, or Inf.") 48 | } 49 | n <- dim(X)[1] 50 | p <- dim(X)[2] 51 | 52 | # If all of alpha_u, alpha_v, lambda_u, lambda_v are 53 | # a number, we just solve ONE MoMA problem. 54 | is_multiple_para <- length(alpha_u) > 1 || 55 | length(alpha_v) > 1 || 56 | length(lambda_u) > 1 || 57 | length(lambda_v) > 1 58 | 59 | # k must be 1 if alpha_u/v or lambda_u/v is of vector form 60 | if (is_multiple_para && k != 1) { 61 | moma_error("We don't support a range of parameters in finding a rank-k svd") 62 | } 63 | 64 | # Sparsity arguments 65 | # "_moma_sparsity_type" includes all penalty types 66 | if (!inherits(u_sparsity, "_moma_sparsity_type") || !inherits(v_sparsity, "_moma_sparsity_type")) { 67 | moma_error( 68 | "Sparse penalty should be of class ", 69 | sQuote("_moma_sparsity_type"), 70 | ". Try using, for example, `u_sparsity = lasso()`." 71 | ) 72 | } 73 | 74 | # PG loop settings 75 | if (!inherits(pg_settings, "moma_pg_settings")) { 76 | moma_error( 77 | "pg_settings penalty should be of class ", 78 | sQuote("moma_pg_settings"), 79 | ". Try using, for example, `pg_settings = moma_pg_settings(MAX_ITER=1e+4)`." 80 | ) 81 | } 82 | 83 | # Pack all argument into a list 84 | # First we check the smoothness term argument. 85 | algo_settings_list <- c( 86 | list( 87 | X = X, 88 | lambda_u = lambda_u, 89 | lambda_v = lambda_v, 90 | # smoothness 91 | alpha_u = alpha_u, 92 | alpha_v = alpha_v, 93 | rank = k 94 | ), 95 | # Penalties 96 | list( 97 | Omega_u = check_omega(Omega_u, alpha_u, n), 98 | Omega_v = check_omega(Omega_v, alpha_v, p), 99 | prox_arg_list_u = add_default_prox_args(u_sparsity), 100 | prox_arg_list_v = add_default_prox_args(v_sparsity) 101 | ), 102 | pg_settings 103 | ) 104 | 105 | if (is_multiple_para) { 106 | if (select == "gridsearch") { 107 | a <- do.call("cpp_moma_grid_search", algo_settings_list) 108 | class(a) <- "moma_svd_grid" 109 | return(a) 110 | } 111 | else if (select == "nestedBIC") { 112 | a <- do.call("cpp_moma_criterion_search", algo_settings_list) 113 | class(a) <- "moma_svd_nestedBIC" 114 | return(a) 115 | } 116 | else { 117 | moma_error("Wrong parameter selection methods!") 118 | } 119 | } 120 | else { 121 | return(do.call("cpp_moma_multi_rank", algo_settings_list)) 122 | } 123 | } 124 | -------------------------------------------------------------------------------- /tests/testthat/test_5Dlist_extractor.R: -------------------------------------------------------------------------------- 1 | context("5D List") 2 | 3 | set.seed(123) 4 | X <- matrix(runif(12), 3, 4) * 10 5 | 6 | # They are mutually prime. This is useful for testing 7 | # the size of the 5D list 8 | n_alpha_u <- 7 9 | n_alpha_v <- 5 10 | n_lambda_u <- 3 11 | n_lambda_v <- 2 12 | rank <- 3 13 | 14 | # Penalties should not be too high. Otherwise 15 | # u and v becomes vectors of zeros, and defaltion 16 | # is thus trivial. 17 | alpha_u <- seq(0, 0.1, length.out = n_alpha_u) 18 | alpha_v <- seq(0, 0.2, length.out = n_alpha_v) 19 | lambda_u <- seq(0, 0.3, length.out = n_lambda_u) 20 | lambda_v <- seq(0, 0.4, length.out = n_lambda_v) 21 | 22 | 23 | public_arg_list <- c( 24 | list( 25 | X = X, 26 | alpha_u = alpha_u, alpha_v = alpha_v, 27 | Omega_u = second_diff_mat(3), Omega_v = second_diff_mat(4), 28 | lambda_u = lambda_u, lambda_v = lambda_v, 29 | prox_arg_list_u = add_default_prox_args(lasso()), prox_arg_list_v = add_default_prox_args(empty()), 30 | rank = rank 31 | ), 32 | moma_pg_settings() 33 | ) 34 | 35 | # Generate a 5-D list by calling `cpp_multirank_BIC_grid_search` 36 | five_D_list_instance <- do.call( 37 | cpp_multirank_BIC_grid_search, 38 | c( 39 | public_arg_list, 40 | list( 41 | select_scheme_alpha_u = 0, # grid 42 | select_scheme_alpha_v = 0, # grid 43 | select_scheme_lambda_u = 0, # grid 44 | select_scheme_lambda_v = 0 # grid 45 | ) 46 | ) 47 | ) 48 | 49 | test_that("Test 5D List attribute", { 50 | expect_true(inherits(five_D_list_instance, "MoMA_5D_list")) 51 | }) 52 | 53 | 54 | test_that("Error on receiving non-MoMA_5D_list object", { 55 | expect_error( 56 | get_5Dlist_elem(c(1), 1, 1, 1, 1), 57 | paste0(sQuote("x"), " should be a ", sQuote("MoMA_5D_list"), " object") 58 | ) 59 | }) 60 | 61 | 62 | test_that("Access all elements", { 63 | # dim(five_D_list_instance) = 7 3 5 2 64 | # n_alpha_u=7; n_alpha_v=5; n_lambda_u=3; n_lambda_v=2; # mutually prime 65 | cnt <- 1 66 | for (i in 1:n_alpha_u) { 67 | for (j in 1:n_lambda_u) { 68 | for (k in 1:n_alpha_v) { 69 | for (l in 1:n_lambda_v) { 70 | for (rk in 1:rank) { 71 | expect_true(!(is.null(five_D_list_instance[[cnt]]))) 72 | expect_equal( 73 | get_5Dlist_elem(five_D_list_instance, i, j, k, l, rk)[[1]], 74 | five_D_list_instance[[cnt]] 75 | ) 76 | cnt <- cnt + 1 77 | } 78 | } 79 | } 80 | } 81 | } 82 | }) 83 | 84 | test_that("No error when accessing the broundary", { 85 | expect_no_error(get_5Dlist_elem(five_D_list_instance, n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v, rank)) 86 | }) 87 | 88 | test_that("Error when just crossing the broundary", { 89 | # NOTE: R index starts from 1 90 | 91 | # Lower boundary 92 | expect_error( 93 | get_5Dlist_elem(five_D_list_instance, n_alpha_u, n_lambda_u, n_alpha_v, 0), 94 | "Invalid index \\(7,3,5,0,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 95 | ) 96 | 97 | expect_error( 98 | get_5Dlist_elem(five_D_list_instance, n_alpha_u, n_lambda_u, 0, n_lambda_v), 99 | "Invalid index \\(7,3,0,2,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 100 | ) 101 | 102 | expect_error( 103 | get_5Dlist_elem(five_D_list_instance, n_alpha_u, 0, n_alpha_v, n_lambda_v), 104 | "Invalid index \\(7,0,5,2,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 105 | ) 106 | 107 | expect_error( 108 | get_5Dlist_elem(five_D_list_instance, 0, n_lambda_u, n_alpha_v, n_lambda_v), 109 | "Invalid index \\(0,3,5,2,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 110 | ) 111 | 112 | # Upper boundary 113 | expect_error( 114 | get_5Dlist_elem(five_D_list_instance, n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v + 1), 115 | "Invalid index \\(7,3,5,3,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 116 | ) 117 | 118 | expect_error( 119 | get_5Dlist_elem(five_D_list_instance, n_alpha_u, n_lambda_u, n_alpha_v + 1, n_lambda_v), 120 | "Invalid index \\(7,3,6,2,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 121 | ) 122 | 123 | expect_error( 124 | get_5Dlist_elem(five_D_list_instance, n_alpha_u, n_lambda_u + 1, n_alpha_v, n_lambda_v), 125 | "Invalid index \\(7,4,5,2,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 126 | ) 127 | 128 | expect_error( 129 | get_5Dlist_elem(five_D_list_instance, n_alpha_u + 1, n_lambda_u, n_alpha_v, n_lambda_v), 130 | "Invalid index \\(8,3,5,2,1\\), dim = c\\(7, 3, 5, 2, 3\\)" 131 | ) 132 | }) 133 | -------------------------------------------------------------------------------- /src/moma_test_expose.cpp: -------------------------------------------------------------------------------- 1 | #include "moma.h" 2 | #include "moma_prox.h" 3 | #include "moma_solver.h" 4 | 5 | // [[Rcpp::export]] 6 | arma::vec test_prox_lasso(const arma::vec &x, double l) 7 | { 8 | Lasso a; 9 | return a(x, l); 10 | } 11 | 12 | // [[Rcpp::export]] 13 | arma::vec test_prox_nnlasso(const arma::vec &x, double l) 14 | { 15 | NonNegativeLasso a; 16 | return a(x, l); 17 | } 18 | 19 | // [[Rcpp::export]] 20 | arma::vec test_prox_scad(const arma::vec &x, double l, double gamma = 3.7) 21 | { 22 | SCAD a(gamma); 23 | return a(x, l); 24 | } 25 | 26 | // [[Rcpp::export]] 27 | arma::vec test_prox_scadvec(const arma::vec &x, double l, double gamma = 3.7) 28 | { 29 | SCAD a(gamma); 30 | return a.vec_prox(x, l); 31 | } 32 | 33 | // [[Rcpp::export]] 34 | arma::vec test_prox_nnscad(const arma::vec &x, double l, double gamma = 3.7) 35 | { 36 | NonNegativeSCAD a(gamma); 37 | return a(x, l); 38 | } 39 | 40 | // [[Rcpp::export]] 41 | arma::vec test_prox_mcp(const arma::vec &x, double l, double gamma = 4) 42 | { 43 | MCP a(gamma); 44 | return a(x, l); 45 | } 46 | 47 | // [[Rcpp::export]] 48 | arma::vec test_prox_mcpvec(const arma::vec &x, double l, double gamma = 4) 49 | { 50 | MCP a(gamma); 51 | return a.vec_prox(x, l); 52 | } 53 | 54 | // [[Rcpp::export]] 55 | arma::vec test_prox_nnmcp(const arma::vec &x, double l, double gamma = 4) 56 | { 57 | NonNegativeMCP a(gamma); 58 | return a(x, l); 59 | } 60 | 61 | // [[Rcpp::export]] 62 | arma::vec test_prox_grplasso(const arma::vec &x, const arma::vec &g, double l) 63 | { 64 | GrpLasso a(g); 65 | return a(x, l); 66 | } 67 | 68 | // [[Rcpp::export]] 69 | arma::vec test_prox_nngrplasso(const arma::vec &x, const arma::vec &g, double l) 70 | { 71 | NonNegativeGrpLasso a(g); 72 | return a(x, l); 73 | } 74 | 75 | // [[Rcpp::export]] 76 | arma::vec test_prox_fusedlassopath(const arma::vec &x, double l) 77 | { 78 | OrderedFusedLasso a; 79 | return a(x, l); 80 | } 81 | 82 | // [[Rcpp::export]] 83 | arma::vec test_prox_fusedlassodp(const arma::vec &x, double l) 84 | { 85 | OrderedFusedLassoDP a; 86 | return a(x, l); 87 | } 88 | 89 | // [[Rcpp::export]] 90 | arma::vec test_prox_spfusedlasso(const arma::vec &x, double l, double lambda2) 91 | { 92 | // lambda2: the level of penalty on 93 | // the absolute values of the coefficients 94 | SparseFusedLasso a(lambda2); 95 | return a(x, l); 96 | } 97 | 98 | // [[Rcpp::export]] 99 | arma::vec test_prox_fusion(const arma::vec &x, 100 | double l, 101 | const arma::mat w, 102 | bool ADMM, 103 | bool acc, 104 | double prox_eps = 1e-10) 105 | { 106 | Fusion a(w, ADMM, acc, prox_eps); 107 | return a(x, l); 108 | } 109 | 110 | // [[Rcpp::export]] 111 | arma::vec test_prox_l1gf(const arma::vec &x, double l, int k = 1) 112 | { 113 | L1TrendFiltering a(x.n_elem, k); 114 | return a(x, l); 115 | } 116 | 117 | // [[Rcpp::export]] 118 | arma::vec test_prox_slope(const arma::vec &x, double l) 119 | { 120 | // lambda2: the level of penalty on 121 | // the absolute values of the coefficients 122 | SLOPE a(x.n_elem); 123 | return a(x, l); 124 | } 125 | 126 | // [[Rcpp::export]] 127 | int test_df_orderedfusion(const arma::vec &x) 128 | { 129 | OrderedFusedLasso a; 130 | return a.df(x); 131 | } 132 | 133 | // [[Rcpp::export]] 134 | int test_df_spfusedlasso(const arma::vec &x) 135 | { 136 | // SparseFusedLasso object needs a `lambda2` argument 137 | // (the level of penalty on the absolute values of 138 | // the coefficients) to initialize 139 | SparseFusedLasso a(1); 140 | return a.df(x); 141 | } 142 | 143 | // [[Rcpp::export]] 144 | int test_df_l1gf(const arma::vec &x, int k = 1) 145 | { 146 | L1TrendFiltering a(x.n_elem, k); 147 | return a.df(x); 148 | } 149 | 150 | // [[Rcpp::export]] 151 | int test_df_grplasso(const arma::vec &x, const arma::vec &g) 152 | { 153 | GrpLasso a(g); 154 | return a.df(x); 155 | } 156 | 157 | // [[Rcpp::export]] 158 | double test_BIC(const arma::vec y, 159 | const arma::vec y_est, 160 | const std::string &algorithm_string, 161 | double i_alpha, 162 | const arma::mat &i_Omega, 163 | double i_lambda, 164 | Rcpp::List prox_arg_list, 165 | int dim, 166 | double i_EPS = 1e-6, 167 | int i_MAX_ITER = 1e+3) 168 | { 169 | PR_solver solver(algorithm_string, i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, 170 | dim); 171 | 172 | return solver.bic(y, y_est); 173 | } 174 | -------------------------------------------------------------------------------- /man/moma_sflda.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_sflda.R 3 | \name{moma_sflda} 4 | \alias{moma_sflda} 5 | \alias{moma_slda} 6 | \alias{moma_twslda} 7 | \alias{moma_flda} 8 | \alias{moma_twflda} 9 | \title{Sparse and functional LDA} 10 | \usage{ 11 | moma_sflda(X, ..., Y_factor, center = TRUE, scale = FALSE, 12 | x_sparse = moma_empty(), y_sparse = moma_empty(), 13 | x_smooth = moma_smoothness(), y_smooth = moma_smoothness(), 14 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 15 | 16 | moma_slda(X, ..., Y_factor, center = TRUE, scale = FALSE, 17 | x_sparse = moma_empty(), y_sparse = moma_empty(), 18 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 19 | 20 | moma_twslda(X, ..., Y_factor, center = TRUE, scale = FALSE, 21 | x_sparse = moma_empty(), y_sparse = moma_empty(), 22 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 23 | 24 | moma_flda(X, ..., Y_factor, center = TRUE, scale = FALSE, 25 | x_smooth = moma_smoothness(), y_smooth = moma_smoothness(), 26 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 27 | 28 | moma_twflda(X, ..., Y_factor, center = TRUE, scale = FALSE, 29 | x_smooth = moma_smoothness(), y_smooth = moma_smoothness(), 30 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1) 31 | } 32 | \arguments{ 33 | \item{X}{A data matrix, each row representing a sample, and each column a feature.} 34 | 35 | \item{...}{Force users to specify arguments by names.} 36 | 37 | \item{Y_factor}{A factor representing which group a sample belongs to.} 38 | 39 | \item{center}{A logical value indicating whether the variables should be shifted to be zero centered. 40 | Defaults to \code{TRUE}.} 41 | 42 | \item{scale}{A logical value indicating whether the variables should be scaled to have unit variance. 43 | Defaults to \code{FALSE}.} 44 | 45 | \item{x_sparse}{An object of class inheriting from "\code{moma_sparsity_type}". Most conveniently 46 | specified by functions described in \code{\link{moma_sparsity_options}}. It specifies the type of sparsity-inducing 47 | penalty function used in the model. Note that for \code{moma_scca}, these two parameters must not be 48 | specified at the same time. For \code{moma_fcca} and \code{moma_twfcca}, they must not be specified.} 49 | 50 | \item{y_sparse}{An object of class inheriting from "\code{moma_sparsity_type}". Most conveniently 51 | specified by functions described in \code{\link{moma_sparsity_options}}. It specifies the type of sparsity-inducing 52 | penalty function used in the model. Note that for \code{moma_scca}, these two parameters must not be 53 | specified at the same time. For \code{moma_fcca} and \code{moma_twfcca}, they must not be specified.} 54 | 55 | \item{x_smooth}{An object of class inheriting from "\code{moma_smoothness_type}". Most conveniently 56 | specified by functions described in \code{moma_smoothness}. It specifies the type of smoothness 57 | terms used in the model. Note that for \code{moma_fcca}, these two parameters must not be 58 | specified at the same time. For \code{moma_scca} and \code{moma_twscca}, they must not be specified.} 59 | 60 | \item{y_smooth}{An object of class inheriting from "\code{moma_smoothness_type}". Most conveniently 61 | specified by functions described in \code{moma_smoothness}. It specifies the type of smoothness 62 | terms used in the model. Note that for \code{moma_fcca}, these two parameters must not be 63 | specified at the same time. For \code{moma_scca} and \code{moma_twscca}, they must not be specified.} 64 | 65 | \item{pg_settings}{An object of class inheriting from "\code{moma_pg_settings}". Most conviently 66 | specified by functions described in \code{\link{moma_pg_settings}}. It specifies the type of algorithm 67 | used to solve the problem, acceptable level of precision, and the maximum number of iterations allowed.} 68 | 69 | \item{max_bic_iter}{A positive integer. Defaults to 5. The maximum number of iterations allowed 70 | in nested greedy BIC selection scheme.} 71 | 72 | \item{rank}{A positive integer. Defaults to 1. The maximal rank, i.e., maximal number of principal components to be used.} 73 | } 74 | \description{ 75 | \code{moma_sflda} creates an \code{SFLDA} R6 object and returns it. 76 | 77 | \code{moma_slda} is a function for performing one-way sparse LDA. 78 | 79 | \code{moma_twslda} is a function for performing two-way sparse LDA. 80 | 81 | \code{moma_flda} is a function for performing one-way functional LDA. 82 | 83 | \code{moma_twflda} is a function for performing two-way functional LDA. 84 | } 85 | \section{Functions}{ 86 | \itemize{ 87 | \item \code{moma_slda}: a function for performing one-way sparse LDA 88 | 89 | \item \code{moma_twslda}: a function for performing two-way sparse LDA 90 | 91 | \item \code{moma_flda}: a function for performing one-way functional LDA 92 | 93 | \item \code{moma_twflda}: a function for performing two-way functional LDA 94 | }} 95 | 96 | -------------------------------------------------------------------------------- /src/moma_solver.h: -------------------------------------------------------------------------------- 1 | // -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; 2 | // -*- 3 | 4 | #ifndef MOMA_SOLVER 5 | #define MOMA_SOLVER 1 6 | 7 | #include "moma_base.h" 8 | #include "moma_logging.h" 9 | #include "moma_prox.h" 10 | 11 | // Penalized regression solver 12 | // min_u || y - u || + lambda * P(u) s.t. || u ||_S <= 1 13 | // S = I + alpha * Omega 14 | class _PR_solver 15 | { 16 | protected: 17 | int dim; // dimension of the PR problem 18 | double lambda; 19 | double alpha; 20 | double L; 21 | const arma::mat Ω 22 | // S = I + alpha * Omega for u, v smoothing 23 | arma::mat S; 24 | bool is_S_idmat; // indicator of alpha == 0.0 <=> S == I 25 | 26 | // Step size for proximal gradient algorithm 27 | // - since this is a linear model internally, we can used a fixed 28 | // step size without backtracking 29 | double grad_step_size; 30 | double prox_step_size; 31 | // A proximal operator for sparsity inducing penalties 32 | // 33 | // Note that currently the threshold level is not defined in the Prox object 34 | ProxOp p; 35 | // A gradient operator 36 | arma::vec g(const arma::vec &v, 37 | const arma::vec &y, 38 | double step_size, 39 | const arma::mat &S, 40 | bool is_S_idmat); 41 | arma::vec normalize(const arma::vec &u); 42 | 43 | // user-specified precision and max iterations 44 | double EPS; 45 | int MAX_ITER; 46 | 47 | public: 48 | explicit _PR_solver( 49 | // smoothness 50 | double i_alpha, 51 | const arma::mat &i_Omega, 52 | // sparsity 53 | double i_lambda, 54 | Rcpp::List prox_arg_list, 55 | // algorithm settings 56 | double i_EPS, 57 | int i_MAX_ITER, 58 | int i_dim); 59 | 60 | // Used when solving for a bunch of lambda's and alpha's 61 | int set_penalty(double new_lambda, double new_alpha); 62 | double bic(arma::vec y, const arma::vec &est); 63 | virtual ~_PR_solver() = default; 64 | virtual arma::vec solve(arma::vec y, const arma::vec &start_point) = 0; 65 | void check_convergence(int iter, double tol); 66 | }; 67 | 68 | class ISTA : public _PR_solver 69 | { 70 | public: 71 | ISTA(double i_alpha, 72 | const arma::mat &i_Omega, 73 | double i_lambda, 74 | Rcpp::List prox_arg_list, 75 | double i_EPS, 76 | int i_MAX_ITER, 77 | int dim) 78 | : _PR_solver(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim) 79 | { 80 | MoMALogger::debug("Initializing a ISTA solver."); 81 | }; 82 | arma::vec solve(arma::vec y, const arma::vec &start_point); 83 | ~ISTA() { MoMALogger::debug("Releasing a ISTA object"); } 84 | }; 85 | 86 | class FISTA : public _PR_solver 87 | { 88 | public: 89 | FISTA(double i_alpha, 90 | const arma::mat &i_Omega, 91 | double i_lambda, 92 | Rcpp::List prox_arg_list, 93 | double i_EPS, 94 | int i_MAX_ITER, 95 | int dim) 96 | : _PR_solver(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim) 97 | { 98 | MoMALogger::debug("Initializing a FISTA solver."); 99 | }; 100 | arma::vec solve(arma::vec y, const arma::vec &start_point); 101 | ~FISTA() { MoMALogger::debug("Releasing a FISTA object"); } 102 | }; 103 | 104 | class OneStepISTA : public _PR_solver 105 | { 106 | public: 107 | OneStepISTA(double i_alpha, 108 | const arma::mat &i_Omega, 109 | double i_lambda, 110 | Rcpp::List prox_arg_list, 111 | double i_EPS, 112 | int i_MAX_ITER, 113 | int dim) 114 | : _PR_solver(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim) 115 | { 116 | MoMALogger::debug("Initializing an one-step ISTA solver."); 117 | }; 118 | arma::vec solve(arma::vec y, const arma::vec &start_point); 119 | ~OneStepISTA() { MoMALogger::debug("Releasing a OneStepISTA object"); } 120 | }; 121 | 122 | // A handle class 123 | class PR_solver 124 | { 125 | private: 126 | _PR_solver *prs; 127 | 128 | public: 129 | PR_solver( 130 | // a string saying which algorithm to use 131 | const std::string &algorithm_string, 132 | // same as class _PR_solver 133 | double i_alpha, 134 | const arma::mat &i_Omega, 135 | double i_lambda, 136 | Rcpp::List prox_arg_list, 137 | double i_EPS, 138 | int i_MAX_ITER, 139 | int dim); 140 | 141 | // wrap operations in _PR_solver class 142 | arma::vec solve(arma::vec y, const arma::vec &start_point); 143 | double bic(arma::vec y, const arma::vec &est); 144 | int set_penalty(double new_lambda, double new_alpha); 145 | 146 | ~PR_solver() { delete prs; } 147 | }; 148 | 149 | #endif 150 | -------------------------------------------------------------------------------- /vignettes/moma-quick-start.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Introduction to the `MoMA` Package" 3 | author: "Michael Weylandt, Luofeng Liao" 4 | date: "`r Sys.Date()`" 5 | output: html_vignette 6 | bibliography: vignettes.bibtex 7 | vignette: > 8 | %\VignetteIndexEntry{MoMA} 9 | %\VignetteEngine{knitr::rmarkdown} 10 | %\VignetteEncoding{UTF-8} 11 | --- 12 | 13 | ```{r echo=FALSE,cache=FALSE} 14 | set.seed(1234) 15 | knitr::opts_chunk$set(cache = TRUE, collapse = TRUE) 16 | ``` 17 | 18 | The unified SFPCA (Sparse and Functional Principal Component Analysis) method enjoys many advantages over existing approaches to regularized PC, because it 19 | 20 | * allows for arbitrary degrees and forms of regularization; 21 | 22 | * unifies many existing methods; 23 | 24 | * admits a tractable, efficient, and theoretically well-grounded algorithm. 25 | 26 | The problem is formulated as follows. 27 | 28 | $$\max_{u,\,,v}{u}^{T} {X} {v}-\lambda_{{u}} P_{{u}}({u})-\lambda_{{v}} P_{{v}}({v})$$ 29 | $$\text{s.t. } \| u \| _ {S_u} \leq 1, \, \| v \| _ {S_v} \leq 1.$$ 30 | Typically, we take ${S}_{{u}}={I}+\alpha_{{u}} {\Omega}_{{u}}$ where $\Omega_u$ is the second- or fourth-difference matrix, so that the $\|u \|_{S_u}$ penalty term encourages smoothness in the estimated singular vectors. $P_u$ and $P_v$ are sparsity inducing penalties that satisfy the following conditions: 31 | 32 | * $P \geq 0$, $P$ defined on $[0,+\infty)$; 33 | 34 | * $P(cx) = c P (x), \forall \, c > 0$. 35 | 36 | ## A Wide Range of Modeling Options 37 | 38 | Currently, the package supports arbitrary combination of the following. 39 | 40 | #### Various sparsity-inducing penalties 41 | 42 | So far, we have incorporated the following penalties in MoMA. The code under each penalty is only an example specification of the penalty. They should be carefully tailored based on your particular data set. 43 | 44 | * LASSO (least absolute shrinkage and selection operator), see `moma_lasso`; 45 | ``` {r eval = FALSE} 46 | # `non_negative`: impose non-negativity constraint or not 47 | moma_lasso(non_negative = TURE) 48 | ``` 49 | 50 | * SCAD `moma_lasso`(smoothly clipped absolute deviation), see `moma_scad`; 51 | ``` {r eval = FALSE} 52 | # `gamma` is the non-convexity parameter 53 | moma_scad(gamma = 3, non_negative = TURE) 54 | ``` 55 | 56 | * MCP (minimax concave penalty), see `moma_mcp`; 57 | ``` {r eval = FALSE} 58 | # `gamma` is the non-convexity parameter 59 | moma_mcp(gamma = 3, non_negative = TURE) 60 | ``` 61 | 62 | * SLOPE (sorted $\ell$-one penalized estimation), see `moma_slope`; 63 | ``` {r eval = FALSE} 64 | # `gamma` is the non-convexity parameter 65 | moma_slope(gamma = 3, non_negative = TURE) 66 | ``` 67 | 68 | * Group LASSO, see `moma_grplasso`; 69 | ``` {r eval = FALSE} 70 | # `g` is a factor indicating the grouping 71 | moma_grplasso(g = g, non_negative = TURE) 72 | ``` 73 | 74 | * Fused LASSO, see `moma_fusedlasso`; 75 | ``` {r eval = FALSE} 76 | # `algo` is indicates which algorithm to solve the proximal operator 77 | # "dp": dynamic programming, "path": path-based algorithm 78 | moma_fusedlasso(algo = "dp") 79 | ``` 80 | 81 | * L1 trend filtering, see `moma_l1tf`; 82 | ``` {r eval = FALSE} 83 | # `l1tf_k = 2` imposes piece-wise linear 84 | moma_l1tf(l1tf_k = 2) 85 | ``` 86 | 87 | * Sparse fused LASSO, see `moma_spfusedlasso`; 88 | ``` {r eval = FALSE} 89 | # `lambda2` is penalty level for the adjacent difference 90 | moma_spfusedlasso(lambda2 = 1) 91 | ``` 92 | 93 | * Cluster penalty, see `moma_cluster`. 94 | ``` {r eval = FALSE} 95 | # `w` is a symmectric matrix, whose entry, w[i][j], is the weight connecting 96 | # the i-th and the j-th element 97 | moma_cluster(w = w) 98 | ``` 99 | 100 | #### Parameter selection schemes 101 | 102 | * Exhaustive search 103 | 104 | * Nested BIC. See `select_scheme` for details. 105 | 106 | #### Multivariate methods 107 | 108 | * PCA (Principal Component Analysis). See `moma_sfpca`. 109 | 110 | * CCA (Canonical Component Analysis). See `moma_sfcca`. 111 | 112 | * LDA (Linear Discriminant Anlsysis). See `moma_sflda`. 113 | 114 | * PLS (Partial Least Square) (TODO) 115 | 116 | * Correspondence Analysis (TODO) 117 | 118 | #### Deflation schemes 119 | 120 | * Hotelling's deflation (PCA) 121 | 122 | * Projection deflation (PCA, CCA, LDA) 123 | 124 | * Schur's complement (PCA) 125 | 126 | ## Excellent User Experience 127 | 128 | * Easy-to-use functions. Let $\Delta$ be a second-difference matrix of appropriate size, such that $u^T\Delta u = \sum_i (u_{i} - u_{i-1} )^2$. For a matrix $X$, one line of code can solve the following penalized singular value decomposition problem: 129 | 130 | $$\max_{u,\, v} \, {u}^{T} {X} {v} - 4 \sum_i | v_i - v_{i-1}|$$ 131 | $$ \text{s.t. } u^T(I + 3 \Delta) u \leq 1,\, v^Tv \leq 1.$$ 132 | 133 | ```{r eval=FALSE} 134 | # `p` is the length of `u` 135 | moma_sfpca(X, 136 | center = FALSE, 137 | v_sparse = moma_fusedlasso(lambda = 4), 138 | u_smooth = moma_smoothness(second_diff_mat(p), alpha = 3) 139 | ) 140 | ``` 141 | 142 | 143 | * R6 methods to support access of results. 144 | 145 | * Shiny supports interation with MoMA. 146 | 147 | * Fast. `MoMA` uses the `Rcpp` and `RcppArmadillo` libraries for speed 148 | [@Eddelbuettel:2011; @Eddelbuettel:2014; @Sanderson:2016]. 149 | 150 | ## References 151 | 152 | -------------------------------------------------------------------------------- /docs/pkgdown.css: -------------------------------------------------------------------------------- 1 | /* Sticky footer */ 2 | 3 | /** 4 | * Basic idea: https://philipwalton.github.io/solved-by-flexbox/demos/sticky-footer/ 5 | * Details: https://github.com/philipwalton/solved-by-flexbox/blob/master/assets/css/components/site.css 6 | * 7 | * .Site -> body > .container 8 | * .Site-content -> body > .container .row 9 | * .footer -> footer 10 | * 11 | * Key idea seems to be to ensure that .container and __all its parents__ 12 | * have height set to 100% 13 | * 14 | */ 15 | 16 | html, body { 17 | height: 100%; 18 | } 19 | 20 | body > .container { 21 | display: flex; 22 | height: 100%; 23 | flex-direction: column; 24 | 25 | padding-top: 60px; 26 | } 27 | 28 | body > .container .row { 29 | flex: 1 0 auto; 30 | } 31 | 32 | footer { 33 | margin-top: 45px; 34 | padding: 35px 0 36px; 35 | border-top: 1px solid #e5e5e5; 36 | color: #666; 37 | display: flex; 38 | flex-shrink: 0; 39 | } 40 | footer p { 41 | margin-bottom: 0; 42 | } 43 | footer div { 44 | flex: 1; 45 | } 46 | footer .pkgdown { 47 | text-align: right; 48 | } 49 | footer p { 50 | margin-bottom: 0; 51 | } 52 | 53 | img.icon { 54 | float: right; 55 | } 56 | 57 | img { 58 | max-width: 100%; 59 | } 60 | 61 | /* Fix bug in bootstrap (only seen in firefox) */ 62 | summary { 63 | display: list-item; 64 | } 65 | 66 | /* Typographic tweaking ---------------------------------*/ 67 | 68 | .contents .page-header { 69 | margin-top: calc(-60px + 1em); 70 | } 71 | 72 | /* Section anchors ---------------------------------*/ 73 | 74 | a.anchor { 75 | margin-left: -30px; 76 | display:inline-block; 77 | width: 30px; 78 | height: 30px; 79 | visibility: hidden; 80 | 81 | background-image: url(./link.svg); 82 | background-repeat: no-repeat; 83 | background-size: 20px 20px; 84 | background-position: center center; 85 | } 86 | 87 | .hasAnchor:hover a.anchor { 88 | visibility: visible; 89 | } 90 | 91 | @media (max-width: 767px) { 92 | .hasAnchor:hover a.anchor { 93 | visibility: hidden; 94 | } 95 | } 96 | 97 | 98 | /* Fixes for fixed navbar --------------------------*/ 99 | 100 | .contents h1, .contents h2, .contents h3, .contents h4 { 101 | padding-top: 60px; 102 | margin-top: -40px; 103 | } 104 | 105 | /* Static header placement on mobile devices */ 106 | @media (max-width: 767px) { 107 | .navbar-fixed-top { 108 | position: absolute; 109 | } 110 | .navbar { 111 | padding: 0; 112 | } 113 | } 114 | 115 | 116 | /* Sidebar --------------------------*/ 117 | 118 | #sidebar { 119 | margin-top: 30px; 120 | } 121 | #sidebar h2 { 122 | font-size: 1.5em; 123 | margin-top: 1em; 124 | } 125 | 126 | #sidebar h2:first-child { 127 | margin-top: 0; 128 | } 129 | 130 | #sidebar .list-unstyled li { 131 | margin-bottom: 0.5em; 132 | } 133 | 134 | .orcid { 135 | height: 16px; 136 | vertical-align: middle; 137 | } 138 | 139 | /* Reference index & topics ----------------------------------------------- */ 140 | 141 | .ref-index th {font-weight: normal;} 142 | 143 | .ref-index td {vertical-align: top;} 144 | .ref-index .icon {width: 40px;} 145 | .ref-index .alias {width: 40%;} 146 | .ref-index-icons .alias {width: calc(40% - 40px);} 147 | .ref-index .title {width: 60%;} 148 | 149 | .ref-arguments th {text-align: right; padding-right: 10px;} 150 | .ref-arguments th, .ref-arguments td {vertical-align: top;} 151 | .ref-arguments .name {width: 20%;} 152 | .ref-arguments .desc {width: 80%;} 153 | 154 | /* Nice scrolling for wide elements --------------------------------------- */ 155 | 156 | table { 157 | display: block; 158 | overflow: auto; 159 | } 160 | 161 | /* Syntax highlighting ---------------------------------------------------- */ 162 | 163 | pre { 164 | word-wrap: normal; 165 | word-break: normal; 166 | border: 1px solid #eee; 167 | } 168 | 169 | pre, code { 170 | background-color: #f8f8f8; 171 | color: #333; 172 | } 173 | 174 | pre code { 175 | overflow: auto; 176 | word-wrap: normal; 177 | white-space: pre; 178 | } 179 | 180 | pre .img { 181 | margin: 5px 0; 182 | } 183 | 184 | pre .img img { 185 | background-color: #fff; 186 | display: block; 187 | height: auto; 188 | } 189 | 190 | code a, pre a { 191 | color: #375f84; 192 | } 193 | 194 | a.sourceLine:hover { 195 | text-decoration: none; 196 | } 197 | 198 | .fl {color: #1514b5;} 199 | .fu {color: #000000;} /* function */ 200 | .ch,.st {color: #036a07;} /* string */ 201 | .kw {color: #264D66;} /* keyword */ 202 | .co {color: #888888;} /* comment */ 203 | 204 | .message { color: black; font-weight: bolder;} 205 | .error { color: orange; font-weight: bolder;} 206 | .warning { color: #6A0366; font-weight: bolder;} 207 | 208 | /* Clipboard --------------------------*/ 209 | 210 | .hasCopyButton { 211 | position: relative; 212 | } 213 | 214 | .btn-copy-ex { 215 | position: absolute; 216 | right: 0; 217 | top: 0; 218 | visibility: hidden; 219 | } 220 | 221 | .hasCopyButton:hover button.btn-copy-ex { 222 | visibility: visible; 223 | } 224 | 225 | /* mark.js ----------------------------*/ 226 | 227 | mark { 228 | background-color: rgba(255, 255, 51, 0.5); 229 | border-bottom: 2px solid rgba(255, 153, 51, 0.3); 230 | padding: 1px; 231 | } 232 | 233 | /* vertical spacing after htmlwidgets */ 234 | .html-widget { 235 | margin-bottom: 10px; 236 | } 237 | -------------------------------------------------------------------------------- /docs/SUPPORT.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | NA • MoMA 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 45 | 46 | 47 | 48 | 49 | 50 |
    51 |
    52 | 107 | 108 | 109 |
    110 | 111 |
    112 |
    113 |
    114 |

    NA

    115 |
    116 | 117 | 118 |

    Thank you for using MoMA!

    119 |

    Feature requests can be reported on the issue tracker.

    120 |

    For help using the existing features of MoMA, please contact Michael Weylandt and include the tag “[MoMA package help]” in your subject line. Please include the output of moma::moma_session_info() in your email.

    121 | 122 | 123 |
    124 | 125 |
    126 | 127 | 128 |
    129 |
    130 |

    Developed by Michael Weylandt, Genevera Allen, Luofeng Liao.

    131 |
    132 | 133 |
    134 |

    Site built with pkgdown 1.3.0.

    135 |
    136 |
    137 |
    138 | 139 | 140 | 141 | 142 | 143 | 144 | -------------------------------------------------------------------------------- /man/moma_sfpca.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/moma_sfpca.R 3 | \name{moma_sfpca} 4 | \alias{moma_sfpca} 5 | \alias{moma_spca} 6 | \alias{moma_twspca} 7 | \alias{moma_fpca} 8 | \alias{moma_twfpca} 9 | \title{Sparse and functional PCA} 10 | \usage{ 11 | moma_sfpca(X, ..., center = TRUE, scale = FALSE, 12 | u_sparse = moma_empty(), v_sparse = moma_lasso(), 13 | u_smooth = moma_smoothness(), v_smooth = moma_smoothness(), 14 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1, 15 | deflation_scheme = "PCA_Hotelling") 16 | 17 | moma_spca(X, ..., center = TRUE, scale = FALSE, 18 | u_sparse = moma_empty(), v_sparse = moma_lasso(), 19 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1, 20 | deflation_scheme = "PCA_Hotelling") 21 | 22 | moma_twspca(X, ..., center = TRUE, scale = FALSE, 23 | u_sparse = moma_lasso(), v_sparse = moma_lasso(), 24 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1, 25 | deflation_scheme = "PCA_Hotelling") 26 | 27 | moma_fpca(X, ..., center = TRUE, scale = FALSE, 28 | u_smooth = moma_smoothness(), v_smooth = moma_smoothness(), 29 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1, 30 | deflation_scheme = "PCA_Hotelling") 31 | 32 | moma_twfpca(X, ..., center = TRUE, scale = FALSE, 33 | u_smooth = moma_smoothness(), v_smooth = moma_smoothness(), 34 | pg_settings = moma_pg_settings(), max_bic_iter = 5, rank = 1, 35 | deflation_scheme = "PCA_Hotelling") 36 | } 37 | \arguments{ 38 | \item{X}{A data matrix, each row representing a sample, and each column a feature.} 39 | 40 | \item{...}{Force users to specify arguments by names.} 41 | 42 | \item{center}{A logical value indicating whether the variables should be shifted to be zero centered. 43 | Defaults to \code{TRUE}.} 44 | 45 | \item{scale}{A logical value indicating whether the variables should be scaled to have unit variance. 46 | Defaults to \code{FALSE}.} 47 | 48 | \item{u_sparse, v_sparse}{An object of class inheriting from "\code{moma_sparsity_type}". Most conveniently 49 | specified by functions described in \code{\link{moma_sparsity_options}}. It specifies the type of sparsity-inducing 50 | penalty function used in the model. Note that for \code{moma_spca}, these two parameters must not be 51 | specified at the same time. For \code{moma_fpca} and \code{moma_twfpca}, they must not be specified.} 52 | 53 | \item{u_smooth, v_smooth}{An object of class inheriting from "\code{moma_smoothness_type}". Most conveniently 54 | specified by functions described in \code{moma_smoothness}. It specifies the type of smoothness 55 | terms used in the model. Note that for \code{moma_fpca}, these two parameters must not be 56 | specified at the same time. For \code{moma_spca} and \code{moma_twspca}, they must not be specified.} 57 | 58 | \item{pg_settings}{An object of class inheriting from "\code{moma_pg_settings}". Most conviently 59 | specified by functions described in \code{\link{moma_pg_settings}}. It specifies the type of algorithm 60 | used to solve the problem, acceptable level of precision, and the maximum number of iterations allowed.} 61 | 62 | \item{max_bic_iter}{A positive integer. Defaults to 5. The maximum number of iterations allowed 63 | in nested greedy BIC selection scheme.} 64 | 65 | \item{rank}{A positive integer. Defaults to 1. The maximal rank, i.e., maximal number of principal components to be used.} 66 | 67 | \item{deflation_scheme}{A string specifying the deflation scheme. 68 | It should be one of \code{"PCA_Hotelling", "PCA_Schur_Complement", "PCA_Projection"}. 69 | 70 | In the discussion below, let \eqn{u,v} be the normalized vectors obtained by 71 | scaling the penalized singular vectors. 72 | 73 | When \code{deflation_scheme = "Hotelling_deflation"} is specified, the following deflation 74 | scheme is used. \eqn{\boldsymbol{X}_{t} :=\boldsymbol{X}_{t-1}-d_{t} \boldsymbol{u}_{t} \boldsymbol{v}_{t}^{T}}, 75 | where \eqn{d_{t}=\boldsymbol{u}_{t}^{T} \boldsymbol{X}_{t-1} \boldsymbol{v}_{t}}. 76 | 77 | When \code{deflation_scheme = "PCA_Schur_Complement"} is specified, the following deflation 78 | scheme is used: \eqn{\boldsymbol{X}_{t} :=\left(\boldsymbol{I}_{n}- 79 | \boldsymbol{u}_{t} \boldsymbol{u}_{t}^{T}\right) \boldsymbol{X}_{t-1} 80 | \left(\boldsymbol{I}_{p}-\boldsymbol{v}_{t} \boldsymbol{v}_{t}^{T}\right)}. 81 | 82 | When \code{deflation_scheme = "PCA_Projection"} is specified, the following deflation 83 | scheme is used: 84 | \eqn{\boldsymbol{X}_{t} :=\boldsymbol{X}_{t-1}-\frac{\boldsymbol{X}_{t-1} 85 | \boldsymbol{v}_{t} \boldsymbol{u}_{t}^{T} \boldsymbol{X}_{t-1}}{\boldsymbol{u}_{t}^{T} 86 | \boldsymbol{X}_{t-1} \boldsymbol{v}_{t}}}.} 87 | } 88 | \value{ 89 | An R6 object which provides helper functions to access the results. See \code{\link{moma_R6}}. 90 | } 91 | \description{ 92 | \code{moma_sfpca} creates an \code{SFPCA} R6 object and returns it. 93 | 94 | \code{moma_spca} is a function for performing one-way sparse PCA. 95 | 96 | \code{moma_twspca} is a function for performing two-way sparse PCA. 97 | 98 | \code{moma_fpca} is a function for performing one-way functional PCA. 99 | 100 | \code{moma_twfpca} is a function for performing two-way functional PCA. 101 | } 102 | \section{Functions}{ 103 | \itemize{ 104 | \item \code{moma_spca}: a function for performing one-way sparse PCA 105 | 106 | \item \code{moma_twspca}: a function for performing two-way sparse PCA 107 | 108 | \item \code{moma_fpca}: a function for performing one-way functional PCA 109 | 110 | \item \code{moma_twfpca}: a function for performing two-way functional PCA 111 | }} 112 | 113 | -------------------------------------------------------------------------------- /tests/testthat/test_solve.R: -------------------------------------------------------------------------------- 1 | context("SFPCA tests") 2 | test_that("Equivalent to SVD when no penalty imposed", { 3 | set.seed(32) 4 | 5 | for (i in 1:30) { 6 | n <- 17 # set n != p to test bugs 7 | p <- 23 8 | X <- matrix(runif(n * p), n) 9 | sfpca <- sfpca(X) 10 | 11 | svd.result <- svd(X) 12 | svd.result$u[, 1:4] 13 | sfpca$u 14 | 15 | expect_equal(norm(svd.result$v[, 1] - sfpca$v), 0) 16 | expect_equal(norm(svd.result$u[, 1] - sfpca$u), 0) 17 | expect_equal(svd.result$d[1], sfpca$d[1]) 18 | } 19 | }) 20 | 21 | test_that("Closed-form solution when Omega = I and no sparsity", { 22 | set.seed(32) 23 | n <- 17 # set n != p to test bugs 24 | p <- 23 25 | a_u.range <- seq(0, 3, 0.05) 26 | a_v.range <- seq(0, 3, 0.05) 27 | for (a_u in a_u.range) { 28 | for (a_v in a_v.range) { 29 | for (solver in c("ISTA", "FISTA", "ONESTEPISTA")) { 30 | # NOTE: We can have one-step ISTA here 31 | X <- matrix(runif(n * p), n) 32 | 33 | sfpca <- sfpca(X, 34 | alpha_u = a_u, alpha_v = a_v, Omega_u = diag(n), Omega_v = diag(p), 35 | EPS = 1e-9, MAX_ITER = 1e+5, solver = solver 36 | ) 37 | svd.result <- svd(X) 38 | expect_equal(norm(svd.result$v[, 1] - sqrt(1 + a_v) * sfpca$v), 0) 39 | expect_equal(norm(svd.result$u[, 1] - sqrt(1 + a_u) * sfpca$u), 0) 40 | expect_equal(svd.result$d[1], sqrt((1 + a_v) * (1 + a_u)) * sfpca$d[1]) 41 | } 42 | } 43 | } 44 | }) 45 | 46 | test_that("Closed-form solution when no sparsity imposed", { 47 | n <- 17 # set n != p to test bugs 48 | p <- 23 49 | set.seed(32) 50 | X <- matrix(runif(n * p), n) 51 | 52 | # construct p.d. matrix as smoothing matrix 53 | O_v <- crossprod(matrix(runif(p * p), p, p)) 54 | O_u <- crossprod(matrix(runif(n * n), n, n)) 55 | 56 | # set some random alpha's 57 | # WARNING: running time increases quickly as alpha increases 58 | a_u.range <- seq(5) 59 | a_v.range <- seq(5) 60 | for (a_u in a_u.range) { 61 | for (a_v in a_v.range) { 62 | # Cholesky decomposition, note S = I + alpah * Omega 63 | Lv <- chol(a_v * O_v + diag(p)) 64 | Lu <- chol(a_u * O_u + diag(n)) 65 | 66 | svd.result <- svd(t(solve(Lu)) %*% X %*% solve(Lv)) 67 | svd.result.v <- svd.result$v[, 1] 68 | svd.result.u <- svd.result$u[, 1] 69 | 70 | for (solver in c("ISTA", "FISTA")) { 71 | # WARNING: One-step ISTA does not pass this test 72 | res <- sfpca(X, 73 | Omega_u = O_u, Omega_v = O_v, alpha_u = a_u, alpha_v = a_v, 74 | EPS = 1e-7, MAX_ITER = 1e+5, solver = solver 75 | ) 76 | 77 | # The sfpca solutions and the svd solutions are related by an `L` matrix 78 | res.v <- Lv %*% res$v 79 | res.u <- Lu %*% res$u 80 | 81 | # same.direction = 1 if same direction else -1 82 | same.direction <- ((svd.result$v[, 1][1] * res.v[1]) > 0) * 2 - 1 83 | 84 | # tests 85 | expect_lte(norm(svd.result$v[, 1] - same.direction * res.v), 1e-5) 86 | expect_lte(norm(svd.result$u[, 1] - same.direction * res.u), 1e-5) 87 | } 88 | } 89 | } 90 | }) 91 | 92 | test_that("ISTA and FISTA should yield similar results, 93 | in the presence of both sparse and smooth penalty", { 94 | set.seed(332) 95 | n <- 7 # set n != p to test bugs 96 | p <- 11 97 | X <- matrix(runif(n * p), n) 98 | 99 | # generate p.d. matrices 100 | O_v <- crossprod(matrix(runif(p * p), p, p)) 101 | O_u <- crossprod(matrix(runif(n * n), n, n)) 102 | 103 | # run tests 104 | # NOTE: there's no need to test for large 105 | # lambda's and alpha's because in those 106 | # cases u and v are zeros 107 | cnt <- 0 108 | for (sp in seq(0, 5, 0.1)) { 109 | for (sm in seq(0, 5, 0.1)) { 110 | # TODO: Add "L1TRENDFILTERING" 111 | for (sptype in c("LASSO", "SCAD", "MCP", "ORDEREDFUSED")) { 112 | ista <- sfpca(X, 113 | Omega_u = O_u, Omega_v = O_v, alpha_u = sp, alpha_v = sp, 114 | lambda_u = sm, lambda_v = sm, P_u = "LASSO", P_v = sptype, 115 | EPS = 1e-14, MAX_ITER = 1e+3, solver = "ISTA", EPS_inner = 1e-9 116 | ) 117 | fista <- sfpca(X, 118 | Omega_u = O_u, Omega_v = O_v, alpha_u = sp, alpha_v = sp, 119 | lambda_u = sm, lambda_v = sm, P_u = "LASSO", P_v = sptype, 120 | EPS = 1e-6, MAX_ITER = 1e+3, solver = "FISTA", EPS_inner = 1e-9 121 | ) 122 | 123 | # WARNING: We observe if zero appears in either v or u, ista and fista 124 | # might not give identical results. 125 | # Maybe they will both eventually go to the same point, but ista slows 126 | # down a lot before it reaches it and consequently meets the stopping criterion. 127 | if (sum(ista$v[, 1] == 0.0) == 0 128 | && sum(fista$v[, 1] == 0.0) == 0) { 129 | expect_lte(sum((ista$v[, 1] - fista$v[, 1])^2), 1e-6) 130 | expect_lte(sum((ista$u[, 1] - fista$u[, 1])^2), 1e-6) 131 | } 132 | } 133 | } 134 | } 135 | }) 136 | -------------------------------------------------------------------------------- /docs/articles/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Articles • MoMA 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 45 | 46 | 47 | 48 | 49 | 50 |
    51 |
    52 | 107 | 108 | 109 |
    110 | 111 |
    112 |
    113 |
    114 |

    Articles

    115 |
    116 | 117 |
    118 |

    All vignettes

    119 |

    120 | 121 | 127 |
    128 |
    129 |
    130 | 131 |
    132 |
    133 |

    Developed by Michael Weylandt, Genevera Allen, Luofeng Liao.

    134 |
    135 | 136 |
    137 |

    Site built with pkgdown 1.3.0.

    138 |
    139 |
    140 |
    141 | 142 | 143 | 144 | 145 | 146 | 147 | -------------------------------------------------------------------------------- /docs/authors.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Authors • MoMA 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 45 | 46 | 47 | 48 | 49 | 50 |
    51 |
    52 | 107 | 108 | 109 |
    110 | 111 |
    112 |
    113 |
    114 |

    Authors

    115 |
    116 | 117 |
      118 |
    • 119 |

      Michael Weylandt. Author, maintainer. 120 |

      121 |
      • 122 |
    • 123 |

      Genevera Allen. Author. 124 |

      125 |
      • 126 |
    • 127 |

      Luofeng Liao. Author. 128 |

      129 |
      • 130 |
    • 131 |

      Nicholas Johnson. Copyright holder. 132 |
      src/moma_prox_flsadp.cpp

      133 |
      • 134 |
    135 | 136 |
    137 | 138 |
    139 | 140 | 141 |
    142 |
    143 |

    Developed by Michael Weylandt, Genevera Allen, Luofeng Liao.

    144 |
    145 | 146 |
    147 |

    Site built with pkgdown 1.3.0.

    148 |
    149 |
    150 |
    151 | 152 | 153 | 154 | 155 | 156 | 157 | -------------------------------------------------------------------------------- /src/moma_heap.cpp: -------------------------------------------------------------------------------- 1 | #include "moma_heap.h" 2 | #include "moma_prox_fusion_util.h" 3 | 4 | bool operator>(const HeapNode &left, const HeapNode &right) 5 | { 6 | return left.lambda > right.lambda; 7 | } 8 | 9 | bool gt(const HeapNode &left, const HeapNode &right) 10 | { 11 | return left > right; 12 | } 13 | 14 | Heap::Heap(int n) 15 | { 16 | heap_storage.resize(n); 17 | }; 18 | 19 | void Heap::heapify() 20 | { 21 | std::make_heap(heap_storage.begin(), heap_storage.end(), gt); 22 | } 23 | 24 | // Find the smaller child of an element in a heap. Used in siftdown 25 | int Heap::min_child(int i) 26 | { 27 | int cur_size = heap_storage.size(); 28 | int child = i * 2 + 1; 29 | if (child >= cur_size) 30 | { 31 | // no children 32 | return NO_CHILD; 33 | } 34 | else if (child + 1 >= cur_size || !(heap_storage[child] > heap_storage[child + 1])) 35 | { 36 | // only child or first child is biggest child 37 | return child; 38 | } 39 | else 40 | { 41 | // second child exists and is smallest child 42 | return child + 1; 43 | } 44 | } 45 | 46 | // TODO: extra copy can be avoided in siftdown 47 | void Heap::swap(int i, int j, FusedGroups *fg) 48 | { 49 | // // DEBUG INFO 50 | MoMALogger::debug("Swapping ") << heap_storage[i].lambda << "and " << heap_storage[j].lambda; 51 | (*fg).g[heap_storage[i].id].map_to_heap = j; 52 | (*fg).g[heap_storage[j].id].map_to_heap = i; 53 | HeapNode tmp = heap_storage[i]; 54 | heap_storage[i] = heap_storage[j]; 55 | heap_storage[j] = tmp; 56 | } 57 | 58 | // In a min-heap, if the key (lambda in our case) decreases, sift it up 59 | void Heap::siftup(int i, FusedGroups *fg) 60 | { 61 | int parent = (i - 1) / 2; 62 | while (i != 0 && (heap_storage[parent] > heap_storage[i])) 63 | { 64 | Heap::swap(parent, i, fg); 65 | i = parent; 66 | parent = (i - 1) / 2; 67 | } 68 | } 69 | 70 | // In a min-heap, if the key (lambda in our case) increases, sift it down 71 | void Heap::siftdown(int current_node, FusedGroups *fg) 72 | { 73 | int child = min_child(current_node); 74 | while (child != NO_CHILD && (heap_storage[current_node] > heap_storage[child])) 75 | { 76 | Heap::swap(child, current_node, fg); 77 | current_node = child; 78 | child = min_child(child); 79 | } 80 | } 81 | 82 | // Change the key of any nodes; 83 | int Heap::change_lambda_by_id(int i, double new_lambda, FusedGroups *fg) 84 | { 85 | if (i < 0 || i >= heap_storage.size()) 86 | { 87 | MoMALogger::error("Try to change lambda: no such id in current heap: ") << i; 88 | } 89 | double old_lambda = heap_storage[i].lambda; 90 | heap_storage[i].lambda = new_lambda; 91 | if (old_lambda < new_lambda) 92 | { 93 | // // DEBUG INFO 94 | // MoMALogger::debug("(") << old_lambda << "," << heap[i].id << ")" << "->" 95 | // << new_lambda << " siftdown"; 96 | siftdown(i, fg); 97 | } 98 | else 99 | { 100 | // // DEBUG INFO 101 | // MoMALogger::debug("") << old_lambda << "," << heap[i].id << ")" << "->" 102 | // << new_lambda << " siftup"; 103 | siftup(i, fg); 104 | } 105 | return i; 106 | } 107 | 108 | // To delete an element, move it to the tail, pop it out, and then sift down 109 | // the node that replaces it 110 | void Heap::remove(int i, FusedGroups *fg) 111 | { 112 | if (i < 0 || i >= heap_storage.size()) 113 | { 114 | MoMALogger::error("Try to delete: no such id in current heap: ") << i; 115 | } 116 | double old_lambda = heap_storage[i].lambda; 117 | Heap::swap(i, heap_storage.size() - 1, fg); 118 | (*fg).g[heap_storage[heap_storage.size() - 1].id].map_to_heap = FusedGroups::NOT_IN_HEAP; 119 | heap_storage.pop_back(); 120 | if (old_lambda < heap_storage[i].lambda) 121 | { 122 | siftdown(i, fg); 123 | } 124 | else 125 | { 126 | siftup(i, fg); 127 | } 128 | return; 129 | } 130 | 131 | // Check if an array is a min heap 132 | bool Heap::is_minheap() 133 | { 134 | int i = 0; 135 | while (2 * i + 1 < heap_storage.size()) 136 | { 137 | if (heap_storage[i] > heap_storage[2 * i + 1]) 138 | { 139 | MoMALogger::warning("Not a min-heap") 140 | << heap_storage[i].lambda << "and" << heap_storage[2 * i + 1].lambda; 141 | return 0; 142 | } 143 | if (2 * i + 2 < heap_storage.size()) 144 | { 145 | if (heap_storage[i] > heap_storage[2 * i + 2]) 146 | { 147 | MoMALogger::warning("Not a min-heap") 148 | << heap_storage[i].lambda << "and" << heap_storage[2 * i + 2].lambda; 149 | return 0; 150 | } 151 | } 152 | i++; 153 | } 154 | return 1; 155 | } 156 | 157 | bool Heap::is_empty() 158 | { 159 | return heap_storage.size() == 0; 160 | } 161 | 162 | // Get the currently minimun value without deleting the node 163 | HeapNode Heap::heap_peek_min() 164 | { 165 | if (is_empty()) 166 | { 167 | MoMALogger::error("You are peaking at an empty heap!"); 168 | } 169 | HeapNode n = heap_storage.front(); 170 | return n; 171 | } 172 | 173 | // Print the heap 174 | void Heap::heap_print() 175 | { 176 | MoMALogger::debug("") << "(lambda, id)\n"; 177 | int cnt = 0; 178 | int thre = 1; 179 | for (auto i : heap_storage) 180 | { 181 | Rcpp::Rcout << i.lambda << ", " << i.id + 1 << "\t"; 182 | cnt++; 183 | if (cnt == thre) 184 | { 185 | Rcpp::Rcout << "\n"; 186 | thre *= 2; 187 | cnt = 0; 188 | } 189 | } 190 | Rcpp::Rcout << "\n"; 191 | } 192 | -------------------------------------------------------------------------------- /tests/testthat/test_prox_unordered_fusion.R: -------------------------------------------------------------------------------- 1 | context("Unordered Fusion Lasso Tests") 2 | 3 | # Special case 1: 4 | # Large lambda: lambdas in each group are 5 | # the means of everything in the group 6 | test_that("Find means of everything when lambda is large enough and the graph is fully connected", { 7 | set.seed(43) 8 | rep <- 10 9 | large.lambda <- 10000 10 | for (p in c(5, 30, 40, 100)) { 11 | y <- runif(p) 12 | 13 | # A fully connected graph with random weights 14 | w <- matrix(rep(0, p * p), p, byrow = T) 15 | for (i in 1:p - 1) { 16 | for (j in (i + 1):p) { 17 | w[i, j] <- runif(1) + 1 18 | } 19 | } 20 | 21 | for (i in 1:rep) { 22 | res.AMA <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = FALSE) 23 | res.AMA.acc <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = TRUE) 24 | res.ADMM <- test_prox_fusion(y, large.lambda, w, ADMM = TRUE, acc = FALSE) 25 | for (j in c( 26 | res.AMA, 27 | res.AMA.acc, 28 | res.ADMM 29 | )) { 30 | expect_equal(j, mean(y)) 31 | } 32 | } 33 | } 34 | }) 35 | 36 | test_that("Find means of connected components when lambda is large enough", { 37 | set.seed(33) 38 | rep <- 10 39 | large.lambda <- 1000 40 | for (p in c(9, 99)) { 41 | 42 | # A weight matrix of 3 connected components 43 | w <- matrix(rep(0, p * p), p, byrow = T) 44 | num.comp.nodes <- p / 3 # the number of nodes in each component 45 | for (i in seq(1, p, num.comp.nodes)) { 46 | w[i, (i + 1):(i + num.comp.nodes - 1)] <- 1 + runif(num.comp.nodes - 1) 47 | } 48 | 49 | for (j in 1:rep) { 50 | y <- 10 * runif(p) 51 | res.AMA.unacc <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = TRUE) 52 | res.AMA.acc <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = TRUE) 53 | res.ADMM <- test_prox_fusion(y, large.lambda, w, ADMM = TRUE, acc = FALSE) 54 | for (res in list( 55 | res.AMA.unacc, 56 | res.AMA.acc, 57 | res.ADMM 58 | )) { 59 | for (i in 1:p) { 60 | start <- ((i - 1) %/% num.comp.nodes) * num.comp.nodes + 1 61 | end <- start + num.comp.nodes - 1 62 | expect_lte(abs(res[i] - mean(y[start:end])), 1e-6) 63 | } 64 | } 65 | } 66 | } 67 | }) 68 | 69 | # Special case 2: 70 | # For every lambda: when only w_ij = 1 (j = i+1) 71 | # it becomes ordered fused lasso 72 | test_that("Ordered fused lasso when w_ij = 1 all j = i+1", { 73 | set.seed(44) 74 | rep <- 20 75 | for (p in c(3, 20, 100)) { 76 | 77 | # A chained graph 78 | w <- matrix(rep(0, p * p), p, byrow = T) 79 | for (i in 1:(p - 1)) { 80 | w[i, i + 1] <- 1 81 | } 82 | 83 | for (i in 1:rep) { 84 | y <- 10 * runif(p) 85 | err.AMA.unacc <- norm(test_prox_fusedlassodp(y, 1) - test_prox_fusion(y, 1, w, ADMM = FALSE, acc = TRUE)) 86 | err.AMA.acc <- norm(test_prox_fusedlassodp(y, 1) - test_prox_fusion(y, 1, w, ADMM = FALSE, acc = TRUE)) 87 | err.ADMM <- norm(test_prox_fusedlassodp(y, 1) - test_prox_fusion(y, 1, w, ADMM = TRUE, acc = FALSE)) 88 | for (err in c( 89 | err.AMA.unacc, 90 | err.AMA.acc, 91 | err.ADMM 92 | )) { 93 | expect_lte(err, 1e-4) 94 | } 95 | } 96 | } 97 | }) 98 | 99 | # Special case 3: 100 | # For evry lambda: when all i,j w_ij = 1 101 | # the solution path contains no split. 102 | 103 | # Find the weight vector required by the 104 | # `cvxclustr` package 105 | mat_to_vec <- function(my.w, p) { 106 | cnt <- 1 107 | cvx.w <- vector(mode = "numeric", length = p * (p - 1) / 2) 108 | for (jj in 1:(p - 1)) { 109 | for (ii in (jj + 1):p) { 110 | cvx.w[cnt] <- my.w[jj, ii] 111 | cnt <- cnt + 1 112 | } 113 | } 114 | return(cvx.w) 115 | } 116 | 117 | test_that("Unweighted and fully connected graph, i.e., w_ij = 1 for all i, j", { 118 | if (requireNamespace("cvxclustr")) { 119 | set.seed(33) 120 | rep <- 20 121 | 122 | for (p in c(30, 100)) { 123 | 124 | # A weight matrix where w_ij = 1, all i, j 125 | w <- matrix(rep(1, p * p), p, byrow = T) 126 | for (i in 1:(p - 1)) { 127 | for (j in (i + 1):p) { 128 | w[i, j] <- runif(1) + 1 129 | } 130 | } 131 | 132 | for (i in 1:rep) { 133 | y <- 10 * runif(p) 134 | y <- t(matrix(y)) 135 | 136 | # The cvxclustr package stores weights as a vector. 137 | # For Gaussian kernel, wij = exp(-phi ||X[,i]-X[,j]||^2) 138 | # So phi = 0 makes a fully connected and unweighted graph 139 | for (lambda in seq(0, 1, 0.13)) { 140 | cvx.result <- cvxclustr::cvxclust(y, mat_to_vec(w, p), lambda, method = "admm", tol = 1e-10)$U[[1]] 141 | 142 | admm <- t(matrix(test_prox_fusion(y, lambda, w, ADMM = TRUE, acc = FALSE))) 143 | ama <- t(matrix(test_prox_fusion(y, lambda, w, ADMM = FALSE, acc = FALSE))) 144 | ama.acc <- t(matrix(test_prox_fusion(y, lambda, w, ADMM = FALSE, acc = TRUE))) 145 | } 146 | 147 | err.AMA.unacc <- norm(cvx.result - ama) 148 | err.AMA.acc <- norm(cvx.result - ama.acc) 149 | err.ADMM <- norm(cvx.result - admm) 150 | for (err in c( 151 | err.AMA.unacc, 152 | err.AMA.acc, 153 | err.ADMM 154 | )) { 155 | expect_lte(err, 1e-6) 156 | } 157 | } 158 | } 159 | } 160 | }) 161 | -------------------------------------------------------------------------------- /docs/reference/MoMA.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | MoMA: Modern Multivariate Analysis in R — MoMA • MoMA 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 48 | 49 | 50 | 51 | 52 | 53 |
    54 |
    55 | 110 | 111 | 112 |
    113 | 114 |
    115 |
    116 |
    117 |

    MoMA: Modern Multivariate Analysis in R

    118 | Source: R/moma-package.R 119 | 120 |
    121 | 122 |
    123 | 124 |

    TODO

    125 | 126 |
    127 | 128 | 129 |

    Details

    130 | 131 |

    See the package vignettes for details of the algorithm, as well as 132 | comparisons to existing methods.

    133 | 134 | 135 |
    136 | 144 |
    145 | 146 |
    147 |
    148 |

    Developed by Michael Weylandt, Genevera Allen, Luofeng Liao.

    149 |
    150 | 151 |
    152 |

    Site built with pkgdown 1.3.0.

    153 |
    154 |
    155 |
    156 | 157 | 158 | 159 | 160 | 161 | 162 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | cpp_moma_multi_rank <- function(X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, rank = 1L) { 5 | .Call('_MoMA_cpp_moma_multi_rank', PACKAGE = 'MoMA', X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, rank) 6 | } 7 | 8 | cpp_moma_grid_search <- function(X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, rank = 1L) { 9 | .Call('_MoMA_cpp_moma_grid_search', PACKAGE = 'MoMA', X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, rank) 10 | } 11 | 12 | cpp_moma_criterion_search <- function(X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, rank = 1L) { 13 | .Call('_MoMA_cpp_moma_criterion_search', PACKAGE = 'MoMA', X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, rank) 14 | } 15 | 16 | cpp_multirank_BIC_grid_search <- function(X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, deflation_scheme = 1L, select_scheme_alpha_u = 0L, select_scheme_alpha_v = 0L, select_scheme_lambda_u = 0L, select_scheme_lambda_v = 0L, max_bic_iter = 5L, rank = 1L) { 17 | .Call('_MoMA_cpp_multirank_BIC_grid_search', PACKAGE = 'MoMA', X, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, deflation_scheme, select_scheme_alpha_u, select_scheme_alpha_v, select_scheme_lambda_u, select_scheme_lambda_v, max_bic_iter, rank) 18 | } 19 | 20 | cca <- function(X, Y, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, deflation_scheme, select_scheme_alpha_u = 0L, select_scheme_alpha_v = 0L, select_scheme_lambda_u = 0L, select_scheme_lambda_v = 0L, max_bic_iter = 5L, rank = 1L) { 21 | .Call('_MoMA_cca', PACKAGE = 'MoMA', X, Y, alpha_u, alpha_v, Omega_u, Omega_v, lambda_u, lambda_v, prox_arg_list_u, prox_arg_list_v, EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver, deflation_scheme, select_scheme_alpha_u, select_scheme_alpha_v, select_scheme_lambda_u, select_scheme_lambda_v, max_bic_iter, rank) 22 | } 23 | 24 | moma_set_logger_level_cpp <- function(level) { 25 | invisible(.Call('_MoMA_moma_set_logger_level_cpp', PACKAGE = 'MoMA', level)) 26 | } 27 | 28 | moma_get_logger_level_cpp <- function() { 29 | .Call('_MoMA_moma_get_logger_level_cpp', PACKAGE = 'MoMA') 30 | } 31 | 32 | moma_log_cpp <- function(level, x) { 33 | invisible(.Call('_MoMA_moma_log_cpp', PACKAGE = 'MoMA', level, x)) 34 | } 35 | 36 | l1tf_diff_mat <- function(m, k) { 37 | .Call('_MoMA_l1tf_diff_mat', PACKAGE = 'MoMA', m, k) 38 | } 39 | 40 | test_prox_lasso <- function(x, l) { 41 | .Call('_MoMA_test_prox_lasso', PACKAGE = 'MoMA', x, l) 42 | } 43 | 44 | test_prox_nnlasso <- function(x, l) { 45 | .Call('_MoMA_test_prox_nnlasso', PACKAGE = 'MoMA', x, l) 46 | } 47 | 48 | test_prox_scad <- function(x, l, gamma = 3.7) { 49 | .Call('_MoMA_test_prox_scad', PACKAGE = 'MoMA', x, l, gamma) 50 | } 51 | 52 | test_prox_scadvec <- function(x, l, gamma = 3.7) { 53 | .Call('_MoMA_test_prox_scadvec', PACKAGE = 'MoMA', x, l, gamma) 54 | } 55 | 56 | test_prox_nnscad <- function(x, l, gamma = 3.7) { 57 | .Call('_MoMA_test_prox_nnscad', PACKAGE = 'MoMA', x, l, gamma) 58 | } 59 | 60 | test_prox_mcp <- function(x, l, gamma = 4) { 61 | .Call('_MoMA_test_prox_mcp', PACKAGE = 'MoMA', x, l, gamma) 62 | } 63 | 64 | test_prox_mcpvec <- function(x, l, gamma = 4) { 65 | .Call('_MoMA_test_prox_mcpvec', PACKAGE = 'MoMA', x, l, gamma) 66 | } 67 | 68 | test_prox_nnmcp <- function(x, l, gamma = 4) { 69 | .Call('_MoMA_test_prox_nnmcp', PACKAGE = 'MoMA', x, l, gamma) 70 | } 71 | 72 | test_prox_grplasso <- function(x, g, l) { 73 | .Call('_MoMA_test_prox_grplasso', PACKAGE = 'MoMA', x, g, l) 74 | } 75 | 76 | test_prox_nngrplasso <- function(x, g, l) { 77 | .Call('_MoMA_test_prox_nngrplasso', PACKAGE = 'MoMA', x, g, l) 78 | } 79 | 80 | test_prox_fusedlassopath <- function(x, l) { 81 | .Call('_MoMA_test_prox_fusedlassopath', PACKAGE = 'MoMA', x, l) 82 | } 83 | 84 | test_prox_fusedlassodp <- function(x, l) { 85 | .Call('_MoMA_test_prox_fusedlassodp', PACKAGE = 'MoMA', x, l) 86 | } 87 | 88 | test_prox_spfusedlasso <- function(x, l, lambda2) { 89 | .Call('_MoMA_test_prox_spfusedlasso', PACKAGE = 'MoMA', x, l, lambda2) 90 | } 91 | 92 | test_prox_fusion <- function(x, l, w, ADMM, acc, prox_eps = 1e-10) { 93 | .Call('_MoMA_test_prox_fusion', PACKAGE = 'MoMA', x, l, w, ADMM, acc, prox_eps) 94 | } 95 | 96 | test_prox_l1gf <- function(x, l, k = 1L) { 97 | .Call('_MoMA_test_prox_l1gf', PACKAGE = 'MoMA', x, l, k) 98 | } 99 | 100 | test_prox_slope <- function(x, l) { 101 | .Call('_MoMA_test_prox_slope', PACKAGE = 'MoMA', x, l) 102 | } 103 | 104 | test_df_orderedfusion <- function(x) { 105 | .Call('_MoMA_test_df_orderedfusion', PACKAGE = 'MoMA', x) 106 | } 107 | 108 | test_df_spfusedlasso <- function(x) { 109 | .Call('_MoMA_test_df_spfusedlasso', PACKAGE = 'MoMA', x) 110 | } 111 | 112 | test_df_l1gf <- function(x, k = 1L) { 113 | .Call('_MoMA_test_df_l1gf', PACKAGE = 'MoMA', x, k) 114 | } 115 | 116 | test_df_grplasso <- function(x, g) { 117 | .Call('_MoMA_test_df_grplasso', PACKAGE = 'MoMA', x, g) 118 | } 119 | 120 | test_BIC <- function(y, y_est, algorithm_string, i_alpha, i_Omega, i_lambda, prox_arg_list, dim, i_EPS = 1e-6, i_MAX_ITER = 1e+3L) { 121 | .Call('_MoMA_test_BIC', PACKAGE = 'MoMA', y, y_est, algorithm_string, i_alpha, i_Omega, i_lambda, prox_arg_list, dim, i_EPS, i_MAX_ITER) 122 | } 123 | 124 | -------------------------------------------------------------------------------- /docs/reference/moma_session_info.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Session Info used for Bug Reporting — moma_session_info • MoMA 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 49 | 50 | 51 | 52 | 53 | 54 |
    55 |
    56 | 111 | 112 | 113 |
    114 | 115 |
    116 |
    117 |
    118 |

    Session Info used for Bug Reporting

    119 | Source: R/internals.R 120 | 121 |
    122 | 123 |
    124 | 125 |

    A helper function which prints information useful in 126 | bug reports.

    127 | 128 |
    129 | 130 | 
    moma_session_info()
    131 | 132 |

    Value

    133 | 134 |

    None. Called for side-effects (printed to the screen) 135 | only.

    136 | 137 | 138 |
    139 | 147 |
    148 | 149 | 158 |
    159 | 160 | 161 | 162 | 163 | 164 | 165 | --------------------------------------------------------------------------------