From b961ed23669fa408866563e31159298b678b9ffc Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Tue, 18 Jun 2019 17:07:30 +0800 Subject: [PATCH 1/7] More tests for moma_svd --- R/moma_svd.R | 28 ++++++++++++++------ tests/testthat/test_arguments.R | 45 ++++++++++++++++++++++++++++++++- 2 files changed, 64 insertions(+), 9 deletions(-) diff --git a/R/moma_svd.R b/R/moma_svd.R index 8439258b..07aca256 100644 --- a/R/moma_svd.R +++ b/R/moma_svd.R @@ -68,11 +68,23 @@ moma_svd <- function( k = 1, # number of pairs of singular vecters select = c("gridsearch","nestedBIC")){ + if(!inherits(alpha_u,c("numeric","integer")) || + !inherits(alpha_v,c("numeric","integer")) || + !inherits(lambda_u,c("numeric","integer")) || + !inherits(lambda_v,c("numeric","integer"))){ + moma_error(paste0("All penalty levels (", + sQuote("lambda_u"),", ", + sQuote("lambda_v"),", ", + sQuote("alpha_u"),", ", + sQuote("alpha_v"), + ") must be numeric.")) + } + select <- match.arg(select) all_para <- c(alpha_u,alpha_v,lambda_u,lambda_v) # verify all alphas and lambdas are positive numbers - if(sum(all_para < 0 || !is.finite(all_para)) > 0){ + if(sum(all_para < 0) > 0 || sum(!is.finite(all_para)) > 0){ moma_error("All penalty levels (", sQuote("lambda_u"),", ", sQuote("lambda_v"),", ", @@ -89,7 +101,7 @@ moma_svd <- function( # update argument lists # GP loop argument - df_arg_list <- list( + algo_settings_list <- list( X = X, lambda_u = lambda_u, lambda_v = lambda_v, @@ -136,8 +148,8 @@ moma_svd <- function( # Pack all argument into a list # First we check the smoothness term argument. - df_arg_list <- c( - df_arg_list, + algo_settings_list <- c( + algo_settings_list, list( Omega_u = check_omega(Omega_u,alpha_u,n), Omega_v = check_omega(Omega_v,alpha_v,p), @@ -146,13 +158,13 @@ moma_svd <- function( if(is_multiple_para){ if(select == "gridsearch"){ - a <- do.call("cpp_sfpca_grid",df_arg_list) + a <- do.call("cpp_sfpca_grid",algo_settings_list) class(a) <- "moma_svd_grid" return(a) } else if(select == "nestedBIC"){ - a <- do.call("cpp_sfpca_nestedBIC",df_arg_list) - class(a) <- "moma_svc_nestedBIC" + a <- do.call("cpp_sfpca_nestedBIC",algo_settings_list) + class(a) <- "moma_svd_nestedBIC" return(a) } else{ @@ -160,6 +172,6 @@ moma_svd <- function( } } else{ - return(do.call("cpp_sfpca",df_arg_list)) + return(do.call("cpp_sfpca",algo_settings_list)) } } diff --git a/tests/testthat/test_arguments.R b/tests/testthat/test_arguments.R index 53427138..7a8be1c8 100644 --- a/tests/testthat/test_arguments.R +++ b/tests/testthat/test_arguments.R @@ -33,7 +33,7 @@ test_that("Test for arguments names", { } }) -test_that("Prompt errors encountering inappropriate arguments", { +test_that("Prompt errors for wrong prox arguments", { old_logger_level <- MoMA::moma_logger_level() MoMA::moma_logger_level("DEBUG") on.exit(MoMA::moma_logger_level(old_logger_level)) @@ -247,3 +247,46 @@ test_that("Data matrix must be complete", { expect_error(moma_svd(X = X), "X must not have NaN, NA, or Inf. (Called from moma_svd)",fixed=TRUE) }) + +test_that("Negative penalty", { + old_logger_level <- MoMA::moma_logger_level() + MoMA::moma_logger_level("DEBUG") + on.exit(MoMA::moma_logger_level(old_logger_level)) + + + # Negative penalty + set.seed(112) + X <- matrix(runif(12),3,4) + expect_error(moma_svd(X = X, lambda_u=c(0,1,2,3,4,-1)), + paste0("All penalty levels (", + sQuote("lambda_u"),", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"),") must be non-negative numeric. "),fixed=TRUE) + + + expect_error(moma_svd(X = X, lambda_v=c(0,1,2,3,4,-1)), + paste0("All penalty levels (", + sQuote("lambda_u"),", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"),") must be non-negative numeric. "),fixed=TRUE) + + + # Prompt error when passing a matrix + expect_error(moma_svd(X = X, lambda_v=matrix(1:12,3)), + paste0("All penalty levels (", + sQuote("lambda_u"),", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"),") must be numeric."),fixed=TRUE) + + + + expect_no_error(moma_svd(X = X, lambda_v=1,lambda_u=1), + paste0("All penalty levels (", + sQuote("lambda_u"),", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"),") must be non-negative numeric."),fixed=TRUE) +}) From 27f33ad141fee5116dba6c8e2fc5ee79e683b136 Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Sun, 23 Jun 2019 12:34:58 +0800 Subject: [PATCH 2/7] add format-checking shell script and travis (failure expected) --- .clang-format | 150 +++++++++++++++++++++++++++++++++++++++ .travis.yml | 13 ++++ script/diff_generator.sh | 44 ++++++++++++ script/format_check.sh | 20 ++++++ 4 files changed, 227 insertions(+) create mode 100644 .clang-format create mode 100644 script/diff_generator.sh create mode 100644 script/format_check.sh diff --git a/.clang-format b/.clang-format new file mode 100644 index 00000000..afa4851f --- /dev/null +++ b/.clang-format @@ -0,0 +1,150 @@ +# Defines the ANGLE style for automatic reformatting. +# https://code.google.com/p/angleproject/wiki/CodingStandard +# See Clang docs: http://clang.llvm.org/docs/ClangFormatStyleOptions.html +Language: Cpp +AccessModifierOffset: -2 +AlignAfterOpenBracket: Align +AlignConsecutiveAssignments: true +AlignConsecutiveDeclarations: false +AlignEscapedNewlines: Left +AlignOperands: true +AlignTrailingComments: true +AllowAllParametersOfDeclarationOnNextLine: false +AllowShortBlocksOnASingleLine: false +AllowShortCaseLabelsOnASingleLine: false +AllowShortFunctionsOnASingleLine: Inline +AllowShortIfStatementsOnASingleLine: false +AllowShortLoopsOnASingleLine: false +AlwaysBreakAfterDefinitionReturnType: None +AlwaysBreakAfterReturnType: None +AlwaysBreakBeforeMultilineStrings: true +AlwaysBreakTemplateDeclarations: Yes +BinPackArguments: true +BinPackParameters: false +BraceWrapping: + AfterClass: true + AfterControlStatement: true + AfterEnum: true + AfterFunction: true + AfterNamespace: true + AfterObjCDeclaration: false + AfterStruct: true + AfterUnion: true + AfterExternBlock: false + BeforeCatch: true + BeforeElse: true + IndentBraces: false + SplitEmptyFunction: false + SplitEmptyRecord: false + SplitEmptyNamespace: false +BreakBeforeBinaryOperators: None +BreakBeforeBraces: Custom +BreakBeforeInheritanceComma: false +BreakInheritanceList: BeforeColon +BreakBeforeTernaryOperators: true +BreakConstructorInitializersBeforeComma: false +BreakConstructorInitializers: BeforeColon +BreakAfterJavaFieldAnnotations: false +BreakStringLiterals: true +ColumnLimit: 100 +CommentPragmas: '^ IWYU pragma:' +CompactNamespaces: false +ConstructorInitializerAllOnOneLineOrOnePerLine: true +ConstructorInitializerIndentWidth: 4 +ContinuationIndentWidth: 4 +Cpp11BracedListStyle: true +DerivePointerAlignment: false +DisableFormat: false +ExperimentalAutoDetectBinPacking: false +FixNamespaceComments: true +ForEachMacros: + - foreach + - Q_FOREACH + - BOOST_FOREACH +IncludeBlocks: Preserve +IncludeCategories: + - Regex: '^' + Priority: 2 + - Regex: '^<.*\.h>' + Priority: 1 + - Regex: '^<.*' + Priority: 2 + - Regex: '.*' + Priority: 3 +IncludeIsMainRegex: '([-_](test|unittest))?$' +IndentCaseLabels: true +IndentPPDirectives: AfterHash +IndentWidth: 4 +IndentWrappedFunctionNames: false +JavaScriptQuotes: Leave +JavaScriptWrapImports: true +KeepEmptyLinesAtTheStartOfBlocks: true +MacroBlockBegin: '' +MacroBlockEnd: '' +MaxEmptyLinesToKeep: 1 +NamespaceIndentation: None +ObjCBinPackProtocolList: Never +ObjCBlockIndentWidth: 2 +ObjCSpaceAfterProperty: false +ObjCSpaceBeforeProtocolList: true +PenaltyBreakAssignment: 2 +PenaltyBreakBeforeFirstCallParameter: 1 +PenaltyBreakComment: 300 +PenaltyBreakFirstLessLess: 120 +PenaltyBreakString: 1000 +PenaltyBreakTemplateDeclaration: 10 +PenaltyExcessCharacter: 1000000 +PenaltyReturnTypeOnItsOwnLine: 200 +PointerAlignment: Right +RawStringFormats: + - Language: Cpp + Delimiters: + - cc + - CC + - cpp + - Cpp + - CPP + - 'c++' + - 'C++' + CanonicalDelimiter: '' + BasedOnStyle: google + - Language: TextProto + Delimiters: + - pb + - PB + - proto + - PROTO + EnclosingFunctions: + - EqualsProto + - EquivToProto + - PARSE_PARTIAL_TEXT_PROTO + - PARSE_TEST_PROTO + - PARSE_TEXT_PROTO + - ParseTextOrDie + - ParseTextProtoOrDie + CanonicalDelimiter: '' + BasedOnStyle: google +ReflowComments: true +SortIncludes: true +SortUsingDeclarations: true +SpaceAfterCStyleCast: false +SpaceAfterTemplateKeyword: true +SpaceBeforeAssignmentOperators: true +SpaceBeforeCpp11BracedList: false +SpaceBeforeCtorInitializerColon: true +SpaceBeforeInheritanceColon: true +SpaceBeforeParens: ControlStatements +SpaceBeforeRangeBasedForLoopColon: true +SpaceInEmptyParentheses: false +SpacesBeforeTrailingComments: 2 +SpacesInAngles: false +SpacesInContainerLiterals: true +SpacesInCStyleCastParentheses: false +SpacesInParentheses: false +SpacesInSquareBrackets: false +Standard: Cpp11 +StatementMacros: + - Q_UNUSED + - QT_REQUIRE_VERSION +TabWidth: 8 +UseTab: Never diff --git a/.travis.yml b/.travis.yml index 9c58ff74..80ed5124 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,6 +11,18 @@ os: # Modified from github.com/jeroen/jsonlite osx_image: xcode9 +addons: + apt: + sources: + # PPA for clang 6.0 + - llvm-toolchain-trusty-6.0 + # PPA for clang-format 8 + - llvm-toolchain-trusty + # PPA for a more recen libstdc++ + - ubuntu-toolchain-r-test + packages: + - clang-format + r_packages: - Rcpp - RcppArmadillo @@ -20,6 +32,7 @@ r_packages: - covr before_install: + - bash script/format_check.sh || travis_terminate 1; - Rscript -e "source('build_steps.R'); before_install()" after_success: diff --git a/script/diff_generator.sh b/script/diff_generator.sh new file mode 100644 index 00000000..6b636bc6 --- /dev/null +++ b/script/diff_generator.sh @@ -0,0 +1,44 @@ +#!/usr/bin/env bash +# Source https://github.com/Project-OSRM/osrm-backend + +set -o errexit +set -o pipefail +set -o nounset + +# Runs the Clang Formatter in parallel on the code base. +# Return codes: +# - 1 there are files to be formatted +# - 0 everything looks fine + +# Get CPU count +OS=$(uname) +NPROC=1 +if [[ $OS = "Linux" ]] ; then + NPROC=$(nproc) +elif [[ ${OS} = "Darwin" ]] ; then + NPROC=$(sysctl -n hw.physicalcpu) +fi + +# macs does not have clang-foramt pre-installed +if [[ $OS = "Darwin" ]] ; then + brew install clang-format +fi + +# Discover clang-format +if type clang-format-9 2> /dev/null ; then + # For linux the command is clang-format-9 + CLANG_FORMAT=clang-format-9 + V=$(clang-format --version) + echo "clang-format is ${V}" +elif type clang-format 2> /dev/null ; then + # For mac the command is clang-format + CLANG_FORMAT=clang-format + V=$(clang-format --version) + echo "clang-format is ${V}" +else + echo "No appropriate clang-format found" + exit 1 +fi + +find ./src -type f -name '*.h' -o -name '*.cpp' \ +| xargs -I{} -P ${NPROC} ${CLANG_FORMAT} -i -style=file {} diff --git a/script/format_check.sh b/script/format_check.sh new file mode 100644 index 00000000..35bb7cec --- /dev/null +++ b/script/format_check.sh @@ -0,0 +1,20 @@ +#!/bin/bash -ue + +set -o errexit +set -o pipefail +set -o nounset + +bash script/diff_generator.sh + +MSG="The following files have been modified:" +SUCC_MSG="Everything looks fine." +dirty=$(git ls-files --modified) + +if [[ $dirty ]]; then + echo $MSG + echo $dirty + exit 1 +else + echo $SUCC_MSG + exit 0 +fi From d54ae4b6de17e7576fd10edaa9554a638e255cc3 Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Tue, 18 Jun 2019 19:58:17 +0800 Subject: [PATCH 3/7] clang style non-invasive (this should fix the failure) --- src/moma.cpp | 361 ++++++++-------- src/moma.h | 105 +++-- src/moma_R_function.cpp | 195 ++++----- src/moma_base.h | 10 +- src/moma_fourdlist.h | 53 ++- src/moma_heap.cpp | 160 +++++--- src/moma_heap.h | 30 +- src/moma_logging.cpp | 30 +- src/moma_logging.h | 178 ++++---- src/moma_prox.cpp | 749 ++++++++++++++++++++-------------- src/moma_prox.h | 173 ++++---- src/moma_prox_flsadp.cpp | 353 +++++++++------- src/moma_prox_flsadp.h | 26 +- src/moma_prox_fusion_util.cpp | 189 +++++---- src/moma_prox_fusion_util.h | 62 ++- src/moma_prox_l1ft.cpp | 263 +++++++----- src/moma_prox_sortedL1.cpp | 41 +- src/moma_prox_sortedL1.h | 6 +- src/moma_solver.cpp | 272 ++++++------ src/moma_solver.h | 131 +++--- src/moma_solver_BICsearch.cpp | 50 +-- src/moma_solver_BICsearch.h | 14 +- src/moma_test_expose.cpp | 134 +++--- 23 files changed, 1998 insertions(+), 1587 deletions(-) diff --git a/src/moma.cpp b/src/moma.cpp index def6d549..beae5c78 100644 --- a/src/moma.cpp +++ b/src/moma.cpp @@ -1,63 +1,66 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- +// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; +// -*- #include "moma.h" -MoMA::MoMA(const arma::mat &i_X, // Pass X_ as a reference to avoid copy - /* - * sparsity - enforced through penalties - */ - double i_lambda_u, // regularization level - double i_lambda_v, - Rcpp::List i_prox_arg_list_u, - Rcpp::List i_prox_arg_list_v, - - /* - * smoothness - enforced through constraints - */ - double i_alpha_u, // Smoothing levels - double i_alpha_v, - const arma::mat &Omega_u, // Smoothing matrices - const arma::mat &Omega_v, - - /* - * Algorithm parameters: - */ - double i_EPS, - long i_MAX_ITER, - double i_EPS_inner, - long i_MAX_ITER_inner, - std::string i_solver): - n(i_X.n_rows), - p(i_X.n_cols), - alpha_u(i_alpha_u), - alpha_v(i_alpha_v), - lambda_u(i_lambda_u), - lambda_v(i_lambda_v), - X(i_X), // make our copy of the data - MAX_ITER(i_MAX_ITER), - EPS(i_EPS), - solver_u( - i_solver, - alpha_u,Omega_u, - lambda_u,i_prox_arg_list_u, - i_EPS_inner,i_MAX_ITER_inner,i_X.n_rows), - solver_v( - i_solver, - alpha_v,Omega_v, - lambda_v,i_prox_arg_list_v, - i_EPS_inner,i_MAX_ITER_inner,i_X.n_cols) - // const reference must be passed to initializer list +MoMA::MoMA(const arma::mat &i_X, // Pass X_ as a reference to avoid copy + /* + * sparsity - enforced through penalties + */ + double i_lambda_u, // regularization level + double i_lambda_v, + Rcpp::List i_prox_arg_list_u, + Rcpp::List i_prox_arg_list_v, + + /* + * smoothness - enforced through constraints + */ + double i_alpha_u, // Smoothing levels + double i_alpha_v, + const arma::mat &Omega_u, // Smoothing matrices + const arma::mat &Omega_v, + + /* + * Algorithm parameters: + */ + double i_EPS, + long i_MAX_ITER, + double i_EPS_inner, + long i_MAX_ITER_inner, + std::string i_solver) + : n(i_X.n_rows), + p(i_X.n_cols), + alpha_u(i_alpha_u), + alpha_v(i_alpha_v), + lambda_u(i_lambda_u), + lambda_v(i_lambda_v), + X(i_X), // make our copy of the data + MAX_ITER(i_MAX_ITER), + EPS(i_EPS), + solver_u(i_solver, + alpha_u, + Omega_u, + lambda_u, + i_prox_arg_list_u, + i_EPS_inner, + i_MAX_ITER_inner, + i_X.n_rows), + solver_v(i_solver, + alpha_v, + Omega_v, + lambda_v, + i_prox_arg_list_v, + i_EPS_inner, + i_MAX_ITER_inner, + i_X.n_cols) +// const reference must be passed to initializer list { - bicsr_u.bind(&solver_u, &PR_solver::bic); bicsr_v.bind(&solver_v, &PR_solver::bic); MoMALogger::info("Initializing MoMA object:") - << " lambda_u " << lambda_u - << " lambda_v " << lambda_v - << " alpha_u " << alpha_u - << " alpha_v " << alpha_v - << " P_u " << Rcpp::as(i_prox_arg_list_u["P"]) - << " P_v " << Rcpp::as(i_prox_arg_list_v["P"]); + << " lambda_u " << lambda_u << " lambda_v " << lambda_v << " alpha_u " << alpha_u + << " alpha_v " << alpha_v << " P_u " << Rcpp::as(i_prox_arg_list_u["P"]) + << " P_v " << Rcpp::as(i_prox_arg_list_v["P"]); // Step 2: Initialize to leading singular vectors // // MoMA is a regularized SVD, which is a non-convex (bi-convex) @@ -65,9 +68,9 @@ MoMA::MoMA(const arma::mat &i_X, // Pass X_ as a reference to avoid copy // avoid local-minima. Initialization at the SVD (global solution // to the non-regularized problem) seems to be a good trade-off: // for problems with little regularization, the MoMA solution will - // lie near the SVD solution; for problems with significant regularization - // the problem becomes more well-behaved and less sensitive to - // initialization + // lie near the SVD solution; for problems with significant + // regularization the problem becomes more well-behaved and less + // sensitive to initialization arma::mat U; arma::vec s; arma::mat V; @@ -76,9 +79,11 @@ MoMA::MoMA(const arma::mat &i_X, // Pass X_ as a reference to avoid copy u = U.col(0); }; -int MoMA::deflate(double d){ +int MoMA::deflate(double d) +{ MoMALogger::warning("Deflating."); - if(d <= 0.0){ + if (d <= 0.0) + { MoMALogger::error("Cannot deflate by non-positive factor."); } X = X - d * u * v.t(); @@ -92,36 +97,38 @@ int MoMA::deflate(double d){ return d; } -void MoMA::solve(){ - tol = 1; +void MoMA::solve() +{ + tol = 1; iter = 0; arma::vec oldu; arma::vec oldv; - while(tol > EPS && iter < MAX_ITER){ + while (tol > EPS && iter < MAX_ITER) + { iter++; oldu = u; oldv = v; - u = solver_u.solve(X*v, u); - v = solver_v.solve(X.t()*u, v); + u = solver_u.solve(X * v, u); + v = solver_v.solve(X.t() * u, v); tol = norm(oldu - u) / norm(oldu) + norm(oldv - v) / norm(oldv); MoMALogger::debug("Outer loop No.") << iter << "--" << tol; } - - MoMALogger::info("--Finish iter: ") << iter << "---" ; + + MoMALogger::info("--Finish iter: ") << iter << "---"; check_cnvrg(); } -Rcpp::List MoMA::select_nestedBIC( - const arma::vec &alpha_u, - const arma::vec &alpha_v, - const arma::vec &lambda_u, - const arma::vec &lambda_v, - int max_bic_iter = 5){ // suggested in the sfpca_nested_bic.m - +Rcpp::List MoMA::select_nestedBIC(const arma::vec &alpha_u, + const arma::vec &alpha_v, + const arma::vec &lambda_u, + const arma::vec &lambda_v, + int max_bic_iter = 5) +{ // suggested in the sfpca_nested_bic.m + MoMALogger::info("Running nested BIC parameter selection."); - tol = 1; + tol = 1; iter = 0; arma::vec oldu; arma::vec oldv; @@ -136,22 +143,27 @@ Rcpp::List MoMA::select_nestedBIC( double opt_lambda_u; double opt_lambda_v; - while(tol > EPS && iter < MAX_ITER && iter < max_bic_iter){ + while (tol > EPS && iter < MAX_ITER && iter < max_bic_iter) + { iter++; - oldu = u; - oldv = v; + oldu = u; + oldv = v; minbic_u = 1e+10; minbic_v = 1e+10; // choose lambda/alpha_u - for(int i = 0; i < alpha_u.n_elem; i++){ - for(int j = 0; j < lambda_u.n_elem; j++){ + for (int i = 0; i < alpha_u.n_elem; i++) + { + for (int j = 0; j < lambda_u.n_elem; j++) + { // Put lambda_u in the inner loop to avoid reconstructing S many times - solver_u.reset(lambda_u(j),alpha_u(i)); - working_u = solver_u.solve(X*v, working_u); - working_bic_u = solver_u.bic(X*v, working_u); - MoMALogger::debug("(now,min,la,al) = (") << working_bic_u << "," << minbic_u << "," << lambda_u(j) << "," << alpha_u(i) << ")"; - if(working_bic_u < minbic_u){ + solver_u.reset(lambda_u(j), alpha_u(i)); + working_u = solver_u.solve(X * v, working_u); + working_bic_u = solver_u.bic(X * v, working_u); + MoMALogger::debug("(now,min,la,al) = (") << working_bic_u << "," << minbic_u << "," + << lambda_u(j) << "," << alpha_u(i) << ")"; + if (working_bic_u < minbic_u) + { minbic_u = working_bic_u; u = working_u; opt_lambda_u = lambda_u(j); @@ -159,18 +171,21 @@ Rcpp::List MoMA::select_nestedBIC( } } } - MoMALogger::message("Search No.") << iter << ", BIC(u) = " << minbic_u << - ", (al,lam) = (" << opt_alpha_u << - ", " << opt_lambda_u << ")."; + MoMALogger::message("Search No.") << iter << ", BIC(u) = " << minbic_u << ", (al,lam) = (" + << opt_alpha_u << ", " << opt_lambda_u << ")."; // choose lambda/alpha_v - for(int i = 0; i < alpha_v.n_elem; i++){ - for(int j = 0; j < lambda_v.n_elem; j++){ + for (int i = 0; i < alpha_v.n_elem; i++) + { + for (int j = 0; j < lambda_v.n_elem; j++) + { // Put lambda_v in the inner loop to avoid reconstructing S many times - solver_v.reset(lambda_v(j),alpha_v(i)); - working_v = solver_v.solve(X.t()*u, working_v); - working_bic_v = solver_v.bic(X.t()*u, working_v); - MoMALogger::debug("(now,min) = (") << working_bic_v << "," << minbic_v << "," << lambda_v(j) << "," << alpha_v(i) << ")"; - if(working_bic_v < minbic_v){ + solver_v.reset(lambda_v(j), alpha_v(i)); + working_v = solver_v.solve(X.t() * u, working_v); + working_bic_v = solver_v.bic(X.t() * u, working_v); + MoMALogger::debug("(now,min) = (") << working_bic_v << "," << minbic_v << "," + << lambda_v(j) << "," << alpha_v(i) << ")"; + if (working_bic_v < minbic_v) + { minbic_v = working_bic_v; v = working_v; opt_lambda_v = lambda_v(j); @@ -178,75 +193,76 @@ Rcpp::List MoMA::select_nestedBIC( } } } - MoMALogger::message("Search No.") << iter << ", BIC(v) = " << minbic_v << - ", (al,lam) = (" << opt_alpha_v << - ", " << opt_lambda_v << ")."; + MoMALogger::message("Search No.") << iter << ", BIC(v) = " << minbic_v << ", (al,lam) = (" + << opt_alpha_v << ", " << opt_lambda_v << ")."; tol = norm(oldu - u) / norm(oldu) + norm(oldv - v) / norm(oldv); MoMALogger::debug("Outer loop No.") << iter << "--" << tol; } - + // A final run on the chosen set of parameters - reset(opt_lambda_u,opt_lambda_v,opt_alpha_u,opt_alpha_v); + reset(opt_lambda_u, opt_lambda_v, opt_alpha_u, opt_alpha_v); solve(); return Rcpp::List::create( - Rcpp::Named("lambda_u") = opt_lambda_u, - Rcpp::Named("lambda_v") = opt_lambda_v, - Rcpp::Named("alpha_u") = opt_alpha_u, - Rcpp::Named("alpha_v") = opt_alpha_v, - Rcpp::Named("u") = u, - Rcpp::Named("v") = v, - Rcpp::Named("d") = arma::as_scalar(u.t() * X * v)); - + Rcpp::Named("lambda_u") = opt_lambda_u, Rcpp::Named("lambda_v") = opt_lambda_v, + Rcpp::Named("alpha_u") = opt_alpha_u, Rcpp::Named("alpha_v") = opt_alpha_v, + Rcpp::Named("u") = u, Rcpp::Named("v") = v, + Rcpp::Named("d") = arma::as_scalar(u.t() * X * v)); } -int MoMA::check_cnvrg(){ - if(iter >= MAX_ITER){ - MoMALogger::warning("No convergence in MoMA!") - << " lambda_u " << lambda_u - << " lambda_v " << lambda_v - << " alpha_u " << alpha_u +int MoMA::check_cnvrg() +{ + if (iter >= MAX_ITER) + { + MoMALogger::warning("No convergence in MoMA!") + << " lambda_u " << lambda_u << " lambda_v " << lambda_v << " alpha_u " << alpha_u << " alpha_v " << alpha_v; } return 0; -} - -int MoMA::reset(double newlambda_u,double newlambda_v, - double newalpha_u,double newalpha_v){ +} - solver_u.reset(newlambda_u,newalpha_u); - solver_v.reset(newlambda_v,newalpha_v); +int MoMA::reset(double newlambda_u, double newlambda_v, double newalpha_u, double newalpha_v) +{ + solver_u.reset(newlambda_u, newalpha_u); + solver_v.reset(newlambda_v, newalpha_v); return 0; } -const arma::vec &set_greedy_grid(const arma::vec &grid, int want_grid){ - if (want_grid == 1){ +const arma::vec &set_greedy_grid(const arma::vec &grid, int want_grid) +{ + if (want_grid == 1) + { return grid; } - else if (want_grid == 0){ + else if (want_grid == 0) + { return MOMA_EMPTY_GRID_OF_LENGTH1; } } -arma::vec set_bic_grid(const arma::vec &grid, int want_bic, int i){ - if(want_bic == 1){ +arma::vec set_bic_grid(const arma::vec &grid, int want_bic, int i) +{ + if (want_bic == 1) + { return grid; } - else if (want_bic == 0){ - return grid(i) * arma::ones (1); + else if (want_bic == 0) + { + return grid(i) * arma::ones(1); } } Rcpp::List MoMA::grid_BIC_mix(const arma::vec &alpha_u, - const arma::vec &alpha_v, - const arma::vec &lambda_u, - const arma::vec &lambda_v, - int selection_criterion_alpha_u, // flags; = 0 means grid, = 01 means BIC search - int selection_criterion_alpha_v, - int selection_criterion_lambda_u, - int selection_criterion_lambda_v, - int max_bic_iter){ - + const arma::vec &alpha_v, + const arma::vec &lambda_u, + const arma::vec &lambda_v, + int selection_criterion_alpha_u, // flags; = 0 means grid, = + // 01 means BIC search + int selection_criterion_alpha_v, + int selection_criterion_lambda_u, + int selection_criterion_lambda_v, + int max_bic_iter) +{ // If alpha_u is selected via grid search, then the variable // grid_au = alpha_u, bic_au_grid = [-1]. // If alpha_u is selected via nested BIC search, @@ -258,24 +274,21 @@ Rcpp::List MoMA::grid_BIC_mix(const arma::vec &alpha_u, // Test that if a grid is set to be BIC-search grid, then // the above code should set grid_xx to the vector [-1] - if((selection_criterion_alpha_u == 1 && (grid_au.n_elem != 1 || grid_au(0) != -1)) - || (selection_criterion_alpha_v == 1 && (grid_av.n_elem != 1 || grid_av(0) != -1)) - || (selection_criterion_lambda_u == 1 && (grid_lu.n_elem != 1 || grid_lu(0) != -1)) - || (selection_criterion_lambda_v == 1 && (grid_lv.n_elem != 1 || grid_lv(0) != -1)) ) + if ((selection_criterion_alpha_u == 1 && (grid_au.n_elem != 1 || grid_au(0) != -1)) || + (selection_criterion_alpha_v == 1 && (grid_av.n_elem != 1 || grid_av(0) != -1)) || + (selection_criterion_lambda_u == 1 && (grid_lu.n_elem != 1 || grid_lu(0) != -1)) || + (selection_criterion_lambda_v == 1 && (grid_lv.n_elem != 1 || grid_lv(0) != -1))) { MoMALogger::error("Wrong grid-search grid!") - << "grid_lu.n_elem=" << grid_lu.n_elem - << ", grid_av.n_elem=" << grid_av.n_elem - << ", grid_lu.n_elem" << grid_lu.n_elem - << ", grid_lv.n_elem" << grid_lv.n_elem; + << "grid_lu.n_elem=" << grid_lu.n_elem << ", grid_av.n_elem=" << grid_av.n_elem + << ", grid_lu.n_elem" << grid_lu.n_elem << ", grid_lv.n_elem" << grid_lv.n_elem; } int n_lambda_u = grid_lu.n_elem; int n_lambda_v = grid_lv.n_elem; - int n_alpha_u = grid_au.n_elem; - int n_alpha_v = grid_av.n_elem; + int n_alpha_u = grid_au.n_elem; + int n_alpha_v = grid_av.n_elem; - RcppFourDList four_d_list(n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v); // nested-BIC search returns a list that @@ -287,56 +300,58 @@ Rcpp::List MoMA::grid_BIC_mix(const arma::vec &alpha_u, arma::vec oldu; arma::vec oldv; - for(int i = 0; i < n_alpha_u; i++){ - for(int j = 0; j < n_lambda_u; j++){ - for(int k = 0; k < n_alpha_v; k++){ - for(int m = 0; m < n_lambda_v; m++){ - + for (int i = 0; i < n_alpha_u; i++) + { + for (int j = 0; j < n_lambda_u; j++) + { + for (int k = 0; k < n_alpha_v; k++) + { + for (int m = 0; m < n_lambda_v; m++) + { arma::vec bic_au_grid = set_bic_grid(alpha_u, selection_criterion_alpha_u, i); arma::vec bic_lu_grid = set_bic_grid(lambda_u, selection_criterion_lambda_u, j); arma::vec bic_av_grid = set_bic_grid(alpha_v, selection_criterion_alpha_v, k); arma::vec bic_lv_grid = set_bic_grid(lambda_v, selection_criterion_lambda_v, m); - if((selection_criterion_alpha_u == 0 && bic_au_grid.n_elem != 1) - || (selection_criterion_alpha_v == 0 && bic_av_grid.n_elem != 1) - || (selection_criterion_lambda_u == 0 && bic_lu_grid.n_elem != 1) - || (selection_criterion_lambda_v == 0 && bic_lv_grid.n_elem != 1) ) + if ((selection_criterion_alpha_u == 0 && bic_au_grid.n_elem != 1) || + (selection_criterion_alpha_v == 0 && bic_av_grid.n_elem != 1) || + (selection_criterion_lambda_u == 0 && bic_lu_grid.n_elem != 1) || + (selection_criterion_lambda_v == 0 && bic_lv_grid.n_elem != 1)) { - MoMALogger::error("Wrong BIC search grid!"); + MoMALogger::error("Wrong BIC search grid!"); } - tol = 1; + tol = 1; iter = 0; - // We conduct 2 BIC searches over 2D grids here instead - // of 4 searches over 1D grids. It's consistent with + // We conduct 2 BIC searches over 2D grids here instead + // of 4 searches over 1D grids. It's consistent with // Genevera's code - while(tol > EPS && iter < MAX_ITER && iter < max_bic_iter){ + while (tol > EPS && iter < MAX_ITER && iter < max_bic_iter) + { iter++; oldu = u; oldv = v; // choose lambda/alpha_u MoMALogger::debug("Start u search."); - u_result = bicsr_u.search(X*v, u, bic_au_grid, bic_lu_grid); - u = Rcpp::as(u_result["vector"]); + u_result = bicsr_u.search(X * v, u, bic_au_grid, bic_lu_grid); + u = Rcpp::as(u_result["vector"]); MoMALogger::debug("Start v search."); - v_result = bicsr_v.search(X.t()*u, v, bic_av_grid, bic_lv_grid); - v = Rcpp::as(v_result["vector"]); + v_result = bicsr_v.search(X.t() * u, v, bic_av_grid, bic_lv_grid); + v = Rcpp::as(v_result["vector"]); tol = norm(oldu - u) / norm(oldu) + norm(oldv - v) / norm(oldv); - MoMALogger::message("Finish BIC search outer loop. (iter, tol) = (") - << iter << "," << tol << "), " - << "(bic_u, bic_v) = (" - << (double)u_result["bic"] << "," - << (double)v_result["bic"] << ")"; + MoMALogger::message("Finish BIC search outer loop. (iter, tol) = (") + << iter << "," << tol << "), " + << "(bic_u, bic_v) = (" << (double)u_result["bic"] << "," + << (double)v_result["bic"] << ")"; } - - four_d_list.insert(Rcpp::List::create( - Rcpp::Named("u") = u_result, - Rcpp::Named("v") = v_result), i, j, k, m); - + + four_d_list.insert(Rcpp::List::create(Rcpp::Named("u") = u_result, + Rcpp::Named("v") = v_result), + i, j, k, m); } } } diff --git a/src/moma.h b/src/moma.h index 88d8dc17..32cc1dc1 100644 --- a/src/moma.h +++ b/src/moma.h @@ -1,4 +1,5 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- +// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; +// -*- #ifndef MOMA_H #define MOMA_H 1 // Global #includes and #defines @@ -22,25 +23,23 @@ void moma_set_logger_level_cpp(int); int moma_get_logger_level_cpp(); void moma_log_cpp(int, Rcpp::StringVector); -class MoMA{ - -private: +class MoMA +{ + private: /* matrix size */ - int n; // rows - int p; // columns + int n; // rows + int p; // columns double alpha_u; double alpha_v; double lambda_u; double lambda_v; -public: - + public: // Receiver a grid of parameters // and perform greedy BIC search BIC_searcher bicsr_u; BIC_searcher bicsr_v; - // Our own copy of the data matrix // Modified when finding rank-k svd arma::mat X; @@ -56,49 +55,48 @@ class MoMA{ PR_solver solver_u; PR_solver solver_v; - + // Parse user input into a MoMA object which defines the problem and algorithm // used to solve it. // // TODO: Decouple problem defintion and algorithmic choices // - MoMA(const arma::mat &X_, // Pass X_ as a reference to avoid copy - /* - * sparsity - enforced through penalties - */ - double i_lambda_u, // regularization level - double i_lambda_v, - Rcpp::List i_prox_arg_list_u, - Rcpp::List i_prox_arg_list_v, - - /* - * smoothness - enforced through constraints - */ - double i_alpha_u, // Smoothing levels - double i_alpha_v, - const arma::mat &Omega_u, // Smoothing matrices - const arma::mat &Omega_v, - - /* - * Algorithm parameters: - */ - double i_EPS, - long i_MAX_ITER, - double i_EPS_inner, - long i_MAX_ITER_inner, - std::string i_solver); + MoMA(const arma::mat &X_, // Pass X_ as a reference to avoid copy + /* + * sparsity - enforced through penalties + */ + double i_lambda_u, // regularization level + double i_lambda_v, + Rcpp::List i_prox_arg_list_u, + Rcpp::List i_prox_arg_list_v, + + /* + * smoothness - enforced through constraints + */ + double i_alpha_u, // Smoothing levels + double i_alpha_v, + const arma::mat &Omega_u, // Smoothing matrices + const arma::mat &Omega_v, + + /* + * Algorithm parameters: + */ + double i_EPS, + long i_MAX_ITER, + double i_EPS_inner, + long i_MAX_ITER_inner, + std::string i_solver); // solve sfpca by iteratively solving // penalized regressions void solve(); // do parameter selection using nested BIC - Rcpp::List select_nestedBIC( - const arma::vec &alpha_u, - const arma::vec &alpha_v, - const arma::vec &lambda_u, - const arma::vec &lambda_v, - int max_bic_iter); + Rcpp::List select_nestedBIC(const arma::vec &alpha_u, + const arma::vec &alpha_v, + const arma::vec &lambda_u, + const arma::vec &lambda_v, + int max_bic_iter); // deflate u * v.t() out of X by the amount of d int deflate(double d); @@ -107,19 +105,18 @@ class MoMA{ int check_cnvrg(); // change penalty level - int reset(double newlambda_u,double newlambda_v, - double newalpha_u,double newalpha_v); - - Rcpp::List grid_BIC_mix( - const arma::vec &alpha_u, - const arma::vec &alpha_v, - const arma::vec &lambda_u, - const arma::vec &lambda_v, - int selection_criterion_alpha_u, // flags; = 0 means grid, = 01 means BIC search - int selection_criterion_alpha_v, - int selection_criterion_lambda_u, - int selection_criterion_lambda_v, - int max_bic_iter=5); + int reset(double newlambda_u, double newlambda_v, double newalpha_u, double newalpha_v); + + Rcpp::List grid_BIC_mix(const arma::vec &alpha_u, + const arma::vec &alpha_v, + const arma::vec &lambda_u, + const arma::vec &lambda_v, + int selection_criterion_alpha_u, // flags; = 0 means grid, = 01 + // means BIC search + int selection_criterion_alpha_v, + int selection_criterion_lambda_u, + int selection_criterion_lambda_v, + int max_bic_iter = 5); }; #endif diff --git a/src/moma_R_function.cpp b/src/moma_R_function.cpp index bfbed192..51805412 100644 --- a/src/moma_R_function.cpp +++ b/src/moma_R_function.cpp @@ -4,10 +4,10 @@ // [[Rcpp::export]] Rcpp::List cpp_sfpca( - const arma::mat &X, // We should not change any variable in R, so const ref + const arma::mat &X, // We should not change any variable in R, so const ref const arma::vec &alpha_u, const arma::vec &alpha_v, - const arma::mat &Omega_u, // Default values for these matrices should be set in R + const arma::mat &Omega_u, // Default values for these matrices should be set in R const arma::mat &Omega_v, const arma::vec &lambda_u, const arma::vec &lambda_v, @@ -18,70 +18,60 @@ Rcpp::List cpp_sfpca( double EPS_inner, long MAX_ITER_inner, std::string solver, - int k = 1){ - + int k = 1) +{ // WARNING: arguments should be listed // in the exact order of MoMA constructor MoMA problem(X, - /* sparsity */ - lambda_u(0), - lambda_v(0), - prox_arg_list_u, - prox_arg_list_v, - /* smoothness */ - alpha_u(0), - alpha_v(0), - Omega_u, - Omega_v, - /* algorithm parameters */ - EPS, - MAX_ITER, - EPS_inner, - MAX_ITER_inner, - solver); + /* sparsity */ + lambda_u(0), lambda_v(0), prox_arg_list_u, prox_arg_list_v, + /* smoothness */ + alpha_u(0), alpha_v(0), Omega_u, Omega_v, + /* algorithm parameters */ + EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver); int n_lambda_u = lambda_u.n_elem; int n_lambda_v = lambda_v.n_elem; - int n_alpha_u = alpha_u.n_elem; - int n_alpha_v = alpha_v.n_elem; + int n_alpha_u = alpha_u.n_elem; + int n_alpha_v = alpha_v.n_elem; - int n_more_than_one = int(n_lambda_v > 1) + int(n_lambda_u > 1) + int(n_alpha_u > 1) + int(n_alpha_v > 1); - if(n_more_than_one > 0){ + int n_more_than_one = + int(n_lambda_v > 1) + int(n_lambda_u > 1) + int(n_alpha_u > 1) + int(n_alpha_v > 1); + if (n_more_than_one > 0) + { MoMALogger::error("We don't allow a range of parameters in finding a rank-k svd."); } // store results - arma::mat U(X.n_rows,k); - arma::mat V(X.n_cols,k); + arma::mat U(X.n_rows, k); + arma::mat V(X.n_cols, k); arma::vec d(k); // find k PCs - for(int i = 0; i < k; i++){ + for (int i = 0; i < k; i++) + { problem.solve(); U.col(i) = problem.u; V.col(i) = problem.v; - d(i) = arma::as_scalar(problem.u.t() * problem.X * problem.v); + d(i) = arma::as_scalar(problem.u.t() * problem.X * problem.v); // deflate X - if(i < k-1){ + if (i < k - 1) + { problem.deflate(d(i)); } } - return Rcpp::List::create( - Rcpp::Named("lambda_u") = lambda_u, - Rcpp::Named("lambda_v") = lambda_v, - Rcpp::Named("alpha_u") = alpha_u, - Rcpp::Named("alpha_v") = alpha_v, - Rcpp::Named("u") = U, - Rcpp::Named("v") = V, - Rcpp::Named("d") = d); + return Rcpp::List::create(Rcpp::Named("lambda_u") = lambda_u, + Rcpp::Named("lambda_v") = lambda_v, Rcpp::Named("alpha_u") = alpha_u, + Rcpp::Named("alpha_v") = alpha_v, Rcpp::Named("u") = U, + Rcpp::Named("v") = V, Rcpp::Named("d") = d); } // This function solves a squence of lambda's and alpha's // [[Rcpp::export]] Rcpp::List cpp_sfpca_grid( - const arma::mat &X, // We should not change any variable in R, so const ref + const arma::mat &X, // We should not change any variable in R, so const ref const arma::vec &alpha_u, const arma::vec &alpha_v, - const arma::mat &Omega_u, // Default values for these matrices should be set in R + const arma::mat &Omega_u, // Default values for these matrices should be set in R const arma::mat &Omega_v, const arma::vec &lambda_u, const arma::vec &lambda_v, @@ -92,20 +82,23 @@ Rcpp::List cpp_sfpca_grid( double EPS_inner, long MAX_ITER_inner, std::string solver, - int k = 1){ - + int k = 1) +{ // We only allow changing two parameters int n_lambda_u = lambda_u.n_elem; int n_lambda_v = lambda_v.n_elem; - int n_alpha_u = alpha_u.n_elem; - int n_alpha_v = alpha_v.n_elem; + int n_alpha_u = alpha_u.n_elem; + int n_alpha_v = alpha_v.n_elem; - int n_more_than_one = int(n_lambda_v > 1) + int(n_lambda_u > 1) + int(n_alpha_u > 1) + int(n_alpha_v > 1); - if(n_more_than_one > 2){ + int n_more_than_one = + int(n_lambda_v > 1) + int(n_lambda_u > 1) + int(n_alpha_u > 1) + int(n_alpha_v > 1); + if (n_more_than_one > 2) + { MoMALogger::error("We only allow changing two parameters."); } - if(n_lambda_v == 0 || n_lambda_u == 0 || n_alpha_u == 0 || n_alpha_v == 0){ + if (n_lambda_v == 0 || n_lambda_u == 0 || n_alpha_u == 0 || n_alpha_v == 0) + { MoMALogger::error("Please specify all four parameters."); } @@ -114,73 +107,62 @@ Rcpp::List cpp_sfpca_grid( // NOTE: arguments should be listed // in the exact order of MoMA constructor MoMA problem(X, - /* sparsity */ - lambda_u(0), - lambda_v(0), - prox_arg_list_u, - prox_arg_list_v, - /* smoothness */ - alpha_u(0), - alpha_v(0), - Omega_u, - Omega_v, - /* algorithm parameters */ - EPS, - MAX_ITER, - EPS_inner, - MAX_ITER_inner, - solver); + /* sparsity */ + lambda_u(0), lambda_v(0), prox_arg_list_u, prox_arg_list_v, + /* smoothness */ + alpha_u(0), alpha_v(0), Omega_u, Omega_v, + /* algorithm parameters */ + EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver); // store results - arma::mat U(X.n_rows,n_total); - arma::mat V(X.n_cols,n_total); + arma::mat U(X.n_rows, n_total); + arma::mat V(X.n_cols, n_total); arma::vec d(n_total); int problem_id = 0; - for(int i = 0; i < n_lambda_u; i++){ - for(int j = 0; j < n_lambda_v; j++){ - for(int k = 0; k < n_alpha_u; k++){ - for(int m = 0; m < n_alpha_v; m++){ + for (int i = 0; i < n_lambda_u; i++) + { + for (int j = 0; j < n_lambda_v; j++) + { + for (int k = 0; k < n_alpha_u; k++) + { + for (int m = 0; m < n_alpha_v; m++) + { MoMALogger::info("Setting up model:") - << " lambda_u " << lambda_u(i) - << " lambda_v " << lambda_v(j) - << " alpha_u " << alpha_u(k) - << " alpha_v " << alpha_v(m); + << " lambda_u " << lambda_u(i) << " lambda_v " << lambda_v(j) << " alpha_u " + << alpha_u(k) << " alpha_v " << alpha_v(m); - problem.reset(lambda_u(i),lambda_v(j),alpha_u(k),alpha_v(m)); + problem.reset(lambda_u(i), lambda_v(j), alpha_u(k), alpha_v(m)); // `solve` method use the result from last // iteration as starting point problem.solve(); U.col(problem_id) = problem.u; V.col(problem_id) = problem.v; - d(problem_id) = arma::as_scalar(problem.u.t() * problem.X * problem.v); + d(problem_id) = arma::as_scalar(problem.u.t() * problem.X * problem.v); problem_id++; } } } } - if(problem_id != n_total){ + if (problem_id != n_total) + { MoMALogger::error("Internal error: solution not found for all grid points."); } - return Rcpp::List::create( - Rcpp::Named("lambda_u") = lambda_u, - Rcpp::Named("lambda_v") = lambda_v, - Rcpp::Named("alpha_u") = alpha_u, - Rcpp::Named("alpha_v") = alpha_v, - Rcpp::Named("u") = U, - Rcpp::Named("v") = V, - Rcpp::Named("d") = d); + return Rcpp::List::create(Rcpp::Named("lambda_u") = lambda_u, + Rcpp::Named("lambda_v") = lambda_v, Rcpp::Named("alpha_u") = alpha_u, + Rcpp::Named("alpha_v") = alpha_v, Rcpp::Named("u") = U, + Rcpp::Named("v") = V, Rcpp::Named("d") = d); } // This function solves a squence of lambda's and alpha's // [[Rcpp::export]] Rcpp::List cpp_sfpca_nestedBIC( - const arma::mat &X, // We should not change any variable in R, so const ref + const arma::mat &X, // We should not change any variable in R, so const ref const arma::vec &alpha_u, const arma::vec &alpha_v, - const arma::mat &Omega_u, // Default values for these matrices should be set in R + const arma::mat &Omega_u, // Default values for these matrices should be set in R const arma::mat &Omega_v, const arma::vec &lambda_u, const arma::vec &lambda_v, @@ -191,20 +173,23 @@ Rcpp::List cpp_sfpca_nestedBIC( double EPS_inner, long MAX_ITER_inner, std::string solver, - int k = 1){ - + int k = 1) +{ // We only allow changing two parameters int n_lambda_u = lambda_u.n_elem; int n_lambda_v = lambda_v.n_elem; - int n_alpha_u = alpha_u.n_elem; - int n_alpha_v = alpha_v.n_elem; + int n_alpha_u = alpha_u.n_elem; + int n_alpha_v = alpha_v.n_elem; - int n_more_than_one = int(n_lambda_v > 1) + int(n_lambda_u > 1) + int(n_alpha_u > 1) + int(n_alpha_v > 1); - if(n_more_than_one > 2){ + int n_more_than_one = + int(n_lambda_v > 1) + int(n_lambda_u > 1) + int(n_alpha_u > 1) + int(n_alpha_v > 1); + if (n_more_than_one > 2) + { MoMALogger::error("We only allow changing two parameters."); } - if(n_lambda_v == 0 || n_lambda_u == 0 || n_alpha_u == 0 || n_alpha_v == 0){ + if (n_lambda_v == 0 || n_lambda_u == 0 || n_alpha_u == 0 || n_alpha_v == 0) + { MoMALogger::error("Please specify all four parameters."); } @@ -213,22 +198,12 @@ Rcpp::List cpp_sfpca_nestedBIC( // NOTE: arguments should be listed // in the exact order of MoMA constructor MoMA problem(X, - /* sparsity */ - lambda_u(0), - lambda_v(0), - prox_arg_list_u, - prox_arg_list_v, - /* smoothness */ - alpha_u(0), - alpha_v(0), - Omega_u, - Omega_v, - /* algorithm parameters */ - EPS, - MAX_ITER, - EPS_inner, - MAX_ITER_inner, - solver); - - return problem.select_nestedBIC(alpha_u,alpha_v,lambda_u,lambda_v,5); + /* sparsity */ + lambda_u(0), lambda_v(0), prox_arg_list_u, prox_arg_list_v, + /* smoothness */ + alpha_u(0), alpha_v(0), Omega_u, Omega_v, + /* algorithm parameters */ + EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver); + + return problem.select_nestedBIC(alpha_u, alpha_v, lambda_u, lambda_v, 5); } diff --git a/src/moma_base.h b/src/moma_base.h index 90b2e5d6..b6a752ab 100644 --- a/src/moma_base.h +++ b/src/moma_base.h @@ -7,16 +7,16 @@ #ifndef MOMA_BASE_H #define MOMA_BASE_H 1 -#include #include +#include // We only include RcppArmadillo.h which pulls Rcpp.h in for us #include "RcppArmadillo.h" -// For difficult smoothing matrices, we may encounter artificially small eigenvalues: -// we add a small "nugget" here to regularize the computations +// For difficult smoothing matrices, we may encounter artificially small +// eigenvalues: we add a small "nugget" here to regularize the computations #define MOMA_EIGENVALUE_REGULARIZATION 0.01 -static constexpr double MOMA_INFTY = std::numeric_limits::infinity(); -static const arma::vec MOMA_EMPTY_GRID_OF_LENGTH1 = - arma::ones (1); +static constexpr double MOMA_INFTY = std::numeric_limits::infinity(); +static const arma::vec MOMA_EMPTY_GRID_OF_LENGTH1 = -arma::ones(1); #define MOMA_FUSEDLASSODP_BUFFERSIZE 5000 #endif diff --git a/src/moma_fourdlist.h b/src/moma_fourdlist.h index 1480ed8e..1815715f 100644 --- a/src/moma_fourdlist.h +++ b/src/moma_fourdlist.h @@ -1,46 +1,43 @@ -# include "moma.h" +#include "moma.h" -class RcppFourDList{ +class RcppFourDList +{ int n_alpha_u; int n_lambda_u; int n_alpha_v; int n_lambda_v; Rcpp::List flattened_list; -public: - RcppFourDList(int n_alpha_u, int n_lambda_u, int n_alpha_v, int n_lambda_v): - n_alpha_u(n_alpha_u), n_lambda_u(n_lambda_u), n_alpha_v(n_alpha_v), n_lambda_v(n_lambda_v), - flattened_list(n_alpha_u * n_alpha_v * n_lambda_u * n_lambda_v) + public: + RcppFourDList(int n_alpha_u, int n_lambda_u, int n_alpha_v, int n_lambda_v) + : n_alpha_u(n_alpha_u), + n_lambda_u(n_lambda_u), + n_alpha_v(n_alpha_v), + n_lambda_v(n_lambda_v), + flattened_list(n_alpha_u * n_alpha_v * n_lambda_u * n_lambda_v) { - flattened_list.attr("dim") = Rcpp::NumericVector::create( - n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v); - flattened_list.attr("class") = "MoMA_4D_list"; + flattened_list.attr("dim") = + Rcpp::NumericVector::create(n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v); + flattened_list.attr("class") = "MoMA_4D_list"; }; - int insert(Rcpp::List object, int alpha_u_i, int lambda_u_i, int alpha_v_i, int lambda_v_i){ + int insert(Rcpp::List object, int alpha_u_i, int lambda_u_i, int alpha_v_i, int lambda_v_i) + { // insert object in the alpha_u_i-th position along the alpha_u-axis // and so on - if( - alpha_u_i < 0 || alpha_u_i >= n_alpha_u || - lambda_u_i < 0 || lambda_u_i >= n_lambda_u || - alpha_v_i < 0 || alpha_v_i >= n_alpha_v || - lambda_v_i < 0 || lambda_v_i >= n_lambda_v - ){ + if (alpha_u_i < 0 || alpha_u_i >= n_alpha_u || lambda_u_i < 0 || lambda_u_i >= n_lambda_u || + alpha_v_i < 0 || alpha_v_i >= n_alpha_v || lambda_v_i < 0 || lambda_v_i >= n_lambda_v) + { MoMALogger::error("Invalid index is passed to RcppFourDList::insert. ") - << "Dimension is (" << n_alpha_u << ", " - << n_lambda_u << ", " << n_alpha_v << ", " - << n_lambda_v << "), received (" << alpha_u_i << ", " - << lambda_u_i << ", " << alpha_v_i << ", " << lambda_v_i << ")." - ; + << "Dimension is (" << n_alpha_u << ", " << n_lambda_u << ", " << n_alpha_v << ", " + << n_lambda_v << "), received (" << alpha_u_i << ", " << lambda_u_i << ", " + << alpha_v_i << ", " << lambda_v_i << ")."; } - flattened_list(n_lambda_u * n_alpha_v * n_lambda_v * alpha_u_i + - n_alpha_v * n_lambda_v * lambda_u_i + - n_lambda_v * alpha_v_i + - lambda_v_i) = object; + flattened_list(n_lambda_u * n_alpha_v * n_lambda_v * alpha_u_i + + n_alpha_v * n_lambda_v * lambda_u_i + n_lambda_v * alpha_v_i + lambda_v_i) = + object; return 0; } - Rcpp::List get_list(){ - return flattened_list; - } + Rcpp::List get_list() { return flattened_list; } }; diff --git a/src/moma_heap.cpp b/src/moma_heap.cpp index 8628d667..593b8f57 100644 --- a/src/moma_heap.cpp +++ b/src/moma_heap.cpp @@ -1,119 +1,151 @@ #include "moma_heap.h" #include "moma_prox_fusion_util.h" -bool operator > (const HeapNode &left, const HeapNode &right){ +bool operator>(const HeapNode &left, const HeapNode &right) +{ return left.lambda > right.lambda; } -bool gt(const HeapNode &left, const HeapNode &right){ +bool gt(const HeapNode &left, const HeapNode &right) +{ return left > right; } -Heap::Heap(int n){ - heap_storage.resize(n); +Heap::Heap(int n) +{ + heap_storage.resize(n); }; -void Heap::heapify(){ - std::make_heap(heap_storage.begin(),heap_storage.end(),gt); +void Heap::heapify() +{ + std::make_heap(heap_storage.begin(), heap_storage.end(), gt); } // Find the smaller child of an element in a heap. Used in siftdown -int Heap::min_child(int i) { +int Heap::min_child(int i) +{ int cur_size = heap_storage.size(); - int child = i * 2 + 1; - if (child >= cur_size) { - // no children - return NO_CHILD; - } else if (child+1 >= cur_size || !(heap_storage[child] > heap_storage[child+1])){ - // only child or first child is biggest child - return child; - } else { - // second child exists and is smallest child - return child+1; - } + int child = i * 2 + 1; + if (child >= cur_size) + { + // no children + return NO_CHILD; + } + else if (child + 1 >= cur_size || !(heap_storage[child] > heap_storage[child + 1])) + { + // only child or first child is biggest child + return child; + } + else + { + // second child exists and is smallest child + return child + 1; + } } // TODO: extra copy can be avoided in siftdown -void Heap::swap(int i, int j, FusedGroups *fg){ +void Heap::swap(int i, int j, FusedGroups *fg) +{ // // DEBUG INFO MoMALogger::debug("Swapping ") << heap_storage[i].lambda << "and " << heap_storage[j].lambda; (*fg).g[heap_storage[i].id].map_to_heap = j; (*fg).g[heap_storage[j].id].map_to_heap = i; - HeapNode tmp = heap_storage[i]; - heap_storage[i] = heap_storage[j]; - heap_storage[j] = tmp; + HeapNode tmp = heap_storage[i]; + heap_storage[i] = heap_storage[j]; + heap_storage[j] = tmp; } // In a min-heap, if the key (lambda in our case) decreases, sift it up -void Heap::siftup(int i, FusedGroups *fg){ +void Heap::siftup(int i, FusedGroups *fg) +{ int parent = (i - 1) / 2; - while (i != 0 && (heap_storage[parent] > heap_storage[i])) { + while (i != 0 && (heap_storage[parent] > heap_storage[i])) + { Heap::swap(parent, i, fg); - i = parent; + i = parent; parent = (i - 1) / 2; } } // In a min-heap, if the key (lambda in our case) increases, sift it down -void Heap::siftdown(int current_node, FusedGroups *fg){ - int child = min_child(current_node); - while (child != NO_CHILD && (heap_storage[current_node] > heap_storage[child])){ - Heap::swap(child, current_node, fg); +void Heap::siftdown(int current_node, FusedGroups *fg) +{ + int child = min_child(current_node); + while (child != NO_CHILD && (heap_storage[current_node] > heap_storage[child])) + { + Heap::swap(child, current_node, fg); current_node = child; - child = min_child(child); - } + child = min_child(child); + } } -//Change the key of any nodes; -int Heap::change_lambda_by_id(int i, double new_lambda, FusedGroups *fg){ - if(i < 0 || i >= heap_storage.size()){ +// Change the key of any nodes; +int Heap::change_lambda_by_id(int i, double new_lambda, FusedGroups *fg) +{ + if (i < 0 || i >= heap_storage.size()) + { MoMALogger::error("Try to change lambda: no such id in current heap: ") << i; } - double old_lambda = heap_storage[i].lambda; + double old_lambda = heap_storage[i].lambda; heap_storage[i].lambda = new_lambda; - if(old_lambda < new_lambda){ + if (old_lambda < new_lambda) + { // // DEBUG INFO - // MoMALogger::debug("(") << old_lambda << "," << heap[i].id << ")" << "->" << new_lambda << " siftdown"; + // MoMALogger::debug("(") << old_lambda << "," << heap[i].id << ")" << "->" + // << new_lambda << " siftdown"; siftdown(i, fg); } - else{ + else + { // // DEBUG INFO - // MoMALogger::debug("") << old_lambda << "," << heap[i].id << ")" << "->" << new_lambda << " siftup"; + // MoMALogger::debug("") << old_lambda << "," << heap[i].id << ")" << "->" + // << new_lambda << " siftup"; siftup(i, fg); } return i; } -// To delete an element, move it to the tail, pop it out, and then sift down +// To delete an element, move it to the tail, pop it out, and then sift down // the node that replaces it -void Heap::remove(int i, FusedGroups *fg){ - if(i < 0 || i >= heap_storage.size()){ +void Heap::remove(int i, FusedGroups *fg) +{ + if (i < 0 || i >= heap_storage.size()) + { MoMALogger::error("Try to delete: no such id in current heap: ") << i; } double old_lambda = heap_storage[i].lambda; - Heap::swap(i, heap_storage.size()-1, fg); - (*fg).g[heap_storage[heap_storage.size()-1].id].map_to_heap = FusedGroups::NOT_IN_HEAP; + Heap::swap(i, heap_storage.size() - 1, fg); + (*fg).g[heap_storage[heap_storage.size() - 1].id].map_to_heap = FusedGroups::NOT_IN_HEAP; heap_storage.pop_back(); - if(old_lambda < heap_storage[i].lambda){ + if (old_lambda < heap_storage[i].lambda) + { siftdown(i, fg); } - else{ + else + { siftup(i, fg); } return; } // Check if an array is a min heap -bool Heap::is_minheap(){ +bool Heap::is_minheap() +{ int i = 0; - while(2 * i + 1 < heap_storage.size()){ - if(heap_storage[i] > heap_storage[2 * i + 1]){ - MoMALogger::warning("Not a min-heap") << heap_storage[i].lambda << "and"<< heap_storage[2*i+1].lambda; + while (2 * i + 1 < heap_storage.size()) + { + if (heap_storage[i] > heap_storage[2 * i + 1]) + { + MoMALogger::warning("Not a min-heap") + << heap_storage[i].lambda << "and" << heap_storage[2 * i + 1].lambda; return 0; } - if(2 * i + 2 < heap_storage.size()){ - if(heap_storage[i] > heap_storage[2 * i + 2]){ - MoMALogger::warning("Not a min-heap") << heap_storage[i].lambda << "and"<< heap_storage[2*i+2].lambda; + if (2 * i + 2 < heap_storage.size()) + { + if (heap_storage[i] > heap_storage[2 * i + 2]) + { + MoMALogger::warning("Not a min-heap") + << heap_storage[i].lambda << "and" << heap_storage[2 * i + 2].lambda; return 0; } } @@ -122,13 +154,16 @@ bool Heap::is_minheap(){ return 1; } -bool Heap::is_empty(){ +bool Heap::is_empty() +{ return heap_storage.size() == 0; } // Get the currently minimun value without deleting the node -HeapNode Heap::heap_peek_min(){ - if(is_empty()){ +HeapNode Heap::heap_peek_min() +{ + if (is_empty()) + { MoMALogger::error("You are peaking at an empty heap!"); } HeapNode n = heap_storage.front(); @@ -136,14 +171,17 @@ HeapNode Heap::heap_peek_min(){ } // Print the heap -void Heap::heap_print(){ +void Heap::heap_print() +{ MoMALogger::debug("") << "(lambda, id)\n"; - int cnt = 0; + int cnt = 0; int thre = 1; - for (auto i : heap_storage){ + for (auto i : heap_storage) + { Rcpp::Rcout << i.lambda << ", " << i.id + 1 << "\t"; - cnt ++; - if(cnt == thre){ + cnt++; + if (cnt == thre) + { Rcpp::Rcout << "\n"; thre *= 2; cnt = 0; diff --git a/src/moma_heap.h b/src/moma_heap.h index bf363576..51b5e0b8 100644 --- a/src/moma_heap.h +++ b/src/moma_heap.h @@ -3,29 +3,28 @@ #include "moma_base.h" #include "moma_logging.h" - - -class HeapNode{ -public: - HeapNode(int i = -1, double l = -1.0):id(i),lambda(l){}; - HeapNode& operator = (const HeapNode &source){ - id = source.id; +class HeapNode +{ + public: + HeapNode(int i = -1, double l = -1.0) : id(i), lambda(l){}; + HeapNode &operator=(const HeapNode &source) + { + id = source.id; lambda = source.lambda; return *this; } - int id; // value: id-th beta + int id; // value: id-th beta double lambda; // key: for id-th group and its next groupto merge at lambda - void print(){ - MoMALogger::debug("") << "lambda: " << lambda << "id: " << id; - } + void print() { MoMALogger::debug("") << "lambda: " << lambda << "id: " << id; } }; // comparision between heap nodes bool gt(const HeapNode &left, const HeapNode &right); class FusedGroups; -class Heap{ -public: +class Heap +{ + public: Heap(int n = 0); void heap_print(); HeapNode heap_peek_min(); @@ -36,14 +35,15 @@ class Heap{ int change_lambda_by_id(int id, double new_lambda, FusedGroups *fg); bool is_minheap(); -private: + + private: void swap(int i, int j, FusedGroups *fg); void siftup(int i, FusedGroups *fg); void siftdown(int current_node, FusedGroups *fg); int min_child(int i); - // A constant, where the non-existing + // A constant, where the non-existing // child is assumed to be located. // Used only in function `min_child` const int NO_CHILD = -11; diff --git a/src/moma_logging.cpp b/src/moma_logging.cpp index 57adac95..848ea00d 100644 --- a/src/moma_logging.cpp +++ b/src/moma_logging.cpp @@ -1,30 +1,42 @@ #include "moma.h" // [[Rcpp::export]] -void moma_set_logger_level_cpp(int level){ +void moma_set_logger_level_cpp(int level) +{ auto logger_level = static_cast(level); MoMALogger::set_level(logger_level); } // [[Rcpp::export]] -int moma_get_logger_level_cpp(){ +int moma_get_logger_level_cpp() +{ auto logger_level = static_cast(MoMALogger::get_level()); return logger_level; } // [[Rcpp::export]] -void moma_log_cpp(int level, Rcpp::StringVector x){ - auto msg_level = static_cast(level); +void moma_log_cpp(int level, Rcpp::StringVector x) +{ + auto msg_level = static_cast(level); std::string msg = Rcpp::as(x[0]); - if(msg_level >= MoMALoggerLevel::ERRORS){ + if (msg_level >= MoMALoggerLevel::ERRORS) + { MoMALogger::error(msg); - } else if(msg_level >= MoMALoggerLevel::WARNING){ + } + else if (msg_level >= MoMALoggerLevel::WARNING) + { MoMALogger::warning(msg); - } else if(msg_level >= MoMALoggerLevel::MESSAGES){ + } + else if (msg_level >= MoMALoggerLevel::MESSAGES) + { MoMALogger::message(msg); - } else if(msg_level >= MoMALoggerLevel::INFO){ + } + else if (msg_level >= MoMALoggerLevel::INFO) + { MoMALogger::info(msg); - } else if(msg_level >= MoMALoggerLevel::DEBUG){ + } + else if (msg_level >= MoMALoggerLevel::DEBUG) + { MoMALogger::debug(msg); } } diff --git a/src/moma_logging.h b/src/moma_logging.h index 96866f70..f90dc5fb 100644 --- a/src/moma_logging.h +++ b/src/moma_logging.h @@ -10,90 +10,102 @@ // that is displayed by default (corresponding to message() in R.) // // This must be kept consistent with R/logging.R::MoMA_set_logger_level -enum class MoMALoggerLevel { - ERRORS = 40, - WARNING = 30, - MESSAGES = 20, - INFO = 10, - DEBUG = 0 +enum class MoMALoggerLevel +{ + ERRORS = 40, + WARNING = 30, + MESSAGES = 20, + INFO = 10, + DEBUG = 0 }; // See http://gallery.rcpp.org/articles/quiet-stop-and-warning/ -inline void warningNoCall(const std::string& s) { +inline void warningNoCall(const std::string &s) +{ Rf_warningcall(R_NilValue, s.c_str()); }; -inline void NORET stopNoCall(const std::string& s) { +inline void NORET stopNoCall(const std::string &s) +{ throw Rcpp::exception(s.c_str(), false); }; // Logger structure loosely based on https://github.com/PennEcon/RcppLogger -class MoMALoggerMessage { -public: +class MoMALoggerMessage +{ + public: MoMALoggerMessage(const char *header, MoMALoggerLevel msg_level, MoMALoggerLevel logger_level, - std::ostream& logger_ostream){ - - this->msg_level = msg_level; + std::ostream &logger_ostream) + { + this->msg_level = msg_level; this->logger_level = logger_level; - if(msg_level >= logger_level){ + if (msg_level >= logger_level) + { logger_ostream << header << " -- "; - // Test for a reasonable compiler which supports std::put_time and similar... - // If we have a recent _real_ GCC (i.e., GCC >= 5) or clang (>= 4) then we should - // be good... -#if (__clang_major__ < 4) || ((__GNUC__ < 5) && !(__clang__)) + // Test for a reasonable compiler which supports std::put_time and + // similar... If we have a recent _real_ GCC (i.e., GCC >= 5) or clang (>= + // 4) then we should be good... +#if (__clang_major__ < 4) || ((__GNUC__ < 5) && !(__clang__)) #else - auto time_now = std::chrono::system_clock::now(); + auto time_now = std::chrono::system_clock::now(); auto time_now_t = std::chrono::system_clock::to_time_t(time_now); - auto gmt_time = gmtime(&time_now_t); + auto gmt_time = gmtime(&time_now_t); logger_ostream << std::put_time(gmt_time, "%Y-%m-%d %H:%M:%S") << " -- "; #endif } } - ~MoMALoggerMessage() { - if(msg_level >= logger_level){ + ~MoMALoggerMessage() + { + if (msg_level >= logger_level) + { logger_ostream << std::endl; } } - template - MoMALoggerMessage &operator<<(const T &t){ - if(msg_level >= logger_level){ + template + MoMALoggerMessage &operator<<(const T &t) + { + if (msg_level >= logger_level) + { logger_ostream << t; } return *this; } -private: + private: MoMALoggerLevel msg_level; MoMALoggerLevel logger_level; - std::ostream& logger_ostream = Rcpp::Rcout; + std::ostream &logger_ostream = Rcpp::Rcout; }; // Special LoggerMessage for things we want to have // handled via R's condition handling mechanisms -class RHandleMoMALoggerMessage { -public: +class RHandleMoMALoggerMessage +{ + public: RHandleMoMALoggerMessage(const char *header, MoMALoggerLevel msg_level, - MoMALoggerLevel logger_level){ - - this->msg_level = msg_level; + MoMALoggerLevel logger_level) + { + this->msg_level = msg_level; this->logger_level = logger_level; - this->log_msg = new std::stringstream(); + this->log_msg = new std::stringstream(); } - ~RHandleMoMALoggerMessage() { - if(msg_level >= logger_level){ + ~RHandleMoMALoggerMessage() + { + if (msg_level >= logger_level) + { (*log_msg) << std::endl; } - const std::string& log_msg_s = (*log_msg).str(); + const std::string &log_msg_s = (*log_msg).str(); delete log_msg; // Need an extra call to BEGIN_RCPP and VOID_END_RCPP @@ -101,13 +113,19 @@ class RHandleMoMALoggerMessage { // (they seem to interact badly with destructors otherwise) BEGIN_RCPP - if(msg_level >= logger_level){ + if (msg_level >= logger_level) + { // Report to R (else: ignore) - if(msg_level >= MoMALoggerLevel::ERRORS){ + if (msg_level >= MoMALoggerLevel::ERRORS) + { stopNoCall(log_msg_s.c_str()); - } else if(msg_level >= MoMALoggerLevel::WARNING){ + } + else if (msg_level >= MoMALoggerLevel::WARNING) + { warningNoCall(log_msg_s.c_str()); - } else if(msg_level >= MoMALoggerLevel::MESSAGES){ + } + else if (msg_level >= MoMALoggerLevel::MESSAGES) + { Rcpp::Function print_msg("message"); print_msg(log_msg_s, Rcpp::Named("appendLF", false)); } @@ -116,27 +134,31 @@ class RHandleMoMALoggerMessage { VOID_END_RCPP } - template - RHandleMoMALoggerMessage &operator<<(const T &t){ - if(msg_level >= logger_level){ + template + RHandleMoMALoggerMessage &operator<<(const T &t) + { + if (msg_level >= logger_level) + { (*log_msg) << t; } return *this; } - RHandleMoMALoggerMessage(RHandleMoMALoggerMessage&&) = default; - RHandleMoMALoggerMessage& operator=(RHandleMoMALoggerMessage&&) = default; + RHandleMoMALoggerMessage(RHandleMoMALoggerMessage &&) = default; + RHandleMoMALoggerMessage &operator=(RHandleMoMALoggerMessage &&) = default; -private: + private: MoMALoggerLevel msg_level; MoMALoggerLevel logger_level; - std::stringstream* log_msg; + std::stringstream *log_msg; }; // Singleton pattern loosely based on https://stackoverflow.com/a/1008289/967712 -class MoMALogger { -public: - static MoMALogger& getInstance() { +class MoMALogger +{ + public: + static MoMALogger &getInstance() + { // Guaranteed to be destroyed // Instantiated (below) on first use static MoMALogger instance; @@ -152,70 +174,64 @@ class MoMALogger { // be public as it results in better error messages // due to the compilers behavior to check accessibility // before deleted status - MoMALogger(MoMALogger const&) = delete; // Don't Implement - void operator=(MoMALogger const&) = delete; // Don't implement + MoMALogger(MoMALogger const &) = delete; // Don't Implement + void operator=(MoMALogger const &) = delete; // Don't implement - static RHandleMoMALoggerMessage error(const std::string& log_msg) { - RHandleMoMALoggerMessage msg("[ERROR]", - MoMALoggerLevel::ERRORS, - MoMALogger::get_level()); + static RHandleMoMALoggerMessage error(const std::string &log_msg) + { + RHandleMoMALoggerMessage msg("[ERROR]", MoMALoggerLevel::ERRORS, MoMALogger::get_level()); msg << log_msg; return msg; } - static RHandleMoMALoggerMessage warning(const std::string& log_msg) { - RHandleMoMALoggerMessage msg("[WARNING]", - MoMALoggerLevel::WARNING, + static RHandleMoMALoggerMessage warning(const std::string &log_msg) + { + RHandleMoMALoggerMessage msg("[WARNING]", MoMALoggerLevel::WARNING, MoMALogger::get_level()); msg << log_msg; return msg; } - static RHandleMoMALoggerMessage message(const std::string& log_msg) { - RHandleMoMALoggerMessage msg("[MESSAGE]", - MoMALoggerLevel::MESSAGES, + static RHandleMoMALoggerMessage message(const std::string &log_msg) + { + RHandleMoMALoggerMessage msg("[MESSAGE]", MoMALoggerLevel::MESSAGES, MoMALogger::get_level()); msg << log_msg; return msg; } - static MoMALoggerMessage info(const std::string& log_msg) { - MoMALoggerMessage msg("[INFO]", - MoMALoggerLevel::INFO, - MoMALogger::get_level(), + static MoMALoggerMessage info(const std::string &log_msg) + { + MoMALoggerMessage msg("[INFO]", MoMALoggerLevel::INFO, MoMALogger::get_level(), MoMALogger::get_ostream()); msg << log_msg; return msg; } - static MoMALoggerMessage debug(const std::string& log_msg) { - MoMALoggerMessage msg("[DEBUG]", - MoMALoggerLevel::DEBUG, - MoMALogger::get_level(), + static MoMALoggerMessage debug(const std::string &log_msg) + { + MoMALoggerMessage msg("[DEBUG]", MoMALoggerLevel::DEBUG, MoMALogger::get_level(), MoMALogger::get_ostream()); msg << log_msg; return msg; } - static void set_level(MoMALoggerLevel logger_level){ + static void set_level(MoMALoggerLevel logger_level) + { MoMALogger::getInstance().logger_level = logger_level; } - static MoMALoggerLevel get_level(){ - return MoMALogger::getInstance().logger_level; - } + static MoMALoggerLevel get_level() { return MoMALogger::getInstance().logger_level; } - static std::ostream& get_ostream(){ - return MoMALogger::getInstance().logger_ostream; - } + static std::ostream &get_ostream() { return MoMALogger::getInstance().logger_ostream; } -private: + private: MoMALoggerLevel logger_level = MoMALoggerLevel::MESSAGES; - std::ostream& logger_ostream = Rcpp::Rcout; + std::ostream &logger_ostream = Rcpp::Rcout; // Default constructor ==> logger level = MESSAGES, output = Rcpp::Rcout @@ -224,8 +240,8 @@ class MoMALogger { // them if desired. MoMALogger() {} - MoMALogger(MoMALogger&&) = default; - MoMALogger& operator=(MoMALogger&&) = default; + MoMALogger(MoMALogger &&) = default; + MoMALogger &operator=(MoMALogger &&) = default; }; #endif diff --git a/src/moma_prox.cpp b/src/moma_prox.cpp index 51e58b65..45fe7f38 100644 --- a/src/moma_prox.cpp +++ b/src/moma_prox.cpp @@ -1,215 +1,249 @@ #include "moma_prox.h" /* -* Prox base class -*/ -NullProx::NullProx(){ + * Prox base class + */ +NullProx::NullProx() +{ MoMALogger::debug("Initializing null proximal operator object"); } -arma::vec NullProx::operator()(const arma::vec &x, double l){ - return x; // TODO: to be tested, return a reference might cause extra copying. +arma::vec NullProx::operator()(const arma::vec &x, double l) +{ + return x; // TODO: to be tested, return a reference might cause extra + // copying. }; -NullProx::~NullProx() { +NullProx::~NullProx() +{ MoMALogger::debug("Releasing null proximal operator object"); }; -int NullProx::df(const arma::vec &x){ +int NullProx::df(const arma::vec &x) +{ return x.n_elem; } /* -* Lasso -*/ -Lasso::Lasso(){ + * Lasso + */ +Lasso::Lasso() +{ MoMALogger::debug("Initializing Lasso proximal operator object"); } -arma::vec Lasso::operator()(const arma::vec &x, double l){ +arma::vec Lasso::operator()(const arma::vec &x, double l) +{ arma::vec absx = arma::abs(x); return arma::sign(x) % soft_thres_p(absx, l); } -Lasso::~Lasso(){ +Lasso::~Lasso() +{ MoMALogger::debug("Releasing Lasso proximal operator object"); } -int Lasso::df(const arma::vec &x){ +int Lasso::df(const arma::vec &x) +{ return arma::sum(x != 0.0); } /* -* SLOPE - Sorted L-One Penalized Estimation -*/ -SLOPE::SLOPE(int dim){ + * SLOPE - Sorted L-One Penalized Estimation + */ +SLOPE::SLOPE(int dim) +{ // BH-type rule // lambda_BH(i) = Phi_inv () lambda.resize(dim); double q = 0.05; - for(int i = 0; i < dim; i++){ + for (int i = 0; i < dim; i++) + { lambda(i) = R::qnorm(1 - (i + 1) * q / (2 * dim), 0.0, 1.0, 1, 0); } - + MoMALogger::debug("Initializing SLOPE proximal operator object"); } -arma::vec SLOPE::operator()(const arma::vec &x, double l){ - int n = x.n_elem; +arma::vec SLOPE::operator()(const arma::vec &x, double l) +{ + int n = x.n_elem; arma::vec x_sgn = arma::sign(x); arma::vec x_abs = arma::abs(x); - arma::uvec order = arma::sort_index(x_abs,"descend"); + arma::uvec order = arma::sort_index(x_abs, "descend"); arma::vec ordered_absx(n); // arma::vec ordered_abs(n); - for(int i =0; i < n; i++){ + for (int i = 0; i < n; i++) + { ordered_absx(i) = x_abs(order(i)); } - + arma::vec scratch(x.n_elem); - evaluateProx(ordered_absx,lambda * l,scratch,x.n_elem,order); + evaluateProx(ordered_absx, lambda * l, scratch, x.n_elem, order); return scratch % x_sgn; } -SLOPE::~SLOPE(){ +SLOPE::~SLOPE() +{ MoMALogger::debug("Releasing SLOPE proximal operator object"); } -int SLOPE::df(const arma::vec &x){ +int SLOPE::df(const arma::vec &x) +{ return arma::sum(x != 0.0); } /* -* Non-negative Lasso -*/ -NonNegativeLasso::NonNegativeLasso(){ + * Non-negative Lasso + */ +NonNegativeLasso::NonNegativeLasso() +{ MoMALogger::debug("Initializing non-negative Lasso proximal operator object"); } -arma::vec NonNegativeLasso::operator()(const arma::vec &x, double l){ - return soft_thres_p(x,l); +arma::vec NonNegativeLasso::operator()(const arma::vec &x, double l) +{ + return soft_thres_p(x, l); } -NonNegativeLasso::~NonNegativeLasso(){ +NonNegativeLasso::~NonNegativeLasso() +{ MoMALogger::debug("Releasing non-negative Lasso proximal operator object"); } -int NonNegativeLasso::df(const arma::vec &x){ +int NonNegativeLasso::df(const arma::vec &x) +{ return arma::sum(x != 0.0); } /* -* SCAD -*/ -SCAD::SCAD(double g){ + * SCAD + */ +SCAD::SCAD(double g) +{ MoMALogger::debug("Initializing SCAD proximal operator object"); - if(g <= 2){ + if (g <= 2) + { MoMALogger::error("Gamma for SCAD should be larger than 2!"); }; gamma = g; } -SCAD::~SCAD(){ +SCAD::~SCAD() +{ MoMALogger::debug("Releasing SCAD proximal operator object"); } -arma::vec SCAD::operator()(const arma::vec &x, double l){ - int n = x.n_elem; - double gl = gamma*l; +arma::vec SCAD::operator()(const arma::vec &x, double l) +{ + int n = x.n_elem; + double gl = gamma * l; arma::vec z(n); arma::vec absx = arma::abs(x); arma::vec sgnx = arma::sign(x); - for (int i = 0; i < n; i++) // Probably need vectorization + for (int i = 0; i < n; i++) // Probably need vectorization { - // The implementation follows - // Variable Selection via Nonconcave Penalized Likelihood and its Oracle Properties - // Jianqing Fan nd Runze Li - // formula(2.8). - z(i) = absx(i) > gl ? absx(i) : (absx(i) > 2 * l ? //(gamma-1)/(gamma-2) * THRES_P(absx(i),gamma*l/(gamma-1)) - ((gamma - 1) * absx(i) - gl)/ (gamma - 2) - : THRES_P(absx(i),l) - ); + // The implementation follows + // Variable Selection via Nonconcave Penalized Likelihood and its Oracle + // Properties Jianqing Fan nd Runze Li formula(2.8). + z(i) = absx(i) > gl + ? absx(i) + : (absx(i) > 2 * l ? //(gamma-1)/(gamma-2) * THRES_P(absx(i),gamma*l/(gamma-1)) + ((gamma - 1) * absx(i) - gl) / (gamma - 2) + : THRES_P(absx(i), l)); } return z % sgnx; } -arma::vec SCAD::vec_prox(const arma::vec &x, double l){ - int n = x.n_elem; +arma::vec SCAD::vec_prox(const arma::vec &x, double l) +{ + int n = x.n_elem; double gl = gamma * l; arma::vec z(n); arma::vec absx = arma::abs(x); arma::vec sgnx = arma::sign(x); - arma::umat D(x.n_elem,3,arma::fill::zeros); + arma::umat D(x.n_elem, 3, arma::fill::zeros); - for(int i = 0; i < n; i++){ - arma::uword flag = absx(i) > gl ? 2 : (absx(i) > 2 * l ? 1: 0); - D(i,flag) = 1; + for (int i = 0; i < n; i++) + { + arma::uword flag = absx(i) > gl ? 2 : (absx(i) > 2 * l ? 1 : 0); + D(i, flag) = 1; } // D.col(2) = absx > gl; // D.col(0) = absx <= 2 * l; // D.col(1) = arma::ones(n) - D.col(2) - D.col(0); - z = D.col(0) % soft_thres_p(absx,l) + D.col(1) % ((gamma - 1) * absx - gl) / (gamma-2) + D.col(2) % absx; + z = D.col(0) % soft_thres_p(absx, l) + D.col(1) % ((gamma - 1) * absx - gl) / (gamma - 2) + + D.col(2) % absx; return sgnx % z; } -int SCAD::df(const arma::vec &x){ +int SCAD::df(const arma::vec &x) +{ // An approximation return arma::sum(x != 0.0); } /* -* Nonnegative SCAD -*/ -NonNegativeSCAD::NonNegativeSCAD(double g):SCAD(g){ + * Nonnegative SCAD + */ +NonNegativeSCAD::NonNegativeSCAD(double g) : SCAD(g) +{ MoMALogger::debug("Initializing non-negative SCAD proximal operator object"); } -NonNegativeSCAD::~NonNegativeSCAD(){ +NonNegativeSCAD::~NonNegativeSCAD() +{ MoMALogger::debug("Releasing non-negative SCAD proximal operator object"); } -arma::vec NonNegativeSCAD::operator()(const arma::vec &x, double l){ - int n = x.n_elem; +arma::vec NonNegativeSCAD::operator()(const arma::vec &x, double l) +{ + int n = x.n_elem; double gl = gamma * l; arma::vec z(n); - for (int i = 0; i < n; i++) // Probably need vectorization - { - // The implementation follows - // Variable Selection via Nonconcave Penalized Likelihood and its Oracle Properties - // Jianqing Fan and Runze Li - // formula(2.8). - z(i) = x(i) > gl ? x(i): - (x(i) > 2 * l ? //(gamma-1)/(gamma-2) * THRES_P(absx(i),gamma*l/(gamma-1)) - ((gamma - 1) * x(i) - gl) / (gamma - 2) - : THRES_P(x(i),l) - ); + for (int i = 0; i < n; i++) // Probably need vectorization + { + // The implementation follows + // Variable Selection via Nonconcave Penalized Likelihood and its Oracle + // Properties Jianqing Fan and Runze Li formula(2.8). + z(i) = x(i) > gl + ? x(i) + : (x(i) > 2 * l ? //(gamma-1)/(gamma-2) * THRES_P(absx(i),gamma*l/(gamma-1)) + ((gamma - 1) * x(i) - gl) / (gamma - 2) + : THRES_P(x(i), l)); } return z; } -int NonNegativeSCAD::df(const arma::vec &x){ +int NonNegativeSCAD::df(const arma::vec &x) +{ // An approximation return arma::sum(x != 0.0); } /* -* MCP -*/ -MCP::MCP(double g){ + * MCP + */ +MCP::MCP(double g) +{ MoMALogger::debug("Initializing MCP proximal operator object"); - if(g <= 1){ + if (g <= 1) + { MoMALogger::error("Gamma for MCP should be larger than 1!"); } - gamma=g; + gamma = g; } -MCP::~MCP(){ +MCP::~MCP() +{ MoMALogger::debug("Releasing MCP proximal operator object"); } -arma::vec MCP::operator()(const arma::vec &x, double l){ +arma::vec MCP::operator()(const arma::vec &x, double l) +{ int n = x.n_elem; arma::vec z(n); arma::vec absx = arma::abs(x); @@ -219,46 +253,53 @@ arma::vec MCP::operator()(const arma::vec &x, double l){ // implementation follows lecture notes of Patrick Breheny // http://myweb.uiowa.edu/pbreheny/7600/s16/notes/2-29.pdf // slide 19 - z(i) = absx(i) > gamma * l ? absx(i) : (gamma / (gamma - 1)) * THRES_P(absx(i),l); + z(i) = absx(i) > gamma * l ? absx(i) : (gamma / (gamma - 1)) * THRES_P(absx(i), l); } - return z % sgnx; + return z % sgnx; } -arma::vec MCP::vec_prox(const arma::vec &x, double l){ - int n = x.n_elem; +arma::vec MCP::vec_prox(const arma::vec &x, double l) +{ + int n = x.n_elem; double gl = gamma * l; arma::vec z(n); arma::vec absx = arma::abs(x); arma::vec sgnx = arma::sign(x); - arma::umat D(x.n_elem,2,arma::fill::zeros); - for(int i = 0; i < n; i++){ + arma::umat D(x.n_elem, 2, arma::fill::zeros); + for (int i = 0; i < n; i++) + { arma::uword flag = 0; - if(absx(i) <= gl){ + if (absx(i) <= gl) + { flag = 1; } - D(i,flag) = 1; + D(i, flag) = 1; } - z = (gamma / (gamma - 1)) * (D.col(1) % soft_thres_p(absx,l)) + D.col(0) % absx; + z = (gamma / (gamma - 1)) * (D.col(1) % soft_thres_p(absx, l)) + D.col(0) % absx; return sgnx % z; } -int MCP::df(const arma::vec &x){ +int MCP::df(const arma::vec &x) +{ // An approximation return arma::sum(x != 0.0); } /* -* Non-negative MCP -*/ -NonNegativeMCP::NonNegativeMCP(double g):MCP(g){ + * Non-negative MCP + */ +NonNegativeMCP::NonNegativeMCP(double g) : MCP(g) +{ MoMALogger::debug("Initializing non-negative MCP proximal operator object"); } -NonNegativeMCP::~NonNegativeMCP(){ +NonNegativeMCP::~NonNegativeMCP() +{ MoMALogger::debug("Releasing non-negative MCP proximal operator object"); } -arma::vec NonNegativeMCP::operator()(const arma::vec &x, double l){ +arma::vec NonNegativeMCP::operator()(const arma::vec &x, double l) +{ int n = x.n_elem; arma::vec z(n); for (int i = 0; i < n; i++) @@ -266,97 +307,115 @@ arma::vec NonNegativeMCP::operator()(const arma::vec &x, double l){ // implementation follows lecture notes of Patrick Breheny // http://myweb.uiowa.edu/pbreheny/7600/s16/notes/2-29.pdf // slide 19 - z(i) = x(i) > gamma * l ? x(i) : (gamma / (gamma - 1)) * THRES_P(x(i),l); + z(i) = x(i) > gamma * l ? x(i) : (gamma / (gamma - 1)) * THRES_P(x(i), l); } return z; } -int NonNegativeMCP::df(const arma::vec &x){ +int NonNegativeMCP::df(const arma::vec &x) +{ // An approximation return arma::sum(x != 0.0); } /* -* Group lasso -*/ -GrpLasso::GrpLasso(const arma::vec &grp): - group(grp - arma::ones(grp.n_elem)){ - // takes in a factor `grp`, whose indices start with 1 + * Group lasso + */ +GrpLasso::GrpLasso(const arma::vec &grp) : group(grp - arma::ones(grp.n_elem)) +{ + // takes in a factor `grp`, whose indices start with 1 n_grp = grp.max(); MoMALogger::debug("Initializing group lasso proximal operator object"); } -GrpLasso::~GrpLasso(){ +GrpLasso::~GrpLasso() +{ MoMALogger::debug("Releasing non-negative group lasso proximal operator object"); } -arma::vec GrpLasso::operator()(const arma::vec &x, double l){ +arma::vec GrpLasso::operator()(const arma::vec &x, double l) +{ // TODO: benchmark with simple looping! - if(x.n_elem != group.n_elem){ + if (x.n_elem != group.n_elem) + { MoMALogger::debug("Wrong dimension: x dim is") << x.n_elem << "but we take" << group.n_elem; } arma::vec grp_norm = arma::zeros(n_grp); - for(int i = 0; i < x.n_elem; i++){ - grp_norm(group(i)) += x(i)*x(i); + for (int i = 0; i < x.n_elem; i++) + { + grp_norm(group(i)) += x(i) * x(i); } - grp_norm = arma::sqrt(grp_norm); - arma::vec grp_scale = soft_thres_p(grp_norm,l) / grp_norm; + grp_norm = arma::sqrt(grp_norm); + arma::vec grp_scale = soft_thres_p(grp_norm, l) / grp_norm; arma::vec scale(x.n_elem); - for(int i = 0; i < x.n_elem; i++){ + for (int i = 0; i < x.n_elem; i++) + { scale(i) = grp_scale(group(i)); } return x % scale; } -int GrpLasso::df(const arma::vec &x){ +int GrpLasso::df(const arma::vec &x) +{ // Ref: Equation (6.3) of - // Yuan, Ming, and Yi Lin. - // "Model selection and estimation in regression with grouped variables." - // Journal of the Royal Statistical Society: Series B (Statistical Methodology) 68.1 (2006): 49-67. + // Yuan, Ming, and Yi Lin. + // "Model selection and estimation in regression with grouped variables." + // Journal of the Royal Statistical Society: Series B (Statistical + // Methodology) 68.1 (2006): 49-67. arma::vec grp_norm = arma::zeros(n_grp); - for(int i = 0; i < x.n_elem; i++){ - grp_norm(group(i)) += x(i)*x(i); + for (int i = 0; i < x.n_elem; i++) + { + grp_norm(group(i)) += x(i) * x(i); } // Approxiamte df = number of groups that are not zero + num_para - num_group - // The unbiased estimate is a bit complicated, involving finding OLS estimates. + // The unbiased estimate is a bit complicated, involving finding OLS + // estimates. return arma::sum(grp_norm != 0.0) + x.n_elem - n_grp; } /* -* Non-negative group lasso -*/ -NonNegativeGrpLasso::NonNegativeGrpLasso(const arma::vec &grp):GrpLasso(grp){ // takes in a factor + * Non-negative group lasso + */ +NonNegativeGrpLasso::NonNegativeGrpLasso(const arma::vec &grp) : GrpLasso(grp) +{ // takes in a factor MoMALogger::debug("Initializing non-negative group lasso proximal operator object"); } -NonNegativeGrpLasso::~NonNegativeGrpLasso(){ +NonNegativeGrpLasso::~NonNegativeGrpLasso() +{ MoMALogger::debug("Releasing non-negative group lasso proximal operator object"); } -arma::vec NonNegativeGrpLasso::operator()(const arma::vec &x_, double l){ +arma::vec NonNegativeGrpLasso::operator()(const arma::vec &x_, double l) +{ // Reference: Proximal Methods for Hierarchical Sparse Coding, Lemma 11 - arma::vec x = soft_thres_p(x_,0); // zero out negative entries - if(x.n_elem != group.n_elem){ + arma::vec x = soft_thres_p(x_, 0); // zero out negative entries + if (x.n_elem != group.n_elem) + { MoMALogger::debug("Wrong dimension: x dim is") << x.n_elem << "but we take" << group.n_elem; } arma::vec grp_norm = arma::zeros(n_grp); - for(int i = 0; i < x.n_elem; i++){ - grp_norm(group(i)) += x(i)*x(i); + for (int i = 0; i < x.n_elem; i++) + { + grp_norm(group(i)) += x(i) * x(i); } - grp_norm = arma::sqrt(grp_norm); - arma::vec grp_scale = soft_thres_p(grp_norm,l) / grp_norm; + grp_norm = arma::sqrt(grp_norm); + arma::vec grp_scale = soft_thres_p(grp_norm, l) / grp_norm; arma::vec scale(x.n_elem); - for(int i = 0; i < x.n_elem; i++){ + for (int i = 0; i < x.n_elem; i++) + { scale(i) = grp_scale(group(i)); } return x % scale; } -int NonNegativeGrpLasso::df(const arma::vec &x){ +int NonNegativeGrpLasso::df(const arma::vec &x) +{ arma::vec grp_norm = arma::zeros(n_grp); - for(int i = 0; i < x.n_elem; i++){ - grp_norm(group(i)) += x(i)*x(i); + for (int i = 0; i < x.n_elem; i++) + { + grp_norm(group(i)) += x(i) * x(i); } // Approxiamte df = number of groups that are not zero + num_para - num_group // The unbiased estimate is a bit complicated, involving find OLS estimates. @@ -364,141 +423,168 @@ int NonNegativeGrpLasso::df(const arma::vec &x){ } /* -* Ordered fused lasso -*/ -OrderedFusedLasso::OrderedFusedLasso(){ + * Ordered fused lasso + */ +OrderedFusedLasso::OrderedFusedLasso() +{ MoMALogger::debug("Initializing a ordered fusion lasso proximal operator object"); } -OrderedFusedLasso::~OrderedFusedLasso(){ +OrderedFusedLasso::~OrderedFusedLasso() +{ MoMALogger::debug("Releasing a ordered fusion lasso proximal operator object"); } -arma::vec OrderedFusedLasso::operator()(const arma::vec &x, double l){ +arma::vec OrderedFusedLasso::operator()(const arma::vec &x, double l) +{ FusedGroups fg(x); - while(!fg.all_merged() && fg.next_lambda() < l){ + while (!fg.all_merged() && fg.next_lambda() < l) + { fg.merge(); - } return fg.find_beta_at(l); } -int OrderedFusedLasso::df(const arma::vec &x){ +int OrderedFusedLasso::df(const arma::vec &x) +{ // Ref: - // Table 2 of Tibshirani, Robert. - // "Regression shrinkage and selection via the lasso: a retrospective." - // Journal of the Royal Statistical Society: Series B (Statistical Methodology) 73.3 (2011): 273-282. - if(x.n_elem < 2){ + // Table 2 of Tibshirani, Robert. + // "Regression shrinkage and selection via the lasso: a retrospective." + // Journal of the Royal Statistical Society: Series B (Statistical + // Methodology) 73.3 (2011): 273-282. + if (x.n_elem < 2) + { MoMALogger::error("x must not be a scalar"); } int df = 1; // Cound the number of transitions, which is the number of fused groups - for(int i = 1; i < x.n_elem; i++){ - if(abs(x(i)-x(i-1)) > 1e-10){ + for (int i = 1; i < x.n_elem; i++) + { + if (abs(x(i) - x(i - 1)) > 1e-10) + { df++; } } - return df; + return df; } /* -* Ordered fused lasso-dynamic programming approach -*/ -OrderedFusedLassoDP::OrderedFusedLassoDP(){ + * Ordered fused lasso-dynamic programming approach + */ +OrderedFusedLassoDP::OrderedFusedLassoDP() +{ MoMALogger::debug("Initializing a ordered fusion lasso proximal operator object (DP)"); } -OrderedFusedLassoDP::~OrderedFusedLassoDP(){ +OrderedFusedLassoDP::~OrderedFusedLassoDP() +{ MoMALogger::debug("Releasing a ordered fusion lasso proximal operator object (DP)"); } -arma::vec OrderedFusedLassoDP::operator()(const arma::vec& x, double l) { +arma::vec OrderedFusedLassoDP::operator()(const arma::vec &x, double l) +{ return myflsadp(x, l, MOMA_FUSEDLASSODP_BUFFERSIZE); -} - +} /* -* Sparse fused lasso -*/ -SparseFusedLasso::SparseFusedLasso(double i_lambda2):lambda2(i_lambda2){ + * Sparse fused lasso + */ +SparseFusedLasso::SparseFusedLasso(double i_lambda2) : lambda2(i_lambda2) +{ MoMALogger::debug("Initializing a sparse fused lasso proximal operator object"); } -SparseFusedLasso::~SparseFusedLasso(){ +SparseFusedLasso::~SparseFusedLasso() +{ MoMALogger::debug("Releasing a sparse fused lasso proximal operator object"); } -arma::vec SparseFusedLasso::operator()(const arma::vec &x, double l){ - arma::vec tmp = fg(x,l); - return soft_thres(tmp,lambda2); +arma::vec SparseFusedLasso::operator()(const arma::vec &x, double l) +{ + arma::vec tmp = fg(x, l); + return soft_thres(tmp, lambda2); } -int SparseFusedLasso::df(const arma::vec &x){ +int SparseFusedLasso::df(const arma::vec &x) +{ // Ref: - // Table 2 of Tibshirani, Robert. - // "Regression shrinkage and selection via the lasso: a retrospective." - // Journal of the Royal Statistical Society: Series B (Statistical Methodology) 73.3 (2011): 273-282. + // Table 2 of Tibshirani, Robert. + // "Regression shrinkage and selection via the lasso: a retrospective." + // Journal of the Royal Statistical Society: Series B (Statistical + // Methodology) 73.3 (2011): 273-282. - if(x.n_elem < 2){ + if (x.n_elem < 2) + { MoMALogger::error("x must not be a scalar"); } int df = x(0) != 0; // the number of non-zero fused groups - for(int i = 1; i < x.n_elem; i++){ - if(x(i) != 0 && abs(x(i)-x(i-1)) > 1e-10){ + for (int i = 1; i < x.n_elem; i++) + { + if (x(i) != 0 && abs(x(i) - x(i - 1)) > 1e-10) + { df++; } } - return df; + return df; } /* -* Fusion lasso -*/ + * Fusion lasso + */ // From matrix index to vector index of an upper triangular matrix -int tri_idx(int i, int j, int n){ +int tri_idx(int i, int j, int n) +{ return (2 * n - i - 1) * i / 2 + j - i - 1; } -Fusion::Fusion(const arma::mat &input_w,bool input_ADMM,bool input_acc,double input_prox_eps){ +Fusion::Fusion(const arma::mat &input_w, bool input_ADMM, bool input_acc, double input_prox_eps) +{ // w should be symmetric, and have zero diagonal elements. // We only store the upper half of the matrix w_ij, j >= i+1. // This wastes some space since the lower triangular part of weight is empty. - prox_eps = input_prox_eps; - ADMM = input_ADMM; - acc = input_acc; + prox_eps = input_prox_eps; + ADMM = input_ADMM; + acc = input_acc; int n_col = input_w.n_cols; int n_row = input_w.n_rows; - if(n_col != n_row){ + if (n_col != n_row) + { MoMALogger::error("Weight matrix should be square: ") << n_col << " and " << n_row; } start_point.set_size(n_col); start_point.zeros(); - weight.set_size(n_col*(n_col-1)/2); + weight.set_size(n_col * (n_col - 1) / 2); - for(int i = 0; i < n_col; i++){ - for(int j = i + 1; j < n_col; j++){ - int k = tri_idx(i,j,n_col); - weight(k) = input_w(i,j); + for (int i = 0; i < n_col; i++) + { + for (int j = i + 1; j < n_col; j++) + { + int k = tri_idx(i, j, n_col); + weight(k) = input_w(i, j); } } MoMALogger::debug("Initializing a fusion lasso proximal operator object"); }; -Fusion::~Fusion(){ +Fusion::~Fusion() +{ MoMALogger::debug("Releasing a fusion lasso proximal operator object"); }; // Find the column sums and row sums of an upper triangular matrix, // whose diagonal elements are all zero. -int tri_sums(const arma::vec &w, arma::vec &col_sums, arma::vec &row_sums, int n){ +int tri_sums(const arma::vec &w, arma::vec &col_sums, arma::vec &row_sums, int n) +{ // col_sums and row_sums should be initialzied by zeros. col_sums.zeros(); row_sums.zeros(); int cnt = 0; - for(int i = 0; i < n; i++){ - for(int j = i + 1; j < n; j++){ + for (int i = 0; i < n; i++) + { + for (int j = i + 1; j < n; j++) + { row_sums(i) += w(cnt); col_sums(j) += w(cnt); cnt++; @@ -507,13 +593,15 @@ int tri_sums(const arma::vec &w, arma::vec &col_sums, arma::vec &row_sums, int n return 0; } -int Fusion::df(const arma::vec &x){ +int Fusion::df(const arma::vec &x) +{ // First construct a graph, where any nodes are connected if // they have the same value. Then a good intuition is to find - // the number of connected components, which is the multiplicity - // of 0 as an eigenvalue of the laplacian matrix of the graph. Way too complicated. + // the number of connected components, which is the multiplicity + // of 0 as an eigenvalue of the laplacian matrix of the graph. Way too + // complicated. - // There could be cases when two groups happen to have the + // There could be cases when two groups happen to have the // same value, but are not actually "fused". // Let's just count the number of different values. @@ -523,34 +611,38 @@ int Fusion::df(const arma::vec &x){ // This function sets lambda += (lambda - old_lambda) * step, // and then set old_lambda = lambda. -int tri_momentum(arma::mat &lambda, arma::mat &old_lambda, double step, int n){ +int tri_momentum(arma::mat &lambda, arma::mat &old_lambda, double step, int n) +{ lambda += step * (lambda - old_lambda); old_lambda = lambda; return 0; } -arma::vec Fusion::operator()(const arma::vec &x, double l){ +arma::vec Fusion::operator()(const arma::vec &x, double l) +{ const int MAX_IT = 10000; - arma::vec &w = weight; - int n = x.n_elem; - if(n == 2){ + arma::vec &w = weight; + int n = x.n_elem; + if (n == 2) + { MoMALogger::error("Please use ordered fused lasso instead"); } // beta subproblem: O(n) - if(ADMM){ + if (ADMM) + { // ADMM - // Reference: Algorithm 5 in - // ADMM Algorithmic Regularization Paths for Sparse Statistical Machine Learning, - // Yue Hu, Eric C. Chi and Genevera I. Allen + // Reference: Algorithm 5 in + // ADMM Algorithmic Regularization Paths for Sparse Statistical Machine + // Learning, Yue Hu, Eric C. Chi and Genevera I. Allen // Using Genevera's paper notations MoMALogger::debug("Running ADMM."); const arma::vec &y = x; - + double y_bar = arma::mean(y); - arma::vec z(n*(n-1)/2); - arma::vec u(n*(n-1)/2); + arma::vec z(n * (n - 1) / 2); + arma::vec u(n * (n - 1) / 2); arma::vec &b = start_point; arma::vec old_b; // arma::mat old_z(n,n); @@ -562,31 +654,36 @@ arma::vec Fusion::operator()(const arma::vec &x, double l){ // old_u.zeros(); int cnt = 0; - do{ + do + { old_b = b; cnt++; arma::vec z_row_sums(n); arma::vec z_col_sums(n); arma::vec u_row_sums(n); arma::vec u_col_sums(n); - tri_sums(u,u_col_sums,u_row_sums,n); - tri_sums(z,z_col_sums,z_row_sums,n); + tri_sums(u, u_col_sums, u_row_sums, n); + tri_sums(z, z_col_sums, z_row_sums, n); // beta subproblem: O(n) - // TODO: vectorize - for(int i = 0; i < n; i++){ + // TODO: vectorize + for (int i = 0; i < n; i++) + { double part1 = z_row_sums(i) + u_row_sums(i); double part2 = z_col_sums(i) + u_col_sums(i); - b(i) = ((y(i) + n * y_bar) + part1 - part2) / (n + 1); + b(i) = ((y(i) + n * y_bar) + part1 - part2) / (n + 1); } // u and z subproblems: O(n(n-1)/2) - for(int i = 0; i < n; i++){ - for(int j = i + 1; j < n; j++){ + for (int i = 0; i < n; i++) + { + for (int j = i + 1; j < n; j++) + { // z - int k = tri_idx(i,j,n); + int k = tri_idx(i, j, n); double to_be_thres = b(i) - b(j) - u(k); - double scale = (1 - l * w(k) / std::abs(to_be_thres)); // TODO: vectorize - if(scale < 0){ + double scale = (1 - l * w(k) / std::abs(to_be_thres)); // TODO: vectorize + if (scale < 0) + { scale = 0; }; z(k) = scale * to_be_thres; @@ -594,7 +691,8 @@ arma::vec Fusion::operator()(const arma::vec &x, double l){ u(k) = u(k) + (z(k) - (b(i) - b(j))); } } - if(acc){ + if (acc) + { MoMALogger::error("Not provided yet"); // double alpha = (1 + std::sqrt(old_alpha)) / 2; // z += (old_alpha / alpha) * (z - old_z); @@ -605,33 +703,40 @@ arma::vec Fusion::operator()(const arma::vec &x, double l){ // // tri_momentum(u,old_u,old_alpha / alpha,n); // old_alpha = alpha; } - }while(arma::norm(old_b - b,2) / arma::norm(old_b,2) > prox_eps && cnt < MAX_IT); + } while (arma::norm(old_b - b, 2) / arma::norm(old_b, 2) > prox_eps && cnt < MAX_IT); // Check convergence - if(cnt == MAX_IT){ + if (cnt == MAX_IT) + { MoMALogger::warning("No convergence in unordered fusion lasso prox (ADMM)."); - }else{ + } + else + { MoMALogger::debug("ADMM converges after iter: ") << cnt; } // TODO: shrink stepsize, as is done in the paper return b; } - else{ + else + { // AMA // Reference: Algorithm 3 Fast AMA in // Splitting Methods for Convex Clustering // Eric C. Chi and Kenneth Lange† int n = x.n_elem; - // Choosing nu is not trivial. See Proposition 4.1 in + // Choosing nu is not trivial. See Proposition 4.1 in // Splitting Methods for Convex Clustering, Chi and Range MoMALogger::debug("Running AMA."); // Find the degrees of nodes arma::vec deg(n); deg.zeros(); - for(int i = 0; i < n; i++){ - for(int j = i + 1; j < n; j++){ - if(w(tri_idx(i,j,n)) > 0){ + for (int i = 0; i < n; i++) + { + for (int j = i + 1; j < n; j++) + { + if (w(tri_idx(i, j, n)) > 0) + { deg(i)++; deg(j)++; } @@ -640,35 +745,42 @@ arma::vec Fusion::operator()(const arma::vec &x, double l){ // Find the degree of edges, which are the sums of their nodes. int max_edge_deg = -1; - for(int i = 0; i < n; i++){ - for(int j = i + 1; j < n; j++){ - if(w(tri_idx(i,j,n)) > 0){ - max_edge_deg = std::max(double(deg(i)+deg(j)),(double)max_edge_deg); + for (int i = 0; i < n; i++) + { + for (int j = i + 1; j < n; j++) + { + if (w(tri_idx(i, j, n)) > 0) + { + max_edge_deg = std::max(double(deg(i) + deg(j)), (double)max_edge_deg); } } } - double nu = 1.0 / (std::min(n,max_edge_deg)); + double nu = 1.0 / (std::min(n, max_edge_deg)); arma::vec &u = start_point; - arma::vec lambda(n*(n-1)/2); + arma::vec lambda(n * (n - 1) / 2); // Initialze lambda.zeros(); double old_alpha = 1; - arma::vec old_lambda(n*(n-1)/2); + arma::vec old_lambda(n * (n - 1) / 2); old_lambda.zeros(); arma::vec old_u; int cnt = 0; // Start iterating - do{ + do + { cnt++; // lambda subproblem - for(int i = 0; i < n; i++){ - for(int j = i + 1; j < n; j++){ - int k = tri_idx(i,j,n); + for (int i = 0; i < n; i++) + { + for (int j = i + 1; j < n; j++) + { + int k = tri_idx(i, j, n); lambda(k) = lambda(k) - nu * (u(i) - u(j)); // project onto the interval [ -w_ij*lambda_ij, w_ij*lambda_ij ] - if(std::abs(lambda(k)) > l * w(k)){ + if (std::abs(lambda(k)) > l * w(k)) + { lambda(k) = l * w(k) * lambda(k) / std::abs(lambda(k)); } } @@ -678,23 +790,28 @@ arma::vec Fusion::operator()(const arma::vec &x, double l){ old_u = u; arma::vec lambda_row_sums(n); arma::vec lambda_col_sums(n); - tri_sums(lambda,lambda_col_sums,lambda_row_sums,n); - for(int i = 0; i < n; i++){ + tri_sums(lambda, lambda_col_sums, lambda_row_sums, n); + for (int i = 0; i < n; i++) + { double part1 = lambda_row_sums(i); double part2 = lambda_col_sums(i); - u(i) = x(i) + part1 - part2; + u(i) = x(i) + part1 - part2; } - if(acc){// Momemtum step + if (acc) + { // Momemtum step double alpha = (1 + std::sqrt(old_alpha)) / 2; - tri_momentum(lambda,old_lambda,(old_alpha-1.0)/alpha,n); + tri_momentum(lambda, old_lambda, (old_alpha - 1.0) / alpha, n); old_alpha = alpha; } - }while(arma::norm(u-old_u,2) / arma::norm(old_u,2) > prox_eps && cnt < MAX_IT); + } while (arma::norm(u - old_u, 2) / arma::norm(old_u, 2) > prox_eps && cnt < MAX_IT); // Check convergence - if(cnt == MAX_IT){ + if (cnt == MAX_IT) + { MoMALogger::warning("No convergence in unordered fusion lasso prox (AMA)."); - }else{ + } + else + { MoMALogger::debug("AMA converges after iter: ") << cnt; } return u; @@ -702,115 +819,155 @@ arma::vec Fusion::operator()(const arma::vec &x, double l){ } // A handle class -ProxOp::ProxOp(Rcpp::List prox_arg_list, int dim){ - const std::string &s = Rcpp::as(prox_arg_list["P"]); - double gamma = Rcpp::as(prox_arg_list["gamma"]); - const arma::vec group = Rcpp::as(prox_arg_list["group"]); - double lambda2 = Rcpp::as(prox_arg_list["lambda2"]); - const arma::mat w = Rcpp::as(prox_arg_list["w"]); - bool ADMM = Rcpp::as(prox_arg_list["ADMM"]); - bool acc = Rcpp::as(prox_arg_list["acc"]); - double prox_eps = Rcpp::as(prox_arg_list["prox_eps"]); - int l1tf_k = Rcpp::as(prox_arg_list["l1tf_k"]); - bool nonneg = Rcpp::as(prox_arg_list["nonneg"]); - if(s.compare("NONE") == 0){ +ProxOp::ProxOp(Rcpp::List prox_arg_list, int dim) +{ + const std::string &s = Rcpp::as(prox_arg_list["P"]); + double gamma = Rcpp::as(prox_arg_list["gamma"]); + const arma::vec group = Rcpp::as(prox_arg_list["group"]); + double lambda2 = Rcpp::as(prox_arg_list["lambda2"]); + const arma::mat w = Rcpp::as(prox_arg_list["w"]); + bool ADMM = Rcpp::as(prox_arg_list["ADMM"]); + bool acc = Rcpp::as(prox_arg_list["acc"]); + double prox_eps = Rcpp::as(prox_arg_list["prox_eps"]); + int l1tf_k = Rcpp::as(prox_arg_list["l1tf_k"]); + bool nonneg = Rcpp::as(prox_arg_list["nonneg"]); + if (s.compare("NONE") == 0) + { p = new NullProx(); } - else if (s.compare("LASSO") == 0){ - if(nonneg){ + else if (s.compare("LASSO") == 0) + { + if (nonneg) + { p = new NonNegativeLasso(); } - else{ + else + { p = new Lasso(); } } - else if (s.compare("SCAD") == 0){ - if(nonneg){ + else if (s.compare("SCAD") == 0) + { + if (nonneg) + { p = new NonNegativeSCAD(gamma); } - else{ + else + { p = new SCAD(gamma); } } - else if (s.compare("MCP") == 0){ - if(nonneg){ + else if (s.compare("MCP") == 0) + { + if (nonneg) + { p = new NonNegativeMCP(gamma); } - else{ + else + { p = new MCP(gamma); } } - else if (s.compare("SLOPE") == 0){ - if(nonneg){ + else if (s.compare("SLOPE") == 0) + { + if (nonneg) + { MoMALogger::error("Non-negative SLOPE is not implemented!"); } - else{ + else + { p = new SLOPE(dim); } } - else if(s.compare("GRPLASSO") == 0){ - if(group.n_elem != dim){ + else if (s.compare("GRPLASSO") == 0) + { + if (group.n_elem != dim) + { MoMALogger::error("Wrong dimension: length(group) != dim(x)."); } - if(nonneg){ + if (nonneg) + { p = new NonNegativeGrpLasso(group); } - else{ + else + { p = new GrpLasso(group); } } - else if(s.compare("ORDEREDFUSED") == 0){ - if(nonneg){ + else if (s.compare("ORDEREDFUSED") == 0) + { + if (nonneg) + { MoMALogger::error("Non-negative ordered fused lasso is not implemented!"); } - else{ + else + { p = new OrderedFusedLasso(); } } - else if(s.compare("ORDEREDFUSEDDP") == 0){ - if(nonneg){ + else if (s.compare("ORDEREDFUSEDDP") == 0) + { + if (nonneg) + { MoMALogger::error("Non-negative ordered fused lasso is not implemented!"); } - else{ + else + { p = new OrderedFusedLassoDP(); } } - else if(s.compare("SPARSEFUSEDLASSO") == 0){ - if(nonneg){ + else if (s.compare("SPARSEFUSEDLASSO") == 0) + { + if (nonneg) + { MoMALogger::error("Non-negative sparse fused lasso is not implemented!"); } - else{ + else + { p = new SparseFusedLasso(lambda2); } } - else if(s.compare("L1TRENDFILTERING") == 0){ - if(nonneg){ + else if (s.compare("L1TRENDFILTERING") == 0) + { + if (nonneg) + { MoMALogger::error("Non-negative L1 linear trend filtering is not implemented!"); } - else{ - p = new L1TrendFiltering(dim,l1tf_k); // now support any order of difference matrix + else + { + p = new L1TrendFiltering(dim, l1tf_k); // now support any order of difference matrix } } - else if(s.compare("UNORDEREDFUSION") == 0){ - if(w.n_rows != dim || w.n_cols != dim){ + else if (s.compare("UNORDEREDFUSION") == 0) + { + if (w.n_rows != dim || w.n_cols != dim) + { MoMALogger::error("Wrong dimension: dim(weight matrix) != dim(x)."); } - if(nonneg){ + if (nonneg) + { MoMALogger::error("Non-negative unordered fusion lasso is not implemented!"); } - else{ - p = new Fusion(w,ADMM,acc,prox_eps); + else + { + p = new Fusion(w, ADMM, acc, prox_eps); } } - else{ - MoMALogger::error("Your sparse penalty is not provided by us/specified by you! Use `NullProx` by default: ") << s; + else + { + MoMALogger::error( + "Your sparse penalty is not provided by us/specified by you! Use " + "`NullProx` by default: ") + << s; } } -arma::vec ProxOp::operator()(const arma::vec &x, double l){ - return (*p)(x,l); +arma::vec ProxOp::operator()(const arma::vec &x, double l) +{ + return (*p)(x, l); } -int ProxOp::df(const arma::vec &x){ +int ProxOp::df(const arma::vec &x) +{ return (*p).df(x); } diff --git a/src/moma_prox.h b/src/moma_prox.h index a245a672..b6195bed 100644 --- a/src/moma_prox.h +++ b/src/moma_prox.h @@ -1,73 +1,83 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- +// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; +// -*- #ifndef MOMA_PROX #define MOMA_PROX 1 #include "moma_base.h" #include "moma_logging.h" +#include "moma_prox_flsadp.h" #include "moma_prox_fusion_util.h" #include "moma_prox_sortedL1.h" -#include "moma_prox_flsadp.h" -#define MAX(a,b) (a)>(b)?(a):(b) -#define MIN(a,b) (a)<(b)?(a):(b) -#define THRES_P(x,l) (MAX(x-l,0.0)) // shrink a positive value by `l` +#define MAX(a, b) (a) > (b) ? (a) : (b) +#define MIN(a, b) (a) < (b) ? (a) : (b) +#define THRES_P(x, l) (MAX(x - l, 0.0)) // shrink a positive value by `l` -inline arma::vec soft_thres(const arma::vec &x, double l){ +inline arma::vec soft_thres(const arma::vec &x, double l) +{ return arma::sign(x) % arma::max(abs(x) - l, arma::zeros(arma::size(x))); } // soft-thresholding a non-negative vector // all negative values will be set 0 -inline arma::vec soft_thres_p(const arma::vec &x, double l){ +inline arma::vec soft_thres_p(const arma::vec &x, double l) +{ return arma::max(x - l, arma::zeros(x.n_elem)); } // An abstract class, member functions are implemeted in derived classes -class Prox{ -public: +class Prox +{ + public: virtual arma::vec operator()(const arma::vec &x, double l) = 0; - virtual ~Prox() = default; - virtual int df(const arma::vec &x) = 0; + virtual ~Prox() = default; + virtual int df(const arma::vec &x) = 0; }; -class NullProx: public Prox{ -public: +class NullProx : public Prox +{ + public: NullProx(); arma::vec operator()(const arma::vec &x, double l); ~NullProx(); int df(const arma::vec &x); }; -class Lasso: public Prox{ -public: +class Lasso : public Prox +{ + public: Lasso(); arma::vec operator()(const arma::vec &x, double l); ~Lasso(); int df(const arma::vec &x); }; -class SLOPE: public Prox{ +class SLOPE : public Prox +{ arma::vec lambda; -public: + + public: SLOPE(int dim); arma::vec operator()(const arma::vec &x, double l); ~SLOPE(); int df(const arma::vec &x); }; -class NonNegativeLasso: public Prox{ -public: +class NonNegativeLasso : public Prox +{ + public: NonNegativeLasso(); arma::vec operator()(const arma::vec &x, double l); ~NonNegativeLasso(); int df(const arma::vec &x); }; -class SCAD: public Prox{ -protected: - double gamma; // gamma_SCAD >= 2 -public: +class SCAD : public Prox +{ + protected: + double gamma; // gamma_SCAD >= 2 + public: SCAD(double g = 3.7); ~SCAD(); arma::vec operator()(const arma::vec &x, double l); @@ -75,18 +85,20 @@ class SCAD: public Prox{ int df(const arma::vec &x); }; -class NonNegativeSCAD: public SCAD{ -public: +class NonNegativeSCAD : public SCAD +{ + public: NonNegativeSCAD(double g = 3.7); ~NonNegativeSCAD(); arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; -class MCP: public Prox{ -protected: - double gamma; // gamma_MCP >= 1 -public: +class MCP : public Prox +{ + protected: + double gamma; // gamma_MCP >= 1 + public: MCP(double g = 3); ~MCP(); arma::vec operator()(const arma::vec &x, double l); @@ -94,19 +106,21 @@ class MCP: public Prox{ int df(const arma::vec &x); }; -class NonNegativeMCP: public MCP{ -public: +class NonNegativeMCP : public MCP +{ + public: NonNegativeMCP(double g = 3); ~NonNegativeMCP(); arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; -class GrpLasso: public Prox{ -protected: +class GrpLasso : public Prox +{ + protected: arma::vec group; - int n_grp; // number of gourps -public: + int n_grp; // number of gourps + public: GrpLasso(const arma::vec &grp); ~GrpLasso(); arma::vec operator()(const arma::vec &x, double l); @@ -114,98 +128,107 @@ class GrpLasso: public Prox{ int df(const arma::vec &x); }; -class NonNegativeGrpLasso: public GrpLasso{ -public: +class NonNegativeGrpLasso : public GrpLasso +{ + public: NonNegativeGrpLasso(const arma::vec &grp); ~NonNegativeGrpLasso(); arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; -class OrderedFusedLasso: public Prox{ -public: +class OrderedFusedLasso : public Prox +{ + public: OrderedFusedLasso(); ~OrderedFusedLasso(); - arma::vec operator()(const arma::vec &x, double l); + arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; -class OrderedFusedLassoDP: public OrderedFusedLasso{ -public: +class OrderedFusedLassoDP : public OrderedFusedLasso +{ + public: OrderedFusedLassoDP(); ~OrderedFusedLassoDP(); arma::vec operator()(const arma::vec &x, double l); }; -class SparseFusedLasso: public Prox{ -private: +class SparseFusedLasso : public Prox +{ + private: OrderedFusedLasso fg; - double lambda2; // lambda2 is the level of penalty on - // the absolute values of the coefficients + double lambda2; // lambda2 is the level of penalty on + // the absolute values of the coefficients -public: + public: SparseFusedLasso(double); ~SparseFusedLasso(); arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; -class Fusion: public Prox{ -private: +class Fusion : public Prox +{ + private: arma::vec weight; bool ADMM; bool acc; double prox_eps; arma::vec start_point; -public: - Fusion(const arma::mat &input_w = arma::zeros(0,0),bool input_ADMM = 1,bool input_acc = 1,double input_prox_eps=1e-10); + + public: + Fusion(const arma::mat &input_w = arma::zeros(0, 0), + bool input_ADMM = 1, + bool input_acc = 1, + double input_prox_eps = 1e-10); ~Fusion(); arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; - // Its implementation is in `moma_prox_l1tf.cpp` -class L1TrendFiltering: public Prox{ -private: - int k; // k \in 0,1,2, corresponding to fused lasso, linear tf and - // third diff amt - +class L1TrendFiltering : public Prox +{ + private: + int k; // k \in 0,1,2, corresponding to fused lasso, linear tf and + // third diff amt + // The backtracking parameters // shrink stepsize by `bata` // if f(x + stepsize * dx) >= (1 - alpha * step) * f(x) - // Ref: http://www.stat.cmu.edu/~ryantibs/convexopt-F15/lectures/16-primal-dual.pdf page 12 - static constexpr double alpha = 0.01; - static constexpr double beta = 0.5; - static const int MAX_ITER = 200; - static const int MAX_BT_ITER = 5; + // Ref: + // http://www.stat.cmu.edu/~ryantibs/convexopt-F15/lectures/16-primal-dual.pdf + // page 12 + static constexpr double alpha = 0.01; + static constexpr double beta = 0.5; + static const int MAX_ITER = 200; + static const int MAX_BT_ITER = 5; static constexpr double prox_eps = 1e-10; arma::mat D; -public: + public: // n is the dim of the problem, k the degree of differences L1TrendFiltering(int n = -1, int i_k = 1); ~L1TrendFiltering(); - arma::vec operator()(const arma::vec &x, double l); + arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; // A handle class that deals with matching proximal operators // and constructing and releasing the pointer -class ProxOp{ -private: - Prox* p; -public: - ProxOp(){ - p = nullptr; - } - +class ProxOp +{ + private: + Prox *p; + + public: + ProxOp() { p = nullptr; } + ProxOp(Rcpp::List prox_arg_list, int dim); - ~ProxOp(){ - delete p; - } + ~ProxOp() { delete p; } arma::vec operator()(const arma::vec &x, double l); int df(const arma::vec &x); }; diff --git a/src/moma_prox_flsadp.cpp b/src/moma_prox_flsadp.cpp index ea3bebed..ea5b796e 100644 --- a/src/moma_prox_flsadp.cpp +++ b/src/moma_prox_flsadp.cpp @@ -35,14 +35,15 @@ // in order to explain the algorithm. Avoid explicit // memory management. -// Reference: -// Johnson, Nicholas A. -// "A dynamic programming algorithm for the fused lasso and l 0-segmentation." +// Reference: +// Johnson, Nicholas A. +// "A dynamic programming algorithm for the fused lasso and l 0-segmentation." // Journal of Computational and Graphical Statistics 22.2 (2013): 246-260. -double Msg::Argmax(double * max_val) { +double Msg::Argmax(double *max_val) +{ // printf("Enter MaxMsg"); - const std::vector& buf = buf_; + const std::vector &buf = buf_; double lin_left = 0.0; double quad_left = 0.0; @@ -50,56 +51,62 @@ double Msg::Argmax(double * max_val) { int last_idx = start_idx_ + len_ - 1; // Step from left to right - for (int knot_idx = start_idx_, m = len_; m; --m, ++knot_idx) { + for (int knot_idx = start_idx_, m = len_; m; --m, ++knot_idx) + { bool end_knot = (knot_idx == last_idx); - const MsgElt& k = (knot_idx == start_idx_) ? - init_knot_ : - (end_knot ? end_knot_ : buf[knot_idx]); + const MsgElt &k = + (knot_idx == start_idx_) ? init_knot_ : (end_knot ? end_knot_ : buf[knot_idx]); - double x1 = (knot_idx == last_idx-1) ? end_knot_.x_ : buf[knot_idx + 1].x_; + double x1 = (knot_idx == last_idx - 1) ? end_knot_.x_ : buf[knot_idx + 1].x_; - if (k.sgn_) { + if (k.sgn_) + { lin_left += k.lin_; quad_left += k.quad_; - } else { + } + else + { lin_left -= k.lin_; quad_left -= k.quad_; } - if (quad_left == 0.0) { + if (quad_left == 0.0) + { continue; } double hit_x = -lin_left / (2.0 * quad_left); - if (hit_x < x1) { - if (max_val) { + if (hit_x < x1) + { + if (max_val) + { *max_val = hit_x * lin_left + hit_x * hit_x * quad_left; } - return(hit_x); + return (hit_x); } } MoMALogger::error("MaxMsg : failed to maximize message"); - return(-1); + return (-1); } -void Msg::InitMsg(int n, int init_sz, double lin, double quad, - double lambda2) { +void Msg::InitMsg(int n, int init_sz, double lin, double quad, double lambda2) +{ len_ = 2; start_idx_ = init_sz / 2; buf_ = std::vector(init_sz); back_pointers.resize(n * 2); - - int i = start_idx_; + + int i = start_idx_; buf_[i].x_ = R_NegInf; buf_[i].sgn_ = true; buf_[i].lin_ = lin; buf_[i].quad_ = quad; - buf_[i+1].x_ = R_PosInf; - buf_[i+1].sgn_ = false; - buf_[i+1].lin_ = lin; - buf_[i+1].quad_ = quad; + buf_[i + 1].x_ = R_PosInf; + buf_[i + 1].sgn_ = false; + buf_[i + 1].lin_ = lin; + buf_[i + 1].quad_ = quad; init_knot_.x_ = R_NegInf; init_knot_.sgn_ = true; @@ -113,15 +120,18 @@ void Msg::InitMsg(int n, int init_sz, double lin, double quad, MoMALogger::debug("Finish initialization."); } -void Msg::ShiftMsg(int check_freq) { - if (len_ > buf_.size() - 20 * check_freq) { +void Msg::ShiftMsg(int check_freq) +{ + if (len_ > buf_.size() - 20 * check_freq) + { std::vector new_buf(buf_.size() * 3); - std::vector * old_buf = &buf_; + std::vector *old_buf = &buf_; int new_start = (new_buf.size() / 4); int old_start = start_idx_; - for (int k = 0; k < len_; ++k) { + for (int k = 0; k < len_; ++k) + { new_buf[k + new_start] = (*old_buf)[k + old_start]; } @@ -129,93 +139,106 @@ void Msg::ShiftMsg(int check_freq) { start_idx_ = new_start; } - if (start_idx_ < 5 * check_freq) { - int new_start = ((buf_.size() - len_)/2); - int old_start = start_idx_; - std::vector * buf = &buf_; + if (start_idx_ < 5 * check_freq) + { + int new_start = ((buf_.size() - len_) / 2); + int old_start = start_idx_; + std::vector *buf = &buf_; - for (int k = len_ - 1; k >= 0; --k) { + for (int k = len_ - 1; k >= 0; --k) + { (*buf)[k + new_start] = (*buf)[k + old_start]; } start_idx_ = new_start; - - } else if (start_idx_ + len_ > buf_.size() - 5 * check_freq) { - int new_start = ((buf_.size() - len_)/2); - int old_start = start_idx_; - std::vector * buf = &buf_; - - for (int k = 0; k < len_; ++k) { + } + else if (start_idx_ + len_ > buf_.size() - 5 * check_freq) + { + int new_start = ((buf_.size() - len_) / 2); + int old_start = start_idx_; + std::vector *buf = &buf_; + + for (int k = 0; k < len_; ++k) + { (*buf)[k + new_start] = (*buf)[k + old_start]; } start_idx_ = new_start; } } -void Msg::UpdMsg(double lambda2, double lin, double quad, int bp_idx) { - std::vector& buf = buf_; +void Msg::UpdMsg(double lambda2, double lin, double quad, int bp_idx) +{ + std::vector &buf = buf_; - double lin_left = lin; - double quad_left = quad; - int new_knot_start = -3; + double lin_left = lin; + double quad_left = quad; + int new_knot_start = -3; // Algorithm 2, line 4-14 - for (int knot_idx = start_idx_, m = len_; m; --m, ++knot_idx) { - - const MsgElt& k = buf[knot_idx]; - double x1 = buf[knot_idx + 1].x_; - if (k.sgn_) { + for (int knot_idx = start_idx_, m = len_; m; --m, ++knot_idx) + { + const MsgElt &k = buf[knot_idx]; + double x1 = buf[knot_idx + 1].x_; + if (k.sgn_) + { lin_left += k.lin_; quad_left += k.quad_; - } else { + } + else + { lin_left -= k.lin_; quad_left -= k.quad_; } double hit_x = (lambda2 - lin_left) / (2.0 * quad_left); - if (hit_x < x1) { + if (hit_x < x1) + { // place a knot here - new_knot_start = knot_idx - 1; + new_knot_start = knot_idx - 1; back_pointers(bp_idx) = hit_x; break; } } - double lin_right = lin; - double quad_right = quad; - int new_knot_end = -2; - int end_idx = start_idx_ + len_ - 1; + double lin_right = lin; + double quad_right = quad; + int new_knot_end = -2; + int end_idx = start_idx_ + len_ - 1; double neg_lam2 = -lambda2; // Algorihtm 2, line 15-25 - for (int knot_idx = end_idx, m = len_; m; --m, --knot_idx) { - - const MsgElt& k = buf[knot_idx]; - double x1 = buf[knot_idx - 1].x_; - - if (k.sgn_) { - lin_right -= k.lin_; + for (int knot_idx = end_idx, m = len_; m; --m, --knot_idx) + { + const MsgElt &k = buf[knot_idx]; + double x1 = buf[knot_idx - 1].x_; + + if (k.sgn_) + { + lin_right -= k.lin_; quad_right -= k.quad_; - } else { - lin_right += k.lin_; + } + else + { + lin_right += k.lin_; quad_right += k.quad_; } double hit_x = (neg_lam2 - lin_right) / (2.0 * quad_right); - if (hit_x > x1) { + if (hit_x > x1) + { // place a knot here - new_knot_end = knot_idx + 1; - back_pointers(bp_idx+1) = hit_x; + new_knot_end = knot_idx + 1; + back_pointers(bp_idx + 1) = hit_x; break; } } // Prepend and append, Algorithm 2 line 26-31 - MsgElt * k0 = &buf[new_knot_start]; - k0->x_ = R_NegInf; - k0->sgn_ = true; - k0->lin_ = lambda2; - k0->quad_ = 0.0; + MsgElt *k0 = &buf[new_knot_start]; + k0->x_ = R_NegInf; + k0->sgn_ = true; + k0->lin_ = lambda2; + k0->quad_ = 0.0; init_knot_ = *k0; k0 = &buf[new_knot_start + 1]; @@ -224,66 +247,78 @@ void Msg::UpdMsg(double lambda2, double lin, double quad, int bp_idx) { k0->lin_ = lin_left - lambda2; k0->quad_ = quad_left; - k0 = &buf[new_knot_end]; - k0->x_ = R_PosInf; - k0->sgn_ = false; - k0->lin_ = -lambda2; - k0->quad_ = 0.0; + k0 = &buf[new_knot_end]; + k0->x_ = R_PosInf; + k0->sgn_ = false; + k0->lin_ = -lambda2; + k0->quad_ = 0.0; end_knot_ = *k0; - k0 = &buf[new_knot_end-1]; - k0->x_ = back_pointers(bp_idx+1); + k0 = &buf[new_knot_end - 1]; + k0->x_ = back_pointers(bp_idx + 1); k0->sgn_ = false; k0->lin_ = lin_right + lambda2; k0->quad_ = quad_right; start_idx_ = new_knot_start; len_ = 1 + new_knot_end - new_knot_start; -} +} -void Msg::UpdMsgOpt(double lambda2, double lin, double quad, int bp_idx) { +void Msg::UpdMsgOpt(double lambda2, double lin, double quad, int bp_idx) +{ // An optimized version - std::vector& buf = buf_; + std::vector &buf = buf_; buf[start_idx_].x_ = R_NegInf; buf[start_idx_ + len_ - 1].x_ = R_PosInf; - double lin_left = lin; - double quad_left = quad; - int new_knot_start = -3; + double lin_left = lin; + double quad_left = quad; + int new_knot_start = -3; - int knot_idx = start_idx_; - const MsgElt * k = &(init_knot_); - double x1 = buf[knot_idx + 1].x_; - if (k->sgn_) { - lin_left += k->lin_; + int knot_idx = start_idx_; + const MsgElt *k = &(init_knot_); + double x1 = buf[knot_idx + 1].x_; + if (k->sgn_) + { + lin_left += k->lin_; quad_left += k->quad_; - } else { - lin_left -= k->lin_; + } + else + { + lin_left -= k->lin_; quad_left -= k->quad_; } double hit_x = (lambda2 - lin_left) / (2.0 * quad_left); - if (hit_x < x1) { + if (hit_x < x1) + { // place a knot here new_knot_start = knot_idx - 1; back_pointers(bp_idx) = hit_x; - } else { + } + else + { ++knot_idx; k = &buf[knot_idx]; - for (; ; ++knot_idx, ++k) { + for (;; ++knot_idx, ++k) + { x1 = k[1].x_; - if (k->sgn_) { - lin_left += k->lin_; + if (k->sgn_) + { + lin_left += k->lin_; quad_left += k->quad_; - } else { - lin_left -= k->lin_; + } + else + { + lin_left -= k->lin_; quad_left -= k->quad_; } hit_x = (lambda2 - lin_left) / (2.0 * quad_left); - if (hit_x < x1) { + if (hit_x < x1) + { // place a knot here new_knot_start = knot_idx - 1; @@ -293,63 +328,73 @@ void Msg::UpdMsgOpt(double lambda2, double lin, double quad, int bp_idx) { } } - double lin_right = lin; - double quad_right = quad; - int new_knot_end = -2; - int end_idx = start_idx_ + len_ - 1; + double lin_right = lin; + double quad_right = quad; + int new_knot_end = -2; + int end_idx = start_idx_ + len_ - 1; double neg_lam2 = -lambda2; knot_idx = end_idx; k = &(end_knot_); - x1 = buf[knot_idx-1].x_; + x1 = buf[knot_idx - 1].x_; - if (k->sgn_) { - lin_right -= k->lin_; + if (k->sgn_) + { + lin_right -= k->lin_; quad_right -= k->quad_; - } else { - lin_right += k->lin_; + } + else + { + lin_right += k->lin_; quad_right += k->quad_; } hit_x = (neg_lam2 - lin_right) / (2.0 * quad_right); - if (hit_x > x1) { + if (hit_x > x1) + { // place a knot here - new_knot_end = knot_idx + 1; - back_pointers(bp_idx+1) = hit_x; - } - else { + new_knot_end = knot_idx + 1; + back_pointers(bp_idx + 1) = hit_x; + } + else + { --knot_idx; k = &buf[knot_idx]; - for (; ; --knot_idx, --k) { + for (;; --knot_idx, --k) + { x1 = k[-1].x_; - if (k->sgn_) { - lin_right -= k->lin_; + if (k->sgn_) + { + lin_right -= k->lin_; quad_right -= k->quad_; - } else { - lin_right += k->lin_; + } + else + { + lin_right += k->lin_; quad_right += k->quad_; } hit_x = (neg_lam2 - lin_right) / (2.0 * quad_right); - if (hit_x > x1) { + if (hit_x > x1) + { // place a knot here - new_knot_end = knot_idx + 1; - back_pointers(bp_idx+1) = hit_x; + new_knot_end = knot_idx + 1; + back_pointers(bp_idx + 1) = hit_x; break; } } } - MsgElt * k0 = &buf[new_knot_start + 1]; - k0->x_ = back_pointers(bp_idx); - k0->sgn_ = true; - k0->lin_ = lin_left - lambda2; - k0->quad_ = quad_left; + MsgElt *k0 = &buf[new_knot_start + 1]; + k0->x_ = back_pointers(bp_idx); + k0->sgn_ = true; + k0->lin_ = lin_left - lambda2; + k0->quad_ = quad_left; - k0 = &buf[new_knot_end-1]; - k0->x_ = back_pointers(bp_idx+1); + k0 = &buf[new_knot_end - 1]; + k0->x_ = back_pointers(bp_idx + 1); k0->sgn_ = false; k0->lin_ = lin_right + lambda2; k0->quad_ = quad_right; @@ -358,40 +403,50 @@ void Msg::UpdMsgOpt(double lambda2, double lin, double quad, int bp_idx) { len_ = 1 + new_knot_end - new_knot_start; } -arma::vec Msg::BackTrace(int seq_len, double last_msg_max) { - +arma::vec Msg::BackTrace(int seq_len, double last_msg_max) +{ arma::vec x_hat(seq_len); double z = x_hat(seq_len - 1) = last_msg_max; - int i = seq_len - 2; + int i = seq_len - 2; - int bp_idx = (2 * (seq_len - 2)); - for (int idx = seq_len-1; idx; --idx, bp_idx -= 2, --i) { - if (z < back_pointers(bp_idx)) { + int bp_idx = (2 * (seq_len - 2)); + for (int idx = seq_len - 1; idx; --idx, bp_idx -= 2, --i) + { + if (z < back_pointers(bp_idx)) + { z = x_hat[i] = back_pointers(bp_idx); - } else if (z > back_pointers(bp_idx+1)) { - z = x_hat[i] = back_pointers(bp_idx+1); - } else { + } + else if (z > back_pointers(bp_idx + 1)) + { + z = x_hat[i] = back_pointers(bp_idx + 1); + } + else + { x_hat[i] = z; } } return x_hat; } -arma::vec myflsadp(const arma::vec& x, double lambda2, int init_buf_sz) { +arma::vec myflsadp(const arma::vec &x, double lambda2, int init_buf_sz) +{ // lambda2 is the penalty level on the difference // of adjacent elements. int seq_len = x.n_elem; - if (lambda2 == 0.0){ + if (lambda2 == 0.0) + { return x; } - if (seq_len < 2) { + if (seq_len < 2) + { MoMALogger::error("Fused lasso: input vector has length less than two"); } int check_freq = 40; - if (init_buf_sz < 30 * check_freq) { + if (init_buf_sz < 30 * check_freq) + { MoMALogger::error("Fused lasso (DP): initial buffer size is too small"); } @@ -403,10 +458,12 @@ arma::vec myflsadp(const arma::vec& x, double lambda2, int init_buf_sz) { msg.UpdMsg(lambda2, x(0), -0.5, 0); MoMALogger::debug("After first UpdMsg"); - for (int j = 1, bp = 2; j < seq_len; ++j, bp += 2, --check_msg) { + for (int j = 1, bp = 2; j < seq_len; ++j, bp += 2, --check_msg) + { msg.UpdMsgOpt(lambda2, x(j), -0.5, bp); // call ShiftMsg periodically - if (!check_msg) { + if (!check_msg) + { check_msg = check_freq - 1; msg.ShiftMsg(check_freq); } @@ -414,4 +471,4 @@ arma::vec myflsadp(const arma::vec& x, double lambda2, int init_buf_sz) { double last_msg_max = msg.Argmax(NULL); return msg.BackTrace(seq_len, last_msg_max); -} +} diff --git a/src/moma_prox_flsadp.h b/src/moma_prox_flsadp.h index 9829422e..33af9c68 100644 --- a/src/moma_prox_flsadp.h +++ b/src/moma_prox_flsadp.h @@ -36,12 +36,13 @@ // in order to explain the algorithm. Avoid explicit // memory management. -// Reference: -// Johnson, Nicholas A. -// "A dynamic programming algorithm for the fused lasso and l 0-segmentation." +// Reference: +// Johnson, Nicholas A. +// "A dynamic programming algorithm for the fused lasso and l 0-segmentation." // Journal of Computational and Graphical Statistics 22.2 (2013): 246-260. -struct MsgElt { +struct MsgElt +{ // the location of the knot double x_; // the sign variable that tells us @@ -55,8 +56,9 @@ struct MsgElt { double quad_; }; -class Msg { -public: +class Msg +{ + public: std::vector buf_; arma::vec back_pointers; int start_idx_; @@ -66,18 +68,20 @@ class Msg { MsgElt end_knot_; void InitMsg(int n, int init_sz, double lin, double quad, double lambda2); - void UpdMsg (double lambda2, double lin, double quad, int bp_idx); + void UpdMsg(double lambda2, double lin, double quad, int bp_idx); void UpdMsgOpt(double lambda2, double lin, double quad, int bp_idx); - double Argmax(double * max_val); + double Argmax(double *max_val); // This data structure supports prepend and append; - // To implement this, first allocate a long array, - // then start filling data in the middle and extend to both ends. Shift + // To implement this, first allocate a long array, + // then start filling data in the middle and extend to both ends. Shift // the space filled with data towards the center of the array periodically void ShiftMsg(int check_freq); arma::vec BackTrace(int seq_len, double last_msg_max); }; -arma::vec myflsadp(const arma::vec& x, double lambda2, int init_buf_sz = MOMA_FUSEDLASSODP_BUFFERSIZE); +arma::vec myflsadp(const arma::vec &x, + double lambda2, + int init_buf_sz = MOMA_FUSEDLASSODP_BUFFERSIZE); #endif // MOMA_PROX_FLSADP diff --git a/src/moma_prox_fusion_util.cpp b/src/moma_prox_fusion_util.cpp index 27562e19..1f4731cc 100644 --- a/src/moma_prox_fusion_util.cpp +++ b/src/moma_prox_fusion_util.cpp @@ -2,56 +2,69 @@ // a non-existing child of the node of a heap is far away #include "moma_prox_fusion_util.h" #include "moma_heap.h" -int sgn(double val){ +int sgn(double val) +{ return (double(0) < val) - (val < double(0)); } // Constructor -FusedGroups::FusedGroups(const arma::vec &x):heap(x.n_elem -1){ +FusedGroups::FusedGroups(const arma::vec &x) : heap(x.n_elem - 1) +{ int n = x.n_elem; - if(n <= 1){ + if (n <= 1) + { MoMALogger::error("TODO: deal with scalar"); } g.resize(n); - + // Initialize `head`, `tail`, `parent`, `lambda` and `beta` - for(int i = 0; i < g.size(); i++){ - g[i] = Group(i,i,i,0,x(i)); + for (int i = 0; i < g.size(); i++) + { + g[i] = Group(i, i, i, 0, x(i)); } // slope - g[0].slope = - sgn(double(x(0) - x(1))); - for(int i = 1; i < g.size()-1; i++){ - double s = - (sgn(x(i)-x(i-1)) + sgn(x(i) - x(i+1))); + g[0].slope = -sgn(double(x(0) - x(1))); + for (int i = 1; i < g.size() - 1; i++) + { + double s = -(sgn(x(i) - x(i - 1)) + sgn(x(i) - x(i + 1))); g[i].slope = s; } - g[n-1].slope = - (sgn(x(n-1) - x(n-2))); + g[n - 1].slope = -(sgn(x(n - 1) - x(n - 2))); // Heap lambda; - for(int i = 0; i < heap.heap_storage.size(); i++){ + for (int i = 0; i < heap.heap_storage.size(); i++) + { // next merge point of group i and i+1 double h = 0; - h = lines_meet_at(0,0,g[i+1].slope,g[i].slope,g[i+1].beta,g[i].beta); - heap.heap_storage[i] = HeapNode(i,h); + h = lines_meet_at(0, 0, g[i + 1].slope, g[i].slope, g[i + 1].beta, g[i].beta); + heap.heap_storage[i] = HeapNode(i, h); } heap.heapify(); - for(int i = 0; i < heap.heap_storage.size(); i++){ - int index_in_g = heap.heap_storage[i].id; + for (int i = 0; i < heap.heap_storage.size(); i++) + { + int index_in_g = heap.heap_storage[i].id; g[index_in_g].map_to_heap = i; } g[n - 1].map_to_heap = NOT_IN_HEAP; return; } -void FusedGroups::print(){ +void FusedGroups::print() +{ MoMALogger::debug("") << "Grouping now is"; - for(int i = 0; i < g.size(); i++){ - if(is_valid(i)){ + for (int i = 0; i < g.size(); i++) + { + if (is_valid(i)) + { g[i].print(); - if(g[i].map_to_heap != NOT_IN_HEAP && g[i].map_to_heap >= heap.heap_storage.size()){ - MoMALogger::error("Exceeds heap limit") << g[i].map_to_heap << "while heap size is " << heap.heap_storage.size(); + if (g[i].map_to_heap != NOT_IN_HEAP && g[i].map_to_heap >= heap.heap_storage.size()) + { + MoMALogger::error("Exceeds heap limit") + << g[i].map_to_heap << "while heap size is " << heap.heap_storage.size(); } } - else{ + else + { MoMALogger::debug("") << "====="; g[i].print(); } @@ -59,52 +72,66 @@ void FusedGroups::print(){ MoMALogger::debug(""); } -bool FusedGroups::is_valid(int this_node){ +bool FusedGroups::is_valid(int this_node) +{ return g[this_node].parent == this_node; } -int FusedGroups::pre_group(int this_group){ - if(!is_valid(this_group)){ +int FusedGroups::pre_group(int this_group) +{ + if (!is_valid(this_group)) + { MoMALogger::error("Only valid groups can be accessed"); } - if(this_group == 0){ + if (this_group == 0) + { return NO_PRE; } - return g[this_group-1].parent; + return g[this_group - 1].parent; } -int FusedGroups::next_group(int this_group){ - if(!is_valid(this_group)){ +int FusedGroups::next_group(int this_group) +{ + if (!is_valid(this_group)) + { MoMALogger::error("Only valid groups be accessed"); } - if(g[this_group].tail == g.size()-1){ + if (g[this_group].tail == g.size() - 1) + { return NO_NEXT; } - else{ + else + { return g[this_group].tail + 1; } } -int FusedGroups::group_size(int this_group){ - if(!is_valid(this_group)){ +int FusedGroups::group_size(int this_group) +{ + if (!is_valid(this_group)) + { MoMALogger::error("Only valid groups be accessed"); } return g[this_group].tail - g[this_group].head + 1; } -// line_value_at evaluates the y-value of a line, -// who has slope is k and goes through point (x,y), +// line_value_at evaluates the y-value of a line, +// who has slope is k and goes through point (x,y), // at x_. -double FusedGroups::line_value_at(double x,double y,double slope,double x_){ +double FusedGroups::line_value_at(double x, double y, double slope, double x_) +{ return y + slope * (x_ - x); } -arma::vec FusedGroups::find_beta_at(double target_lam){ - int n = (this->g).size(); +arma::vec FusedGroups::find_beta_at(double target_lam) +{ + int n = (this->g).size(); arma::vec x = arma::zeros(n); - for(int i = 0; i != NO_NEXT;){ - double betaj = line_value_at(g[i].lambda,g[i].beta,g[i].slope,target_lam); - for(int j = g[i].head; j <= g[i].tail; j++){ + for (int i = 0; i != NO_NEXT;) + { + double betaj = line_value_at(g[i].lambda, g[i].beta, g[i].slope, target_lam); + for (int j = g[i].head; j <= g[i].tail; j++) + { x(j) = betaj; } i = next_group(i); @@ -113,8 +140,15 @@ arma::vec FusedGroups::find_beta_at(double target_lam){ } // Find the x value of the intersection of two lines. -double FusedGroups::lines_meet_at(double x1,double x2,double slope1,double slope2,double y1,double y2){ - if(std::abs(slope1 - slope2) < 1e-10){ +double FusedGroups::lines_meet_at(double x1, + double x2, + double slope1, + double slope2, + double y1, + double y2) +{ + if (std::abs(slope1 - slope2) < 1e-10) + { // Note abs(slope1 - slope2) < 1e-10 // does not work on Linux. return MOMA_INFTY; @@ -122,18 +156,21 @@ double FusedGroups::lines_meet_at(double x1,double x2,double slope1,double slope return ((y1 - y2) - (slope1 * x1 - slope2 * x2)) / (-slope1 + slope2); } -void FusedGroups::merge(){ - +void FusedGroups::merge() +{ HeapNode node = heap.heap_peek_min(); - // Node `dst` will absorb the info of `src` node, `src` will be then marked invalid - int dst = node.id; + // Node `dst` will absorb the info of `src` node, `src` will be then marked + // invalid + int dst = node.id; double new_lambda = node.lambda; - int src = this->next_group(dst); - - if(!is_valid(dst) || src == NO_NEXT){ + int src = this->next_group(dst); + + if (!is_valid(dst) || src == NO_NEXT) + { MoMALogger::error("Only valid groups can be merged: merge point is not valid"); } - if(dst >= src){ + if (dst >= src) + { MoMALogger::error("dst_grp should be in front of src_grp"); } @@ -142,49 +179,55 @@ void FusedGroups::merge(){ // update lambda g[dst].lambda = new_lambda; - - // update slope - int pre_group = this->pre_group(dst); + + // update slope + int pre_group = this->pre_group(dst); int next_group = this->next_group(src); - int sgn1 = 0; - int sgn2 = 0; - if(next_group != NO_NEXT){ + int sgn1 = 0; + int sgn2 = 0; + if (next_group != NO_NEXT) + { sgn2 = sgn(g[dst].beta - g[next_group].beta); } - if(pre_group != NO_PRE){ + if (pre_group != NO_PRE) + { sgn1 = sgn(g[dst].beta - g[pre_group].beta); } g[dst].slope = -1 / double(this->group_size(dst) + this->group_size(src)) * (sgn1 + sgn2); - + // set up pointers - int last_node = g[src].tail; - g[dst].tail = last_node; - g[src].parent = dst; + int last_node = g[src].tail; + g[dst].tail = last_node; + g[src].parent = dst; g[last_node].parent = dst; - + // update heap - if(pre_group != NO_PRE){ - double lambda_pre = lines_meet_at(g[pre_group].lambda,g[dst].lambda, - g[pre_group].slope,g[dst].slope, - g[pre_group].beta,g[dst].beta); + if (pre_group != NO_PRE) + { + double lambda_pre = lines_meet_at(g[pre_group].lambda, g[dst].lambda, g[pre_group].slope, + g[dst].slope, g[pre_group].beta, g[dst].beta); heap.change_lambda_by_id(g[pre_group].map_to_heap, lambda_pre, this); } - if(next_group != NO_NEXT){ - double lambda_next = lines_meet_at(g[next_group].lambda,g[dst].lambda, - g[next_group].slope,g[dst].slope, - g[next_group].beta,g[dst].beta); + if (next_group != NO_NEXT) + { + double lambda_next = lines_meet_at(g[next_group].lambda, g[dst].lambda, g[next_group].slope, + g[dst].slope, g[next_group].beta, g[dst].beta); heap.change_lambda_by_id(g[dst].map_to_heap, lambda_next, this); heap.remove(g[src].map_to_heap, this); - }else{ + } + else + { heap.remove(g[dst].map_to_heap, this); } } -double FusedGroups::next_lambda(){ +double FusedGroups::next_lambda() +{ HeapNode n = heap.heap_peek_min(); return n.lambda; }; -bool FusedGroups::all_merged(){ +bool FusedGroups::all_merged() +{ return heap.is_empty(); }; diff --git a/src/moma_prox_fusion_util.h b/src/moma_prox_fusion_util.h index 2d2ee0f5..78dacebb 100644 --- a/src/moma_prox_fusion_util.h +++ b/src/moma_prox_fusion_util.h @@ -3,8 +3,9 @@ #include "moma_base.h" #include "moma_heap.h" class FusedGroups; -class Group{ -public: +class Group +{ + public: // range of the group, note they are continuous int head; int tail; @@ -18,36 +19,29 @@ class Group{ double slope; int map_to_heap; friend class FusedGroups; - Group(int h=-1, - int t=-1, - int p=-1, - double lambda=-1, - double beta = -1, - double slope = 0):head(h), - tail(t), - parent(p), - lambda(lambda), - beta(beta), - slope(slope){}; - void print(){ - MoMALogger::debug("") - << "[" << head - << "," << tail - << "] map_to_heap: " << map_to_heap - << "(lambda:" << lambda - << ",beta:" << beta - << ",slope: " << slope - << ")"; + Group(int h = -1, + int t = -1, + int p = -1, + double lambda = -1, + double beta = -1, + double slope = 0) + : head(h), tail(t), parent(p), lambda(lambda), beta(beta), slope(slope){}; + void print() + { + MoMALogger::debug("") << "[" << head << "," << tail << "] map_to_heap: " << map_to_heap + << "(lambda:" << lambda << ",beta:" << beta << ",slope: " << slope + << ")"; } }; -class FusedGroups{ -public: - +class FusedGroups +{ + public: // Constructor FusedGroups(const arma::vec &x); - // Merge the next two nodes. - // Note if multiple pairs of nodes is to be merged at the same lambda, only one pair will be merged + // Merge the next two nodes. + // Note if multiple pairs of nodes is to be merged at the same lambda, only + // one pair will be merged void merge(); // Return the next lambda at which merge happens double next_lambda(); @@ -64,19 +58,19 @@ class FusedGroups{ int group_size(int this_group); // Calculation concerning lines - double line_value_at(double x,double y,double slope,double x_); - double lines_meet_at(double x1,double x2,double k1,double k2,double y1,double y2); + double line_value_at(double x, double y, double slope, double x_); + double lines_meet_at(double x1, double x2, double k1, double k2, double y1, double y2); // Some constants // Used when the group includes beta_1 const int NO_PRE = -2; // Used when the group includes beta_p - const int NO_NEXT = -3; + const int NO_NEXT = -3; static const int NOT_IN_HEAP = -4; - // This constant is used in the function - // lines_meet_at, where we might bump - // into situation that the two lines are - // parallel. In order to deal with this, + // This constant is used in the function + // lines_meet_at, where we might bump + // into situation that the two lines are + // parallel. In order to deal with this, // we return MOMA_INFTY. // A vector stroing all the beta values diff --git a/src/moma_prox_l1ft.cpp b/src/moma_prox_l1ft.cpp index 17580346..fe86583c 100644 --- a/src/moma_prox_l1ft.cpp +++ b/src/moma_prox_l1ft.cpp @@ -1,112 +1,134 @@ #include "moma_prox.h" /* -* L1 Trend Filtering -*/ + * L1 Trend Filtering + */ // A second difference matrix // [0 0 ... 1 -2 1 ... 0 0] // [[Rcpp::export]] -arma::mat l1tf_diff_mat(int m, int k){ - if(k < 0){ +arma::mat l1tf_diff_mat(int m, int k) +{ + if (k < 0) + { MoMALogger::error("k should be non-negative integer."); } - if(m < k + 2){ + if (m < k + 2) + { MoMALogger::error("A difference matrix should have more columns."); } - arma::vec coef(k+2); // Note for k = 0, D = [... 1, -1 ...] - // k = 1, D = [... 1, -2, 1 ...] - // k = 2, D = [... 1, -3, 3, -1, ...] - // The (k+1)-th row of the Pascal triangle - coef(0) = std::pow(-1,k); - int flag = -coef(0); - coef(k+1) = -1; - for(int i = 1; i <= (k + 1) / 2; i++){ - coef(i) = -1 * coef(i-1) * (k - i + 2) / i; - coef(k+1-i) = flag * coef(i); + arma::vec coef(k + 2); // Note for k = 0, D = [... 1, -1 ...] + // k = 1, D = [... 1, -2, 1 ...] + // k = 2, D = [... 1, -3, 3, -1, ...] + // The (k+1)-th row of the Pascal triangle + coef(0) = std::pow(-1, k); + int flag = -coef(0); + coef(k + 1) = -1; + for (int i = 1; i <= (k + 1) / 2; i++) + { + coef(i) = -1 * coef(i - 1) * (k - i + 2) / i; + coef(k + 1 - i) = flag * coef(i); } - arma::mat D = arma::zeros(m-1-k,m); - for(int i = 0; i < m-1-k; i++){ - for(int j = 0; j < k + 2; j++){ - D(i,i+j) = coef(j); + arma::mat D = arma::zeros(m - 1 - k, m); + for (int i = 0; i < m - 1 - k; i++) + { + for (int j = 0; j < k + 2; j++) + { + D(i, i + j) = coef(j); } } return D; } -L1TrendFiltering::L1TrendFiltering(int n,int i_k){ - if(i_k >= 2){ +L1TrendFiltering::L1TrendFiltering(int n, int i_k) +{ + if (i_k >= 2) + { MoMALogger::message("TF with higher-than-second difference matrix is not well tested yet."); } - if(n == -1){ + if (n == -1) + { MoMALogger::error("Class L1TrendFiltering needs to know dimension of the problem."); } - D = l1tf_diff_mat(n,i_k); - + D = l1tf_diff_mat(n, i_k); + k = i_k; - MoMALogger::debug("Initializing a L1 linear trend filtering proximal operator object of degree ") - << k - << "."; + MoMALogger::debug( + "Initializing a L1 linear trend filtering proximal operator object of " + "degree ") + << k << "."; } -L1TrendFiltering::~L1TrendFiltering(){ +L1TrendFiltering::~L1TrendFiltering() +{ MoMALogger::debug("Releasing a L1 linear trend filtering proximal operator object"); } // Find the sum of dual residual and centering residual -double res( - const arma::mat &DDt, const arma::vec &Dy, - const arma::vec &mu1,const arma::vec &mu2, - const arma::vec &f1,const arma::vec &f2,double t, - const arma::vec &nu){ - arma::vec res_cent = - (mu1 % f1) - (mu2 % f2) - 1/t; +double res(const arma::mat &DDt, + const arma::vec &Dy, + const arma::vec &mu1, + const arma::vec &mu2, + const arma::vec &f1, + const arma::vec &f2, + double t, + const arma::vec &nu) +{ + arma::vec res_cent = -(mu1 % f1) - (mu2 % f2) - 1 / t; // NOTE: this approximates formulea 16 in the paper arma::vec res_dual = DDt * nu - Dy + mu1 - mu2; return arma::as_scalar(arma::norm(res_cent) + arma::norm(res_dual)); } -double init_stepsize(const arma::vec &mu,const arma::vec &dmu,double step){ - if(step <= 0){ +double init_stepsize(const arma::vec &mu, const arma::vec &dmu, double step) +{ + if (step <= 0) + { MoMALogger::error("step should > 0 in init_stepsize."); } arma::uvec idx = (dmu < 0); - if(arma::sum(idx) > 0){ + if (arma::sum(idx) > 0) + { // the largest step size that does not negate any elements of mu // i.e., max(step) s.t. mu + step * dmu > 0 for all elements arma::vec prop = -(idx % (mu / dmu)); double max_legit_ss = step; - for(int i = 0; i < mu.n_elem; i++){ - if(prop(i) > 0 && prop(i) < max_legit_ss){ + for (int i = 0; i < mu.n_elem; i++) + { + if (prop(i) > 0 && prop(i) < max_legit_ss) + { max_legit_ss = 0.99 * prop(i); } } return max_legit_ss; } - else{ + else + { return step; } } -arma::vec L1TrendFiltering::operator()(const arma::vec &x, double l){ - +arma::vec L1TrendFiltering::operator()(const arma::vec &x, double l) +{ int n = x.n_elem; - int m = n - 1 - k; // # of rows of the diff mat - if(D.n_cols != n || D.n_rows != m){ + int m = n - 1 - k; // # of rows of the diff mat + if (D.n_cols != n || D.n_rows != m) + { MoMALogger::error("Error in initialzing difference matrix."); } - const arma::vec &y = x; + const arma::vec &y = x; // Commonly used mat and vec arma::mat DDt = D * D.t(); - arma::vec Dy = D * y; + arma::vec Dy = D * y; // Step size double step; @@ -114,9 +136,9 @@ arma::vec L1TrendFiltering::operator()(const arma::vec &x, double l){ // Initialzation with a strictly feasible point // Ref: l1 Trend Filtering by Seung-Jean Kim, Kwangmoo Koh // Stephen Boyd and Dimitry Gorinevsky - arma::vec nu = arma::zeros (m); // The dual variable, y - D^t*nu is what we need - arma::vec mu1 = arma::ones (m); // Multipliers to solve the dual problem - arma::vec mu2 = arma::ones (m); + arma::vec nu = arma::zeros(m); // The dual variable, y - D^t*nu is what we need + arma::vec mu1 = arma::ones(m); // Multipliers to solve the dual problem + arma::vec mu2 = arma::ones(m); arma::vec new_nu; arma::vec new_mu1; @@ -136,15 +158,16 @@ arma::vec L1TrendFiltering::operator()(const arma::vec &x, double l){ double gap; int iter = 0; - for(; iter < MAX_ITER; iter++){ - + for (; iter < MAX_ITER; iter++) + { // Surrogate duality gap - // Ref: Primal-Dual Interior-Point Methods, + // Ref: Primal-Dual Interior-Point Methods, // Ryan Tibshirani, Convex Optimization 10-725/36-725 // Powerpoint presentation page 10 // http://www.cs.cmu.edu/~pradeepr/convexopt/Lecture_Slides/primal-dual.pdf - gap = - (sum(mu1 % f1 + mu2 % f2)); - if(gap < prox_eps){ + gap = -(sum(mu1 % f1 + mu2 % f2)); + if (gap < prox_eps) + { break; } @@ -152,22 +175,24 @@ arma::vec L1TrendFiltering::operator()(const arma::vec &x, double l){ // NOTE: this is different from the `l1tf` C implementation t = 4 * m / gap; - arma::mat part1 = DDt - arma::diagmat(mu1/f1+mu2/f2); // A band matrix - arma::vec part2 = -DDt*nu + Dy + (1/t) / f1 - (1/t) / f2; + arma::mat part1 = DDt - arma::diagmat(mu1 / f1 + mu2 / f2); // A band matrix + arma::vec part2 = -DDt * nu + Dy + (1 / t) / f1 - (1 / t) / f2; // Update directions - arma::vec dnu = arma::solve(part1,part2); // RcppArmadillo optimizes with band matrix automatically - arma::vec dmu1 = -(mu1 + ((1/t) + dnu % mu1) / f1); - arma::vec dmu2 = -(mu2 + ((1/t) + dnu % mu2) / f2); + arma::vec dnu = + arma::solve(part1, + part2); // RcppArmadillo optimizes with band matrix automatically + arma::vec dmu1 = -(mu1 + ((1 / t) + dnu % mu1) / f1); + arma::vec dmu2 = -(mu2 + ((1 / t) + dnu % mu2) / f2); // Choose step size by back tracking // Initialize with the largest stepsize not making mu's negative - step = init_stepsize(mu1,dmu1,1); - step = init_stepsize(mu2,dmu2,step); - - for(int iter_bt = 0; iter_bt < MAX_BT_ITER; iter_bt++){ + step = init_stepsize(mu1, dmu1, 1); + step = init_stepsize(mu2, dmu2, step); - new_nu = nu + step * dnu; + for (int iter_bt = 0; iter_bt < MAX_BT_ITER; iter_bt++) + { + new_nu = nu + step * dnu; new_mu1 = mu1 + step * dmu1; new_mu2 = mu2 + step * dmu2; @@ -178,90 +203,106 @@ arma::vec L1TrendFiltering::operator()(const arma::vec &x, double l){ // check step size, exit if all of the conditions are met // 1. f1<0 and f2<0 // 2. loss function should be less than a reference linear function - if(arma::sum(new_f1 > 0) > 0 || arma::sum(new_f2 > 0) > 0 || - res(DDt,Dy,new_mu1,new_mu2,new_f1,new_f2,t,new_nu) >(1 - alpha * step) * res(DDt,Dy,mu1,mu2,f1,f2,t,nu)){ - step *= beta; + if (arma::sum(new_f1 > 0) > 0 || arma::sum(new_f2 > 0) > 0 || + res(DDt, Dy, new_mu1, new_mu2, new_f1, new_f2, t, new_nu) > + (1 - alpha * step) * res(DDt, Dy, mu1, mu2, f1, f2, t, nu)) + { + step *= beta; } - else{ + else + { break; } } MoMALogger::debug("Picking step = ") << step << "."; // Update variable with selected stepsize - nu = new_nu; + nu = new_nu; mu1 = new_mu1; mu2 = new_mu2; - f1 = new_f1; - f2 = new_f2; + f1 = new_f1; + f2 = new_f2; } - if(iter == MAX_ITER){ - MoMALogger::info("No convergence in L1 linear trend filtering solver. Surrogate duality (gap,iter) = ") - << "(" << gap << "," << iter << ")" - << "."; + if (iter == MAX_ITER) + { + MoMALogger::info( + "No convergence in L1 linear trend filtering solver. Surrogate duality " + "(gap,iter) = ") + << "(" << gap << "," << iter << ")" + << "."; } arma::vec Dymm = Dy - (mu1 - mu2); - double dres = 0.5 * arma::as_scalar(Dymm.t() * arma::solve(DDt,Dymm)) + l * arma::sum(mu1+mu2); + double dres = + 0.5 * arma::as_scalar(Dymm.t() * arma::solve(DDt, Dymm)) + l * arma::sum(mu1 + mu2); arma::vec Dtnu = D.t() * nu; - double pres = -0.5 * arma::as_scalar(Dtnu.t() * Dtnu) + arma::as_scalar(Dy.t() * nu); - MoMALogger::debug("Primal loss = ") << pres - << " , dual loss = " << dres - << " , gap = " << pres - dres - << " , surrogate gap = " << gap - << " , iter = " << iter - << "."; + double pres = -0.5 * arma::as_scalar(Dtnu.t() * Dtnu) + arma::as_scalar(Dy.t() * nu); + MoMALogger::debug("Primal loss = ") + << pres << " , dual loss = " << dres << " , gap = " << pres - dres + << " , surrogate gap = " << gap << " , iter = " << iter << "."; return y - D.t() * nu; } -int L1TrendFiltering::df(const arma::vec &x){ - if(k == 0){ +int L1TrendFiltering::df(const arma::vec &x) +{ + if (k == 0) + { MoMALogger::error("Please use fused lasso instead."); } - else if(k == 1){ + else if (k == 1) + { // df = number of knots + k + 1 - // Ref: - // Table 2 of Tibshirani, Robert. - // "Regression shrinkage and selection via the lasso: a retrospective." - // Journal of the Royal Statistical Society: Series B (Statistical Methodology) 73.3 (2011): 273-282. - // D = [... −1 2 −1 ...] - - if(x.n_elem < 3){ + // Ref: + // Table 2 of Tibshirani, Robert. + // "Regression shrinkage and selection via the lasso: a retrospective." + // Journal of the Royal Statistical Society: Series B (Statistical + // Methodology) 73.3 (2011): 273-282. D = [... −1 2 −1 ...] + + if (x.n_elem < 3) + { MoMALogger::error("dim(x) must be larger than 2."); } int knots = 0; - // Count the number of knots (changes in slope in the case of linear trend filtering) - for(int i = 2; i < x.n_elem; i++){ - if(std::abs(x(i-2) - 2 * x(i-1) + x(i)) > 1e-10){ - printf("%d",i); + // Count the number of knots (changes in slope in the case of linear trend + // filtering) + for (int i = 2; i < x.n_elem; i++) + { + if (std::abs(x(i - 2) - 2 * x(i - 1) + x(i)) > 1e-10) + { + printf("%d", i); knots++; } } return knots + k + 1; } - else if(k == 2){ + else if (k == 2) + { // df = number of knots + k + 1 - // Ref: - // Table 2 of Tibshirani, Robert. - // "Regression shrinkage and selection via the lasso: a retrospective." - // Journal of the Royal Statistical Society: Series B (Statistical Methodology) 73.3 (2011): 273-282. - // D = [... 1 -3 3 -1 ...] - - if(x.n_elem < 4){ + // Ref: + // Table 2 of Tibshirani, Robert. + // "Regression shrinkage and selection via the lasso: a retrospective." + // Journal of the Royal Statistical Society: Series B (Statistical + // Methodology) 73.3 (2011): 273-282. D = [... 1 -3 3 -1 ...] + + if (x.n_elem < 4) + { MoMALogger::error("dim(x) must be larger than 3."); } int knots = 0; - // Count the number of knots (changes in second derivative in the case of quadratic trend filtering) - for(int i = 3; i < x.n_elem; i++){ - if(std::abs(x(i-3) - 3 * x(i-2) + 3 * x(i-1) - x(i)) > 1e-10){ + // Count the number of knots (changes in second derivative in the case of + // quadratic trend filtering) + for (int i = 3; i < x.n_elem; i++) + { + if (std::abs(x(i - 3) - 3 * x(i - 2) + 3 * x(i - 1) - x(i)) > 1e-10) + { knots++; } } - + return knots + k + 1; } - else{ + else + { MoMALogger::error("Error in L1TrendFiltering::df: Invalid k."); return 0; } - } diff --git a/src/moma_prox_sortedL1.cpp b/src/moma_prox_sortedL1.cpp index f7adfeab..3b0d280c 100644 --- a/src/moma_prox_sortedL1.cpp +++ b/src/moma_prox_sortedL1.cpp @@ -25,8 +25,12 @@ // M. Bogdan, E. van den Berg, W. Su, and E.J. Candes // http://statweb.stanford.edu/~candes/SortedL1/ -int evaluateProx(const arma::vec &y, const arma::vec &lambda, arma::vec &x, int n, const arma::uvec &order) -{ +int evaluateProx(const arma::vec &y, + const arma::vec &lambda, + arma::vec &x, + int n, + const arma::uvec &order) +{ double d; arma::vec s(n); @@ -34,7 +38,7 @@ int evaluateProx(const arma::vec &y, const arma::vec &lambda, arma::vec &x, int arma::uvec idx_i(n); arma::uvec idx_j(n); - int i,j,k; + int i, j, k; k = 0; for (i = 0; i < n; i++) @@ -43,29 +47,30 @@ int evaluateProx(const arma::vec &y, const arma::vec &lambda, arma::vec &x, int idx_j(k) = i; s(k) = y(i) - lambda(i); w(k) = s(k); - - while ((k > 0) && (w[k-1] <= w(k))) - { - k --; + + while ((k > 0) && (w[k - 1] <= w(k))) + { + k--; idx_j(k) = i; - s(k) += s[k+1]; - w(k) = s(k) / (i - idx_i(k) + 1); + s(k) += s[k + 1]; + w(k) = s(k) / (i - idx_i(k) + 1); } - + k++; } - + for (j = 0; j < k; j++) - { - d = w(j); - if (d < 0){ + { + d = w(j); + if (d < 0) + { d = 0; - } + } for (i = idx_i(j); i <= idx_j(j); i++) - { + { x[order(i)] = d; } } - - return 0; + + return 0; } diff --git a/src/moma_prox_sortedL1.h b/src/moma_prox_sortedL1.h index 1853a016..b845c208 100644 --- a/src/moma_prox_sortedL1.h +++ b/src/moma_prox_sortedL1.h @@ -23,5 +23,9 @@ #include "moma_base.h" -int evaluateProx(const arma::vec &y, const arma::vec &lambda, arma::vec &x, int n, const arma::uvec &order); +int evaluateProx(const arma::vec &y, + const arma::vec &lambda, + arma::vec &x, + int n, + const arma::uvec &order); #endif // MOMA_PROX_SORTEDL1 diff --git a/src/moma_solver.cpp b/src/moma_solver.cpp index 612ea9c2..79273dcb 100644 --- a/src/moma_solver.cpp +++ b/src/moma_solver.cpp @@ -1,40 +1,50 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- +// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; +// -*- #include "moma_solver.h" // A handle class // Penalized regression solver // min_u || y - u || + lambda * P(u) s.t. || u ||_S <= 1 // S = I + alpha * Omega -arma::vec _PR_solver::normalize(const arma::vec &u){ +arma::vec _PR_solver::normalize(const arma::vec &u) +{ arma::vec res = u; - double mn = is_S_idmat ? arma::norm(u) : arma::as_scalar(arma::sqrt(u.t() * S * u)); - if(mn > 0){ + double mn = is_S_idmat ? arma::norm(u) : arma::as_scalar(arma::sqrt(u.t() * S * u)); + if (mn > 0) + { res /= mn; - }else{ + } + else + { res.zeros(); } return res; } -int _PR_solver::check_cnvrg(){ - if(iter >= MAX_ITER){ +int _PR_solver::check_cnvrg() +{ + if (iter >= MAX_ITER) + { MoMALogger::warning("No convergence in _PR_solver!"); } return 0; } -_PR_solver::_PR_solver( - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - double i_EPS, int i_MAX_ITER, int i_dim): - dim(i_dim), - lambda(i_lambda), - alpha(i_alpha), - Omega(i_Omega), // reference to the matrix on the R side, no extra copy - p(prox_arg_list,i_dim), - EPS(i_EPS), - MAX_ITER(i_MAX_ITER){ - +_PR_solver::_PR_solver(double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + double i_EPS, + int i_MAX_ITER, + int i_dim) + : dim(i_dim), + lambda(i_lambda), + alpha(i_alpha), + Omega(i_Omega), // reference to the matrix on the R side, no extra copy + p(prox_arg_list, i_dim), + EPS(i_EPS), + MAX_ITER(i_MAX_ITER) +{ // Step 1b: Calculate leading eigenvalues of smoothing matrices // -> used for prox gradient step sizes S.eye(arma::size(Omega)); @@ -43,25 +53,33 @@ _PR_solver::_PR_solver( grad_step_size = 1 / L; prox_step_size = lambda / L; - is_S_idmat = (alpha == 0.0); - tol = 1; - iter = 0; + is_S_idmat = (alpha == 0.0); + tol = 1; + iter = 0; } -arma::vec _PR_solver::g( - const arma::vec &v, const arma::vec &y, - double step_size, const arma::mat &S, bool is_S_idmat){ +arma::vec _PR_solver::g(const arma::vec &v, + const arma::vec &y, + double step_size, + const arma::mat &S, + bool is_S_idmat) +{ arma::vec res; - if(is_S_idmat){ + if (is_S_idmat) + { res = v + step_size * (y - v); - }else{ - res = v + step_size * (y - S*v); + } + else + { + res = v + step_size * (y - S * v); } return res; } -int _PR_solver::reset(double new_lambda, double new_alpha){ - if(new_alpha != alpha){ +int _PR_solver::reset(double new_lambda, double new_alpha) +{ + if (new_alpha != alpha) + { // avoid re-calculating L // enter only when alpha is changed S.eye(arma::size(S)); @@ -71,187 +89,203 @@ int _PR_solver::reset(double new_lambda, double new_alpha){ grad_step_size = 1 / L; prox_step_size = new_lambda / L; } - else if(lambda != new_lambda){ + else if (lambda != new_lambda) + { prox_step_size = new_lambda / L; } - lambda = new_lambda; - alpha = new_alpha; + lambda = new_lambda; + alpha = new_alpha; is_S_idmat = (new_alpha == 0.0); return 0; } -double _PR_solver::bic(arma::vec y, const arma::vec &est){ +double _PR_solver::bic(arma::vec y, const arma::vec &est) +{ // Find out the bic of the following estimator: - // argmin_x || y - x || + lambda P(x) s.t. || x ||_S <= 1, S = I + alpah * Omega. - // It is approximated by - // log{1/2n * squared error} + log(n)/n * df + const - // NOTE: We ignore the effect of smoothing matrix Omega. + // argmin_x || y - x || + lambda P(x) s.t. || x ||_S <= 1, S = I + alpah * + // Omega. It is approximated by log{1/2n * squared error} + log(n)/n * df + + // const NOTE: We ignore the effect of smoothing matrix Omega. - // Ref: Proposition 2 in - // Allen, Genevera I. - // "Sparse and functional principal components analysis." + // Ref: Proposition 2 in + // Allen, Genevera I. + // "Sparse and functional principal components analysis." // arXiv preprint arXiv:1309.2895 (2013). double res = arma::norm(y - est); double df = p.df(est); MoMALogger::debug("(RES, DF) = （") << res << ", " << df << ")."; - if(res == 0.0) { + if (res == 0.0) + { MoMALogger::warning("BIC = -infty due to zero resdiual."); } - return std::log(res * res / dim) + std::log(dim) / dim * df; // ignore some constants here + return std::log(res * res / dim) + std::log(dim) / dim * df; // ignore some constants here } -arma::vec ISTA::solve(arma::vec y, const arma::vec &start_point){ - if(start_point.n_elem != S.n_cols || y.n_elem != S.n_cols){ - MoMALogger::error("Wrong dimension in PRsolver::solve:") << start_point.n_elem << ":" << S.n_cols; +arma::vec ISTA::solve(arma::vec y, const arma::vec &start_point) +{ + if (start_point.n_elem != S.n_cols || y.n_elem != S.n_cols) + { + MoMALogger::error("Wrong dimension in PRsolver::solve:") + << start_point.n_elem << ":" << S.n_cols; } - tol = 1; - iter = 0; + tol = 1; + iter = 0; arma::vec u = start_point; - arma::vec oldu; // store working result + arma::vec oldu; // store working result while (tol > EPS && iter < MAX_ITER) { iter++; oldu = u; - u = g(u,y,grad_step_size,S,is_S_idmat); - u = p(u,prox_step_size); + u = g(u, y, grad_step_size, S, is_S_idmat); + u = p(u, prox_step_size); double old_norm = arma::norm(oldu); double diff_norm = arma::norm(u - oldu); - if(old_norm != 0.0) + if (old_norm != 0.0) tol = diff_norm / old_norm; - else{ + else + { tol = diff_norm; } - if(iter % 1000 == 0){ - MoMALogger::debug("Solving PR: No.") << iter << "--"<< tol; + if (iter % 1000 == 0) + { + MoMALogger::debug("Solving PR: No.") << iter << "--" << tol; } } u = normalize(u); - - MoMALogger::debug("Finish solving PR: (total_iter, tol) = ") << - "(" << iter << "," << tol << ")"; + + MoMALogger::debug("Finish solving PR: (total_iter, tol) = ") + << "(" << iter << "," << tol << ")"; check_cnvrg(); return u; } -arma::vec FISTA::solve(arma::vec y, const arma::vec &start_point){ - if(start_point.n_elem != S.n_cols || y.n_elem != S.n_cols){ +arma::vec FISTA::solve(arma::vec y, const arma::vec &start_point) +{ + if (start_point.n_elem != S.n_cols || y.n_elem != S.n_cols) + { MoMALogger::error("Wrong dimension in PRsolver::solve"); } - tol = 1; - iter = 0; - arma::vec u = start_point; + tol = 1; + iter = 0; + arma::vec u = start_point; arma::vec newu = start_point; - arma::vec oldu; // store working result + arma::vec oldu; // store working result - double t = 1; + double t = 1; while (tol > EPS && iter < MAX_ITER) { iter++; - oldu = u; + oldu = u; double oldt = t; - t = 0.5 * (1 + std::sqrt(1 + 4 * oldt*oldt)); + t = 0.5 * (1 + std::sqrt(1 + 4 * oldt * oldt)); - u = g(newu,y,grad_step_size,S,is_S_idmat); - u = p(u,prox_step_size); + u = g(newu, y, grad_step_size, S, is_S_idmat); + u = p(u, prox_step_size); newu = u + (oldt - 1) / t * (u - oldu); double old_norm = arma::norm(oldu); double diff_norm = arma::norm(u - oldu); - if(old_norm != 0.0) + if (old_norm != 0.0) tol = diff_norm / old_norm; - else{ + else + { tol = diff_norm; } - if(iter % 1000 == 0){ - MoMALogger::debug("Solving PR: No.") << iter << "--"<< tol; + if (iter % 1000 == 0) + { + MoMALogger::debug("Solving PR: No.") << iter << "--" << tol; } } u = normalize(u); - + check_cnvrg(); - MoMALogger::debug("Finish solving PR: (total_iter, tol) = ") << - "(" << iter << "," << tol << ")"; + MoMALogger::debug("Finish solving PR: (total_iter, tol) = ") + << "(" << iter << "," << tol << ")"; return u; } -arma::vec OneStepISTA::solve(arma::vec y, const arma::vec &start_point){ - if(start_point.n_elem != S.n_cols || y.n_elem != S.n_cols){ +arma::vec OneStepISTA::solve(arma::vec y, const arma::vec &start_point) +{ + if (start_point.n_elem != S.n_cols || y.n_elem != S.n_cols) + { MoMALogger::error("Wrong dimension in PRsolver::solve"); } - tol = 1; - iter = 0; + tol = 1; + iter = 0; arma::vec u = start_point; - arma::vec oldu; // store working result + arma::vec oldu; // store working result while (tol > EPS && iter < MAX_ITER) { iter++; oldu = u; - u = g(u,y,grad_step_size,S,is_S_idmat); - u = p(u,prox_step_size); + u = g(u, y, grad_step_size, S, is_S_idmat); + u = p(u, prox_step_size); u = normalize(u); double old_norm = arma::norm(oldu); double diff_norm = arma::norm(u - oldu); - if(old_norm != 0.0) + if (old_norm != 0.0) tol = diff_norm / old_norm; - else{ + else + { tol = diff_norm; } - if(iter % 1000 == 0){ - MoMALogger::debug("Solving PR: No.") << iter << "--"<< tol; + if (iter % 1000 == 0) + { + MoMALogger::debug("Solving PR: No.") << iter << "--" << tol; } } - + check_cnvrg(); - MoMALogger::debug("Finish solving PR: (total_iter, tol) = ") << - "(" << iter << "," << tol << ")"; + MoMALogger::debug("Finish solving PR: (total_iter, tol) = ") + << "(" << iter << "," << tol << ")"; return u; } -PR_solver::PR_solver( - const std::string &algorithm_string, - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - double i_EPS, int i_MAX_ITER, int dim){ - - if (algorithm_string.compare("ISTA") == 0){ - prs = new ISTA( - i_alpha,i_Omega, - i_lambda,prox_arg_list, - i_EPS,i_MAX_ITER,dim); +PR_solver::PR_solver(const std::string &algorithm_string, + double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + double i_EPS, + int i_MAX_ITER, + int dim) +{ + if (algorithm_string.compare("ISTA") == 0) + { + prs = new ISTA(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim); } - else if (algorithm_string.compare("FISTA") == 0){ - prs = new FISTA( - i_alpha,i_Omega, - i_lambda,prox_arg_list, - i_EPS,i_MAX_ITER,dim); + else if (algorithm_string.compare("FISTA") == 0) + { + prs = new FISTA(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim); } - else if (algorithm_string.compare("ONESTEPISTA") == 0){ - prs = new OneStepISTA( - i_alpha,i_Omega, - i_lambda,prox_arg_list, - i_EPS,i_MAX_ITER,dim); + else if (algorithm_string.compare("ONESTEPISTA") == 0) + { + prs = new OneStepISTA(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim); } - else{ + else + { MoMALogger::error("Your choice of algorithm not provided: ") << algorithm_string; } }; -arma::vec PR_solver::solve(arma::vec y, const arma::vec &start_point){ - return (*prs).solve(y,start_point); +arma::vec PR_solver::solve(arma::vec y, const arma::vec &start_point) +{ + return (*prs).solve(y, start_point); } - -int PR_solver::reset(double new_lambda, double new_alpha){ - return (*prs).reset(new_lambda,new_alpha); + +int PR_solver::reset(double new_lambda, double new_alpha) +{ + return (*prs).reset(new_lambda, new_alpha); } -double PR_solver::bic(arma::vec y, const arma::vec &est){ - return (*prs).bic(y,est); +double PR_solver::bic(arma::vec y, const arma::vec &est) +{ + return (*prs).bic(y, est); } diff --git a/src/moma_solver.h b/src/moma_solver.h index 47c5ce1a..0a497a8f 100644 --- a/src/moma_solver.h +++ b/src/moma_solver.h @@ -1,4 +1,5 @@ -// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- +// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; +// -*- #ifndef MOMA_SOLVER #define MOMA_SOLVER 1 @@ -10,18 +11,17 @@ // Penalized regression solver // min_u || y - u || + lambda * P(u) s.t. || u ||_S <= 1 // S = I + alpha * Omega -class _PR_solver{ - -protected: - int dim; // dimension of the PR problem +class _PR_solver +{ + protected: + int dim; // dimension of the PR problem double lambda; double alpha; double L; const arma::mat Ω // S = I + alpha * Omega for u, v smoothing arma::mat S; - bool is_S_idmat; // indicator of alpha == 0.0 <=> S == I - + bool is_S_idmat; // indicator of alpha == 0.0 <=> S == I // Step size for proximal gradient algorithm // - since this is a linear model internally, we can used a fixed @@ -33,12 +33,13 @@ class _PR_solver{ // Note that currently the threshold level is not defined in the Prox object ProxOp p; // A gradient operator - arma::vec g( - const arma::vec &v, const arma::vec &y, - double step_size, const arma::mat &S, bool is_S_idmat); + arma::vec g(const arma::vec &v, + const arma::vec &y, + double step_size, + const arma::mat &S, + bool is_S_idmat); arma::vec normalize(const arma::vec &u); - // user-specified precision and max iterations double EPS; int MAX_ITER; @@ -47,91 +48,105 @@ class _PR_solver{ int iter; int check_cnvrg(); -public: + public: explicit _PR_solver( // smoothness - double i_alpha, const arma::mat &i_Omega, + double i_alpha, + const arma::mat &i_Omega, // sparsity - double i_lambda, Rcpp::List prox_arg_list, + double i_lambda, + Rcpp::List prox_arg_list, // algorithm settings - double i_EPS, int i_MAX_ITER, int i_dim); + double i_EPS, + int i_MAX_ITER, + int i_dim); // Used when solving for a bunch of lambda's and alpha's int reset(double new_lambda, double new_alpha); double bic(arma::vec y, const arma::vec &est); - virtual ~_PR_solver() = default; + virtual ~_PR_solver() = default; virtual arma::vec solve(arma::vec y, const arma::vec &start_point) = 0; }; -class ISTA: public _PR_solver{ -public: - ISTA( - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - double i_EPS, int i_MAX_ITER, int dim) - : _PR_solver(i_alpha,i_Omega,i_lambda,prox_arg_list,i_EPS,i_MAX_ITER,dim) +class ISTA : public _PR_solver +{ + public: + ISTA(double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + double i_EPS, + int i_MAX_ITER, + int dim) + : _PR_solver(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim) { MoMALogger::debug("Initializing a ISTA solver."); }; - arma::vec solve(arma::vec y,const arma::vec &start_point); - ~ISTA(){ - MoMALogger::debug("Releasing a ISTA object"); - } + arma::vec solve(arma::vec y, const arma::vec &start_point); + ~ISTA() { MoMALogger::debug("Releasing a ISTA object"); } }; -class FISTA: public _PR_solver{ -public: - FISTA( - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - double i_EPS, int i_MAX_ITER, int dim) - : _PR_solver(i_alpha,i_Omega,i_lambda,prox_arg_list,i_EPS,i_MAX_ITER,dim) +class FISTA : public _PR_solver +{ + public: + FISTA(double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + double i_EPS, + int i_MAX_ITER, + int dim) + : _PR_solver(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim) { MoMALogger::debug("Initializing a FISTA solver."); }; - arma::vec solve(arma::vec y,const arma::vec &start_point); - ~FISTA(){ - MoMALogger::debug("Releasing a FISTA object"); - } + arma::vec solve(arma::vec y, const arma::vec &start_point); + ~FISTA() { MoMALogger::debug("Releasing a FISTA object"); } }; -class OneStepISTA: public _PR_solver{ -public: - OneStepISTA( - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - double i_EPS, int i_MAX_ITER, int dim) - : _PR_solver(i_alpha,i_Omega,i_lambda,prox_arg_list,i_EPS,i_MAX_ITER,dim) +class OneStepISTA : public _PR_solver +{ + public: + OneStepISTA(double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + double i_EPS, + int i_MAX_ITER, + int dim) + : _PR_solver(i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, dim) { MoMALogger::debug("Initializing an one-step ISTA solver."); }; - arma::vec solve(arma::vec y,const arma::vec &start_point); - ~OneStepISTA(){ - MoMALogger::debug("Releasing a OneStepISTA object"); - } + arma::vec solve(arma::vec y, const arma::vec &start_point); + ~OneStepISTA() { MoMALogger::debug("Releasing a OneStepISTA object"); } }; // A handle class -class PR_solver{ -private: +class PR_solver +{ + private: _PR_solver *prs; -public: + + public: PR_solver( // a string saying which algorithm to use const std::string &algorithm_string, // same as class _PR_solver - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - double i_EPS, int i_MAX_ITER, int dim); + double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + double i_EPS, + int i_MAX_ITER, + int dim); // wrap operations in _PR_solver class arma::vec solve(arma::vec y, const arma::vec &start_point); double bic(arma::vec y, const arma::vec &est); int reset(double new_lambda, double new_alpha); - ~PR_solver(){ - delete prs; - } + ~PR_solver() { delete prs; } }; #endif diff --git a/src/moma_solver_BICsearch.cpp b/src/moma_solver_BICsearch.cpp index 51c625a5..fe04d03c 100644 --- a/src/moma_solver_BICsearch.cpp +++ b/src/moma_solver_BICsearch.cpp @@ -3,7 +3,7 @@ void BIC_searcher::bind(PR_solver *object, Criterion method) { pr_solver = object; - cri = method; + cri = method; } double BIC_searcher::cur_criterion(arma::vec y, const arma::vec &est) @@ -11,35 +11,30 @@ double BIC_searcher::cur_criterion(arma::vec y, const arma::vec &est) return (pr_solver->*cri)(y, est); } - - -Rcpp::List BIC_searcher::search( - const arma::vec &y, // min_{u} || y - u || + ...penalty... - const arma::vec &initial_u, // start point - const arma::vec &alpha_u, - const arma::vec &lambda_u -) +Rcpp::List BIC_searcher::search(const arma::vec &y, // min_{u} || y - u || + ...penalty... + const arma::vec &initial_u, // start point + const arma::vec &alpha_u, + const arma::vec &lambda_u) { - arma::vec working_selected_u; arma::vec working_u = initial_u; double working_bic_u; double minbic_u = MOMA_INFTY; double opt_alpha_u; double opt_lambda_u; - for(int i = 0; i < alpha_u.n_elem; i++){ - for(int j = 0; j < lambda_u.n_elem; j++){ - + for (int i = 0; i < alpha_u.n_elem; i++) + { + for (int j = 0; j < lambda_u.n_elem; j++) + { // Put lambda_u in the inner loop to avoid reconstructing S many times - pr_solver->reset(lambda_u(j),alpha_u(i)); + pr_solver->reset(lambda_u(j), alpha_u(i)); working_u = pr_solver->solve(y, working_u); working_bic_u = cur_criterion(y, working_u); - MoMALogger::debug("(curBIC, minBIC, lambda, alpha) = (") - << working_bic_u << "," - << minbic_u << "," - << lambda_u(j) << "," - << alpha_u(i) << ")"; - if(working_bic_u < minbic_u){ + MoMALogger::debug("(curBIC, minBIC, lambda, alpha) = (") + << working_bic_u << "," << minbic_u << "," << lambda_u(j) << "," << alpha_u(i) + << ")"; + if (working_bic_u < minbic_u) + { minbic_u = working_bic_u; working_selected_u = working_u; opt_lambda_u = lambda_u(j); @@ -47,15 +42,10 @@ Rcpp::List BIC_searcher::search( } } } - MoMALogger::message("BIC = ") << minbic_u << - ", chosen (alpha,lambda) = (" << opt_alpha_u << - ", " << opt_lambda_u << ")."; + MoMALogger::message("BIC = ") << minbic_u << ", chosen (alpha,lambda) = (" << opt_alpha_u + << ", " << opt_lambda_u << ")."; return Rcpp::List::create( - Rcpp::Named("lambda") = opt_lambda_u, - Rcpp::Named("alpha") = opt_alpha_u, - Rcpp::Named("vector") = working_selected_u, - Rcpp::Named("bic") = minbic_u); -}; - - + Rcpp::Named("lambda") = opt_lambda_u, Rcpp::Named("alpha") = opt_alpha_u, + Rcpp::Named("vector") = working_selected_u, Rcpp::Named("bic") = minbic_u); +}; diff --git a/src/moma_solver_BICsearch.h b/src/moma_solver_BICsearch.h index 3b400241..28096562 100644 --- a/src/moma_solver_BICsearch.h +++ b/src/moma_solver_BICsearch.h @@ -8,9 +8,8 @@ class BIC_searcher { -public: - - typedef double(PR_solver:: *Criterion)(arma::vec y, const arma::vec &est); + public: + typedef double (PR_solver::*Criterion)(arma::vec y, const arma::vec &est); BIC_searcher(){}; void bind(PR_solver *object, Criterion method); @@ -18,17 +17,18 @@ class BIC_searcher // current criterion double cur_criterion(arma::vec y, const arma::vec &est); - ~BIC_searcher(){ + ~BIC_searcher() + { // No need to delete pr_solver MoMALogger::debug("Releasing a BIC_searcher object"); } - Rcpp::List search(const arma::vec &y, // min_{u} || y - u || + ...penalty... - const arma::vec &u, // start point + Rcpp::List search(const arma::vec &y, // min_{u} || y - u || + ...penalty... + const arma::vec &u, // start point const arma::vec &alpha_u, const arma::vec &lambda_u); -private: + private: PR_solver *pr_solver; Criterion cri; }; diff --git a/src/moma_test_expose.cpp b/src/moma_test_expose.cpp index 40239bc7..6dd6c691 100644 --- a/src/moma_test_expose.cpp +++ b/src/moma_test_expose.cpp @@ -1,122 +1,126 @@ -# include "moma_prox.h" -# include "moma_solver.h" -# include "moma.h" +#include "moma.h" +#include "moma_prox.h" +#include "moma_solver.h" // [[Rcpp::export]] arma::vec test_prox_lasso(const arma::vec &x, double l) { Lasso a; - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_nnlasso(const arma::vec &x, double l) { NonNegativeLasso a; - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_scad(const arma::vec &x, double l, double gamma = 3.7) { SCAD a(gamma); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_scadvec(const arma::vec &x, double l, double gamma = 3.7) { - SCAD a(gamma); - return a.vec_prox(x,l); + return a.vec_prox(x, l); } // [[Rcpp::export]] arma::vec test_prox_nnscad(const arma::vec &x, double l, double gamma = 3.7) { NonNegativeSCAD a(gamma); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_mcp(const arma::vec &x, double l, double gamma = 4) { MCP a(gamma); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_mcpvec(const arma::vec &x, double l, double gamma = 4) { MCP a(gamma); - return a.vec_prox(x,l); + return a.vec_prox(x, l); } // [[Rcpp::export]] arma::vec test_prox_nnmcp(const arma::vec &x, double l, double gamma = 4) { NonNegativeMCP a(gamma); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_grplasso(const arma::vec &x, const arma::vec &g, double l) { GrpLasso a(g); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] arma::vec test_prox_nngrplasso(const arma::vec &x, const arma::vec &g, double l) { NonNegativeGrpLasso a(g); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] -arma::vec test_prox_fusedlassopath(const arma::vec &x,double l) +arma::vec test_prox_fusedlassopath(const arma::vec &x, double l) { OrderedFusedLasso a; - return a(x,l); + return a(x, l); } // [[Rcpp::export]] -arma::vec test_prox_fusedlassodp(const arma::vec &x,double l) +arma::vec test_prox_fusedlassodp(const arma::vec &x, double l) { OrderedFusedLassoDP a; - return a(x,l); + return a(x, l); } // [[Rcpp::export]] -arma::vec test_prox_spfusedlasso(const arma::vec &x,double l,double lambda2) +arma::vec test_prox_spfusedlasso(const arma::vec &x, double l, double lambda2) { // lambda2: the level of penalty on // the absolute values of the coefficients SparseFusedLasso a(lambda2); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] -arma::vec test_prox_fusion(const arma::vec &x,double l,const arma::mat w,bool ADMM,bool acc,double prox_eps=1e-10) +arma::vec test_prox_fusion(const arma::vec &x, + double l, + const arma::mat w, + bool ADMM, + bool acc, + double prox_eps = 1e-10) { - Fusion a(w,ADMM,acc,prox_eps); - return a(x,l); + Fusion a(w, ADMM, acc, prox_eps); + return a(x, l); } // [[Rcpp::export]] -arma::vec test_prox_l1gf(const arma::vec &x,double l,int k = 1) +arma::vec test_prox_l1gf(const arma::vec &x, double l, int k = 1) { - L1TrendFiltering a(x.n_elem,k); - return a(x,l); + L1TrendFiltering a(x.n_elem, k); + return a(x, l); } // [[Rcpp::export]] -arma::vec test_prox_slope(const arma::vec &x,double l) +arma::vec test_prox_slope(const arma::vec &x, double l) { // lambda2: the level of penalty on // the absolute values of the coefficients SLOPE a(x.n_elem); - return a(x,l); + return a(x, l); } // [[Rcpp::export]] @@ -137,9 +141,9 @@ int test_df_spfusedlasso(const arma::vec &x) } // [[Rcpp::export]] -int test_df_l1gf(const arma::vec &x,int k = 1) +int test_df_l1gf(const arma::vec &x, int k = 1) { - L1TrendFiltering a(x.n_elem,k); + L1TrendFiltering a(x.n_elem, k); return a.df(x); } @@ -151,20 +155,19 @@ int test_df_grplasso(const arma::vec &x, const arma::vec &g) } // [[Rcpp::export]] -double test_BIC( - const arma::vec y, const arma::vec y_est, - const std::string &algorithm_string, - double i_alpha, const arma::mat &i_Omega, - double i_lambda, Rcpp::List prox_arg_list, - int dim, - double i_EPS=1e-6, int i_MAX_ITER=1e+3) +double test_BIC(const arma::vec y, + const arma::vec y_est, + const std::string &algorithm_string, + double i_alpha, + const arma::mat &i_Omega, + double i_lambda, + Rcpp::List prox_arg_list, + int dim, + double i_EPS = 1e-6, + int i_MAX_ITER = 1e+3) { - - PR_solver solver( - algorithm_string, - i_alpha, i_Omega, - i_lambda, prox_arg_list, - i_EPS, i_MAX_ITER, dim); + PR_solver solver(algorithm_string, i_alpha, i_Omega, i_lambda, prox_arg_list, i_EPS, i_MAX_ITER, + dim); return solver.bic(y, y_est); } @@ -172,10 +175,10 @@ double test_BIC( // This function solves a squence of lambda's and alpha's // [[Rcpp::export]] Rcpp::List testnestedBIC( - const arma::mat &X, // We should not change any variable in R, so const ref + const arma::mat &X, // We should not change any variable in R, so const ref const arma::vec &alpha_u, const arma::vec &alpha_v, - const arma::mat &Omega_u, // Default values for these matrices should be set in R + const arma::mat &Omega_u, // Default values for these matrices should be set in R const arma::mat &Omega_v, const arma::vec &lambda_u, const arma::vec &lambda_v, @@ -186,42 +189,33 @@ Rcpp::List testnestedBIC( double EPS_inner, long MAX_ITER_inner, std::string solver, - int selection_criterion_alpha_u, // flags; = 0 means grid, = 1 means BIC search + int selection_criterion_alpha_u, // 0 means grid, 1 means BIC search int selection_criterion_alpha_v, int selection_criterion_lambda_u, int selection_criterion_lambda_v, - int k = 1){ - - + int k = 1) +{ int n_lambda_u = lambda_u.n_elem; int n_lambda_v = lambda_v.n_elem; - int n_alpha_u = alpha_u.n_elem; - int n_alpha_v = alpha_v.n_elem; + int n_alpha_u = alpha_u.n_elem; + int n_alpha_v = alpha_v.n_elem; - if(n_lambda_v == 0 || n_lambda_u == 0 || n_alpha_u == 0 || n_alpha_v == 0){ + if (n_lambda_v == 0 || n_lambda_u == 0 || n_alpha_u == 0 || n_alpha_v == 0) + { MoMALogger::error("Please specify all four parameters."); } // NOTE: arguments should be listed // in the exact order of MoMA constructor MoMA problem(X, - /* sparsity */ - lambda_u(0), - lambda_v(0), - prox_arg_list_u, - prox_arg_list_v, - /* smoothness */ - alpha_u(0), - alpha_v(0), - Omega_u, - Omega_v, - /* algorithm parameters */ - EPS, - MAX_ITER, - EPS_inner, - MAX_ITER_inner, - solver); - return problem.grid_BIC_mix(alpha_u,alpha_v,lambda_u,lambda_v, - selection_criterion_alpha_u,selection_criterion_alpha_v,selection_criterion_lambda_u,selection_criterion_lambda_v); + /* sparsity */ + lambda_u(0), lambda_v(0), prox_arg_list_u, prox_arg_list_v, + /* smoothness */ + alpha_u(0), alpha_v(0), Omega_u, Omega_v, + /* algorithm parameters */ + EPS, MAX_ITER, EPS_inner, MAX_ITER_inner, solver); + return problem.grid_BIC_mix(alpha_u, alpha_v, lambda_u, lambda_v, selection_criterion_alpha_u, + selection_criterion_alpha_v, selection_criterion_lambda_u, + selection_criterion_lambda_v); // return problem.select_nestedBIC(alpha_u,alpha_v,lambda_u,lambda_v,5); } From 7fa32a89afaa8be69d8d11042e3a254e3e21724f Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Sun, 23 Jun 2019 16:18:14 +0800 Subject: [PATCH 4/7] add shell script for R files format check (failure expected) --- script/diff_generator.sh | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/script/diff_generator.sh b/script/diff_generator.sh index 6b636bc6..1fd7b526 100644 --- a/script/diff_generator.sh +++ b/script/diff_generator.sh @@ -19,7 +19,7 @@ elif [[ ${OS} = "Darwin" ]] ; then NPROC=$(sysctl -n hw.physicalcpu) fi -# macs does not have clang-foramt pre-installed +# macos does not have clang-foramt pre-installed if [[ $OS = "Darwin" ]] ; then brew install clang-format fi @@ -40,5 +40,15 @@ else exit 1 fi +# Format cpp/h files inplace. +# If all files are well-formated, then there +# should be no changes. find ./src -type f -name '*.h' -o -name '*.cpp' \ | xargs -I{} -P ${NPROC} ${CLANG_FORMAT} -i -style=file {} + +# Format R files inplace. +# If all files are well-formated, then there +# should be no changes. +Rscript -e "install.packages(\"styler\");\ + library(\"styler\"); \ + style_dir(transformers=tidyverse_style(indent_by=4), exclude_files=\"./R/RcppExports.R\");" From b0684fbfdffd2ec4f8131bd9e6a7ef0fcf049f65 Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Sun, 23 Jun 2019 16:46:23 +0800 Subject: [PATCH 5/7] format R code using rstyler (this should fix the error) --- R/internals.R | 15 +- R/logging.R | 61 +-- R/moma_4Dlist_extractor.R | 40 +- R/moma_arguments.R | 90 ++-- R/moma_svd.R | 205 ++++---- R/sfpca.R | 38 +- R/zzz.R | 16 +- build_steps.R | 24 +- tests/testthat/helper_moma_tests.R | 21 +- tests/testthat/test_4Dlist_extractor.R | 136 +++--- tests/testthat/test_BIC.R | 16 +- tests/testthat/test_BIC_gird_mixed.R | 279 ++++++----- tests/testthat/test_SLOPE.R | 24 +- tests/testthat/test_arguments.R | 511 +++++++++++++------- tests/testthat/test_dof.R | 72 +-- tests/testthat/test_fused_lasso.R | 90 ++-- tests/testthat/test_grid.R | 54 ++- tests/testthat/test_l1tf.R | 170 ++++--- tests/testthat/test_logging.R | 38 +- tests/testthat/test_sfpca.R | 113 ++--- tests/testthat/test_sparse_fused_lasso.R | 20 +- tests/testthat/test_sparsity_thresholding.R | 157 +++--- tests/testthat/test_unordered_fusion.R | 140 +++--- 23 files changed, 1322 insertions(+), 1008 deletions(-) diff --git a/R/internals.R b/R/internals.R index bbaddf4e..475bb3de 100644 --- a/R/internals.R +++ b/R/internals.R @@ -1,11 +1,11 @@ #' @importFrom utils packageDescription -moma_git_hash <- function(){ +moma_git_hash <- function() { pd <- packageDescription("moma") - gh_file <- system.file("GIT.HASH", package="moma") + gh_file <- system.file("GIT.HASH", package = "moma") - if(!is.null(pd$RemoteSha)){ # devtools install + if (!is.null(pd$RemoteSha)) { # devtools install return(pd$RemoteSha) - } else if(file.exists(gh_file)){ + } else if (file.exists(gh_file)) { return(readLines(gh_file)) } else { NA @@ -22,13 +22,13 @@ moma_git_hash <- function(){ #' only. #' @export #' @importFrom utils sessionInfo -moma_session_info <- function(){ - old_print <- options(max.print=9999) +moma_session_info <- function() { + old_print <- options(max.print = 9999) on.exit(options(old_print)) cat("MoMA Git Hash: ", moma_git_hash(), "\n") - if(requireNamespace("devtools")){ + if (requireNamespace("devtools")) { print(devtools::session_info("moma")) } else { print(sessionInfo()) @@ -36,4 +36,3 @@ moma_session_info <- function(){ invisible(NULL) } - diff --git a/R/logging.R b/R/logging.R index 89aaeefc..4297aacc 100644 --- a/R/logging.R +++ b/R/logging.R @@ -1,11 +1,13 @@ # Logging infrastructure for MoMA ## This must be kept consistent with src/moma_logging.h::MoMAoggerLevel -LEVELS <- c(ERROR = 40, - WARNING = 30, - MESSAGE = 20, - INFO = 10, - DEBUG = 00) +LEVELS <- c( + ERROR = 40, + WARNING = 30, + MESSAGE = 20, + INFO = 10, + DEBUG = 00 +) #' MoMA Package Logging Functionality @@ -34,19 +36,20 @@ LEVELS <- c(ERROR = 40, #' \code{moma_logger_level} function can be used to adjust the global #' log level. The \code{INFO} and \code{DEBUG} levels can be quite verbose #' and may significantly slow down the package. -moma_logger_level <- function(level=c("ERROR", - "WARNING", - "MESSAGE", - "INFO", - "DEBUG")){ - +moma_logger_level <- function(level = c( + "ERROR", + "WARNING", + "MESSAGE", + "INFO", + "DEBUG" + )) { LEVELS_REV <- setNames(names(LEVELS), LEVELS) old_level <- LEVELS_REV[as.character(moma_get_logger_level_cpp())] names(old_level) <- NULL - if(!missing(level)){ - level <- match.arg(level); + if (!missing(level)) { + level <- match.arg(level) moma_set_logger_level_cpp(LEVELS[level]) return(invisible(old_level)) } @@ -54,47 +57,47 @@ moma_logger_level <- function(level=c("ERROR", old_level } -moma_error <- function(..., call=TRUE){ - msg <- paste(list(...), collapse="") +moma_error <- function(..., call = TRUE) { + msg <- paste(list(...), collapse = "") ## Try to add R level calling info - if(identical(call, TRUE)){ + if (identical(call, TRUE)) { tryCatch({ msg <- paste0(msg, " (Called from ", as.character(as.list(sys.call(-1))[[1]]), ")") - }, error=function(e){}) - } else if(is.character(call)){ + }, error = function(e) {}) + } else if (is.character(call)) { msg <- paste0(msg, " (Called from ", call, ")") } moma_log_cpp(LEVELS["ERROR"], msg) } -moma_warning <- function(..., call=TRUE){ - msg <- paste(list(...), collapse="") +moma_warning <- function(..., call = TRUE) { + msg <- paste(list(...), collapse = "") ## Try to add R level calling info - if(identical(call, TRUE)){ + if (identical(call, TRUE)) { tryCatch({ msg <- paste0(msg, " (Called from ", as.character(as.list(sys.call(-1))[[1]]), ")") - }, error=function(e){}) - } else if(is.character(call)){ + }, error = function(e) {}) + } else if (is.character(call)) { msg <- paste0(msg, " (Called from ", call, ")") } moma_log_cpp(LEVELS["WARNING"], msg) } -moma_message <- function(...){ - msg <- paste(list(...), collapse="") +moma_message <- function(...) { + msg <- paste(list(...), collapse = "") moma_log_cpp(LEVELS["MESSAGE"], msg) } -moma_info <- function(...){ - msg <- paste(list(...), collapse="") +moma_info <- function(...) { + msg <- paste(list(...), collapse = "") moma_log_cpp(LEVELS["INFO"], msg) } -moma_debug <- function(...){ - msg <- paste(list(...), collapse="") +moma_debug <- function(...) { + msg <- paste(list(...), collapse = "") moma_log_cpp(LEVELS["DEBUG"], msg) } diff --git a/R/moma_4Dlist_extractor.R b/R/moma_4Dlist_extractor.R index e845936b..34f9474b 100644 --- a/R/moma_4Dlist_extractor.R +++ b/R/moma_4Dlist_extractor.R @@ -1,25 +1,27 @@ -get_4Dlist_elem <- function(x, alpha_u_i, lambda_u_i, alpha_v_i, lambda_v_i){ - if(!inherits(x, "MoMA_4D_list")){ +get_4Dlist_elem <- function(x, alpha_u_i, lambda_u_i, alpha_v_i, lambda_v_i) { + if (!inherits(x, "MoMA_4D_list")) { moma_error(sQuote("x"), " should be a ", sQuote("MoMA_4D_list"), " object.") } - n_alpha_u = dim(x)[1] - n_lambda_u = dim(x)[2] - n_alpha_v = dim(x)[3] - n_lambda_v = dim(x)[4] + n_alpha_u <- dim(x)[1] + n_lambda_u <- dim(x)[2] + n_alpha_v <- dim(x)[3] + n_lambda_v <- dim(x)[4] # NOTE: R index starts from 1 - if( - alpha_u_i <= 0 || alpha_u_i > n_alpha_u || - lambda_u_i <= 0 || lambda_u_i > n_lambda_u || - alpha_v_i <= 0 || alpha_v_i > n_alpha_v || - lambda_v_i <= 0 || lambda_v_i > n_lambda_v - ){ - moma_error("Invalid index (",alpha_u_i, ",", lambda_u_i, - ",",alpha_v_i, ",",lambda_v_i,"), dim = ", - dim(x)) + if ( + alpha_u_i <= 0 || alpha_u_i > n_alpha_u || + lambda_u_i <= 0 || lambda_u_i > n_lambda_u || + alpha_v_i <= 0 || alpha_v_i > n_alpha_v || + lambda_v_i <= 0 || lambda_v_i > n_lambda_v + ) { + moma_error( + "Invalid index (", alpha_u_i, ",", lambda_u_i, + ",", alpha_v_i, ",", lambda_v_i, "), dim = ", + dim(x) + ) } - return(x[n_lambda_u * n_alpha_v * n_lambda_v * (alpha_u_i-1) + - n_alpha_v * n_lambda_v * (lambda_u_i-1) + - n_lambda_v * (alpha_v_i-1) + - lambda_v_i]) + return(x[n_lambda_u * n_alpha_v * n_lambda_v * (alpha_u_i - 1) + + n_alpha_v * n_lambda_v * (lambda_u_i - 1) + + n_lambda_v * (alpha_v_i - 1) + + lambda_v_i]) } diff --git a/R/moma_arguments.R b/R/moma_arguments.R index 4a9930ab..38e33279 100644 --- a/R/moma_arguments.R +++ b/R/moma_arguments.R @@ -1,9 +1,9 @@ # Check whether `x` is a boolean value -is_logical_scalar <- function(x){ +is_logical_scalar <- function(x) { return(is.logical(x) && (length(x) == 1) && !is.na(x)) } -empty <- function(){ +empty <- function() { arglist <- list() class(arglist) <- "moma_sparsity" return(arglist) @@ -22,13 +22,12 @@ empty <- function(){ #' #' @examples #' lasso(non_negative = FALSE) -#' #' @export -lasso <- function(non_negative = FALSE){ - if(!is_logical_scalar(non_negative)){ +lasso <- function(non_negative = FALSE) { + if (!is_logical_scalar(non_negative)) { moma_error(sQuote("non_negative"), " should be a boolean value.") } - arglist <- list(nonneg = non_negative,P = "LASSO") + arglist <- list(nonneg = non_negative, P = "LASSO") class(arglist) <- "moma_sparsity" return(arglist) } @@ -50,16 +49,17 @@ lasso <- function(non_negative = FALSE){ #' #' @examples #' mcp(gamma = 3, non_negative = FALSE) -#' #' @export -mcp <- function(gamma = 3, non_negative = FALSE){ - if(!is_logical_scalar(non_negative)){ +mcp <- function(gamma = 3, non_negative = FALSE) { + if (!is_logical_scalar(non_negative)) { moma_error(sQuote("non_negative"), " should be a boolean value.") } - if(gamma <= 1){ - moma_error("Non-convexity parameter of MCP (", - sQuote("gamma"), - ") must be larger than 1.") + if (gamma <= 1) { + moma_error( + "Non-convexity parameter of MCP (", + sQuote("gamma"), + ") must be larger than 1." + ) } arglist <- list(gamma = gamma, nonneg = non_negative, P = "MCP") class(arglist) <- "moma_sparsity" @@ -84,16 +84,17 @@ mcp <- function(gamma = 3, non_negative = FALSE){ #' #' @examples #' scad(gamma = 3.7, non_negative = FALSE) -#' #' @export -scad <- function(gamma = 3.7, non_negative = FALSE){ - if(!is_logical_scalar(non_negative)){ +scad <- function(gamma = 3.7, non_negative = FALSE) { + if (!is_logical_scalar(non_negative)) { moma_error(sQuote("non_negative"), " should be a boolean value.") } - if(gamma <= 2){ - moma_error("Non-convexity parameter of SCAD (", - sQuote("gamma"), - ") must be larger than 2.") + if (gamma <= 2) { + moma_error( + "Non-convexity parameter of SCAD (", + sQuote("gamma"), + ") must be larger than 2." + ) } arglist <- list(gamma = gamma, nonneg = non_negative, P = "SCAD") class(arglist) <- "moma_sparsity" @@ -106,16 +107,15 @@ scad <- function(gamma = 3.7, non_negative = FALSE){ #' \deqn{\lambda P (x) = \lambda \sum _ { i = 1 } ^ { n } \lambda _ { i } | x | _ { ( i ) } .} #' where \eqn{\lambda_i = \Phi ^ { - 1 } ( 1 - q _ { i } ) , q _ { i } = i \cdot q / 2 p, q = 0.05.} #' Here \eqn{q} is the false discovery rate (FDR). -#' See Bogdan, Malgorzata, et al. "SLOPE - adaptive variable selection via convex optimization." +#' See Bogdan, Malgorzata, et al. "SLOPE - adaptive variable selection via convex optimization." #' The annals of applied statistics 9.3 (2015): 1103. #' #' @return a \code{moma_sparsity} object, which contains a list containing the string "SLOPE". #' #' @examples #' slope() -#' #' @export -slope <- function(){ +slope <- function() { arglist <- list(P = "SLOPE") class(arglist) <- "moma_sparsity" return(arglist) @@ -138,14 +138,13 @@ slope <- function(){ #' #' @examples #' # This sets every three adjacent parameters as a group. -#' grplasso(g = rep(1:10,each = 3), non_negative = FALSE) -#' +#' grplasso(g = rep(1:10, each = 3), non_negative = FALSE) #' @export -grplasso <- function(g, non_negative = FALSE){ - if(!is_logical_scalar(non_negative)){ +grplasso <- function(g, non_negative = FALSE) { + if (!is_logical_scalar(non_negative)) { moma_error(sQuote("non_negative"), " should be a boolean value.") } - if(!(inherits(g,c("character","numeric","factor","integer")))){ + if (!(inherits(g, c("character", "numeric", "factor", "integer")))) { moma_error("Please provide a vector as an indicator of grouping.") } arglist <- list(group = as.factor(g), P = "GRPLASSO", nonneg = non_negative) @@ -173,9 +172,8 @@ grplasso <- function(g, non_negative = FALSE){ #' #' @examples #' fusedlasso() -#' #' @export -fusedlasso <- function(algo=c("path","dp")){ +fusedlasso <- function(algo = c("path", "dp")) { # fused lasso # Two options for solving the proximal operator @@ -183,7 +181,7 @@ fusedlasso <- function(algo=c("path","dp")){ # "dp": dynamic programming # "path": solution path-based algorithm algo <- match.arg(algo) - prox_name = ifelse(algo=="path","ORDEREDFUSED","ORDEREDFUSEDDP") + prox_name <- ifelse(algo == "path", "ORDEREDFUSED", "ORDEREDFUSEDDP") arglist <- list(P = prox_name) class(arglist) <- "moma_sparsity" return(arglist) @@ -212,12 +210,11 @@ fusedlasso <- function(algo=c("path","dp")){ #' @return a \code{moma_sparsity} object, which is an empty list. #' #' @examples -#' l1tf(l1tf_k=1) -#' +#' l1tf(l1tf_k = 1) #' @export -l1tf <- function(l1tf_k=1){ +l1tf <- function(l1tf_k = 1) { # l1 linear trend filtering - arglist <- list(P = "L1TRENDFILTERING",l1tf_k = l1tf_k) + arglist <- list(P = "L1TRENDFILTERING", l1tf_k = l1tf_k) class(arglist) <- "moma_sparsity" return(arglist) } @@ -235,10 +232,9 @@ l1tf <- function(l1tf_k=1){ #' #' @examples #' spfusedlasso(lambda2 = 2) -#' #' @export -spfusedlasso <- function(lambda2){ - arglist <- list(P = "SPARSEFUSEDLASSO",lambda2 = lambda2) +spfusedlasso <- function(lambda2) { + arglist <- list(P = "SPARSEFUSEDLASSO", lambda2 = lambda2) class(arglist) <- "moma_sparsity" return(arglist) } @@ -259,23 +255,23 @@ spfusedlasso <- function(lambda2){ #' \code{ADMM}, \code{acc} and \code{eps}. #' #' @examples -#' cluster(w = matrix(rep(1,9),3), ADMM = FALSE, acc = FALSE, eps = 1e-10) -#' +#' cluster(w = matrix(rep(1, 9), 3), ADMM = FALSE, acc = FALSE, eps = 1e-10) #' @export -cluster <- function(w = NULL,ADMM = FALSE, +cluster <- function(w = NULL, ADMM = FALSE, acc = FALSE, - eps = 1e-10){ + eps = 1e-10) { # fused lasso - if(!is.matrix(w) || is.null(w) || dim(w)[1] != dim(w)[2]){ + if (!is.matrix(w) || is.null(w) || dim(w)[1] != dim(w)[2]) { moma_error("`w` should be a square matrix.") } - if(!isSymmetric(w)){ + if (!isSymmetric(w)) { moma_warning("`w` is not symmetric. Only upper triangular half is used.") } arglist <- list( - w = w, ADMM = ADMM, - acc = acc, prox_eps = eps, - P = "UNORDEREDFUSION") + w = w, ADMM = ADMM, + acc = acc, prox_eps = eps, + P = "UNORDEREDFUSION" + ) class(arglist) <- "moma_sparsity" return(arglist) } diff --git a/R/moma_svd.R b/R/moma_svd.R index 07aca256..65d9217b 100644 --- a/R/moma_svd.R +++ b/R/moma_svd.R @@ -1,27 +1,28 @@ MOMA_EMPTYMAT <- matrix() -MOMA_EMPTYVEC <- vector(mode="numeric") +MOMA_EMPTYVEC <- vector(mode = "numeric") MOMA_DEFAULT_PROX <- list( - P = "NONE", - gamma = 3, - # non-negativity - nonneg = FALSE, - # grouping - group = MOMA_EMPTYVEC, - lambda2 = 0, - # unordered fusion - w = MOMA_EMPTYMAT, - ADMM = FALSE, - acc = FALSE, - prox_eps = 1e-10, - # trend filtering - l1tf_k = 1) -add_default_prox_args <- function(sparsity_type){ + P = "NONE", + gamma = 3, + # non-negativity + nonneg = FALSE, + # grouping + group = MOMA_EMPTYVEC, + lambda2 = 0, + # unordered fusion + w = MOMA_EMPTYMAT, + ADMM = FALSE, + acc = FALSE, + prox_eps = 1e-10, + # trend filtering + l1tf_k = 1 +) +add_default_prox_args <- function(sparsity_type) { # sparsity_type: prox arguments for u and v # To call a C function we have to specify # all arguments. However, some arguments # are specific for a particular prox. So - # we first assign a default arg list to + # we first assign a default arg list to # `df_prox_arg_list_u/_v` and # then update them. return(modifyList(MOMA_DEFAULT_PROX, sparsity_type)) @@ -29,68 +30,75 @@ add_default_prox_args <- function(sparsity_type){ # This function checks the validity of Omega and alpha -check_omega <- function(Omega,alpha,n){ - if(length(alpha) == 1 && alpha == 0){ +check_omega <- function(Omega, alpha, n) { + if (length(alpha) == 1 && alpha == 0) { # discard the Omega matrix specified by users Omega <- diag(n) } - else if(is.null(Omega)){ + else if (is.null(Omega)) { # The user wants smooth penalty # but does not specify Omega matrix Omega <- second_diff_mat(n) } - else{ + else { # Check validity of Omega if users speicify both alpha and Omega - if(dim(Omega)[1] != dim(Omega)[2]){ - moma_error("Omega shoud be a square matrix: nrows = ",dim(Omega)[1], - ", ncols = ",dim(Omega)[2]) + if (dim(Omega)[1] != dim(Omega)[2]) { + moma_error( + "Omega shoud be a square matrix: nrows = ", dim(Omega)[1], + ", ncols = ", dim(Omega)[2] + ) } - if(dim(Omega)[1] != n){ - moma_error("Omega shoud be a compatible matrix. It should be of ", - n,"x",n, - ", but is actually ",dim(Omega)[1],"x",dim(Omega)[1]) + if (dim(Omega)[1] != n) { + moma_error( + "Omega shoud be a compatible matrix. It should be of ", + n, "x", n, + ", but is actually ", dim(Omega)[1], "x", dim(Omega)[1] + ) } } return(Omega) } -second_diff_mat <- function(n){ +second_diff_mat <- function(n) { return(crossprod(diff(diag(n)))) } moma_svd <- function( - X, - u_sparsity=empty(),v_sparsity=empty(),lambda_u=0,lambda_v=0, # lambda_u/_v is a vector or scalar - Omega_u=NULL,Omega_v=NULL,alpha_u=0,alpha_v=0, # so is alpha_u/_v - EPS = 1e-10, MAX_ITER = 1000, - EPS_inner = 1e-10,MAX_ITER_inner = 1e+5, - solver = "ista", - k = 1, # number of pairs of singular vecters - select = c("gridsearch","nestedBIC")){ - - if(!inherits(alpha_u,c("numeric","integer")) || - !inherits(alpha_v,c("numeric","integer")) || - !inherits(lambda_u,c("numeric","integer")) || - !inherits(lambda_v,c("numeric","integer"))){ - moma_error(paste0("All penalty levels (", - sQuote("lambda_u"),", ", - sQuote("lambda_v"),", ", - sQuote("alpha_u"),", ", - sQuote("alpha_v"), - ") must be numeric.")) - } + X, + u_sparsity = empty(), v_sparsity = empty(), lambda_u = 0, lambda_v = 0, # lambda_u/_v is a vector or scalar + Omega_u = NULL, Omega_v = NULL, alpha_u = 0, alpha_v = 0, # so is alpha_u/_v + EPS = 1e-10, MAX_ITER = 1000, + EPS_inner = 1e-10, MAX_ITER_inner = 1e+5, + solver = "ista", + k = 1, # number of pairs of singular vecters + select = c("gridsearch", "nestedBIC")) { + if (!inherits(alpha_u, c("numeric", "integer")) || + !inherits(alpha_v, c("numeric", "integer")) || + !inherits(lambda_u, c("numeric", "integer")) || + !inherits(lambda_v, c("numeric", "integer"))) { + moma_error(paste0( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), + ") must be numeric." + )) + } select <- match.arg(select) - all_para <- c(alpha_u,alpha_v,lambda_u,lambda_v) + all_para <- c(alpha_u, alpha_v, lambda_u, lambda_v) # verify all alphas and lambdas are positive numbers - if(sum(all_para < 0) > 0 || sum(!is.finite(all_para)) > 0){ - moma_error("All penalty levels (", - sQuote("lambda_u"),", ", - sQuote("lambda_v"),", ", - sQuote("alpha_u"),", ", - sQuote("alpha_v"), - ") must be non-negative numeric.") + if (sum(all_para < 0) > 0 || sum(!is.finite(all_para)) > 0) { + moma_error( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), + ") must be non-negative numeric." + ) } # from scalar to vector @@ -102,24 +110,25 @@ moma_svd <- function( # update argument lists # GP loop argument algo_settings_list <- list( - X = X, - lambda_u = lambda_u, - lambda_v = lambda_v, - # smoothness - alpha_u = alpha_u, - alpha_v = alpha_v, - # algorithm parameters - EPS = EPS, - MAX_ITER = MAX_ITER, - EPS_inner = EPS_inner, - MAX_ITER_inner = MAX_ITER_inner, - solver = toupper(solver), - k = k) - - if (!is.matrix(X)){ + X = X, + lambda_u = lambda_u, + lambda_v = lambda_v, + # smoothness + alpha_u = alpha_u, + alpha_v = alpha_v, + # algorithm parameters + EPS = EPS, + MAX_ITER = MAX_ITER, + EPS_inner = EPS_inner, + MAX_ITER_inner = MAX_ITER_inner, + solver = toupper(solver), + k = k + ) + + if (!is.matrix(X)) { moma_error("X must be a matrix.") } - if (sum(!is.finite(X)) >= 1){ + if (sum(!is.finite(X)) >= 1) { moma_error("X must not have NaN, NA, or Inf.") } n <- dim(X)[1] @@ -128,50 +137,54 @@ moma_svd <- function( # If all of alpha_u, alpha_v, lambda_u, lambda_v are # a number, we just solve ONE MoMA problem. is_multiple_para <- length(alpha_u) > 1 || - length(alpha_v) > 1 || - length(lambda_u) > 1 || - length(lambda_v) > 1 + length(alpha_v) > 1 || + length(lambda_u) > 1 || + length(lambda_v) > 1 # k must be 1 if alpha_u/v or lambda_u/v is of vector form - if(is_multiple_para && k != 1){ + if (is_multiple_para && k != 1) { moma_error("We don't support a range of parameters in finding a rank-k svd") } # Sparsity arguments # "moma_sparsity" includes all penalty types, including fused lasso # group lasso and so on. - if(!inherits(u_sparsity,"moma_sparsity") || !inherits(v_sparsity,"moma_sparsity")){ - moma_error("Sparse penalty should be of class ", - sQuote("moma_sparsity"), - ". Try using, for example, `u_sparsity = lasso()`.") + if (!inherits(u_sparsity, "moma_sparsity") || !inherits(v_sparsity, "moma_sparsity")) { + moma_error( + "Sparse penalty should be of class ", + sQuote("moma_sparsity"), + ". Try using, for example, `u_sparsity = lasso()`." + ) } # Pack all argument into a list # First we check the smoothness term argument. algo_settings_list <- c( - algo_settings_list, - list( - Omega_u = check_omega(Omega_u,alpha_u,n), - Omega_v = check_omega(Omega_v,alpha_v,p), - prox_arg_list_u = add_default_prox_args(u_sparsity), - prox_arg_list_v = add_default_prox_args(v_sparsity))) - - if(is_multiple_para){ - if(select == "gridsearch"){ - a <- do.call("cpp_sfpca_grid",algo_settings_list) + algo_settings_list, + list( + Omega_u = check_omega(Omega_u, alpha_u, n), + Omega_v = check_omega(Omega_v, alpha_v, p), + prox_arg_list_u = add_default_prox_args(u_sparsity), + prox_arg_list_v = add_default_prox_args(v_sparsity) + ) + ) + + if (is_multiple_para) { + if (select == "gridsearch") { + a <- do.call("cpp_sfpca_grid", algo_settings_list) class(a) <- "moma_svd_grid" return(a) } - else if(select == "nestedBIC"){ - a <- do.call("cpp_sfpca_nestedBIC",algo_settings_list) + else if (select == "nestedBIC") { + a <- do.call("cpp_sfpca_nestedBIC", algo_settings_list) class(a) <- "moma_svd_nestedBIC" return(a) } - else{ + else { moma_error("Wrong parameter selection methods!") } } - else{ - return(do.call("cpp_sfpca",algo_settings_list)) + else { + return(do.call("cpp_sfpca", algo_settings_list)) } } diff --git a/R/sfpca.R b/R/sfpca.R index 3000d78e..f34904e2 100644 --- a/R/sfpca.R +++ b/R/sfpca.R @@ -2,10 +2,10 @@ sfpca <- function(X, # sparsity P_v = "none", P_u = "none", - lambda_v = 0, # a vector or scalar, same for lambda_u, alpha_u/v + lambda_v = 0, # a vector or scalar, same for lambda_u, alpha_u/v lambda_u = 0, - gamma_v=3, - gamma_u=3, + gamma_v = 3, + gamma_u = 3, # non-negativity nonneg_u = FALSE, nonneg_v = FALSE, @@ -13,7 +13,7 @@ sfpca <- function(X, group_u = MOMA_EMPTYVEC, group_v = MOMA_EMPTYVEC, # sparse fused lasso - lambda2_u = 0, # penalty on the abs value of parameters + lambda2_u = 0, # penalty on the abs value of parameters lambda2_v = 0, # unordered fusion w_u = MOMA_EMPTYMAT, @@ -38,8 +38,8 @@ sfpca <- function(X, EPS_inner = 1e-10, MAX_ITER_inner = 1e+5, solver = "ista", - k = 1){ - if (!is.null(X) && !is.matrix(X)){ + k = 1) { + if (!is.null(X) && !is.matrix(X)) { moma_error("X must be a matrix.") } n <- dim(X)[1] @@ -55,8 +55,8 @@ sfpca <- function(X, lambda_u <- as.vector(lambda_u) lambda_v <- as.vector(lambda_v) - Omega_u <- if(is.null(Omega_u)) diag(dim(X)[1]) else Omega_u - Omega_v <- if(is.null(Omega_v)) diag(dim(X)[2]) else Omega_v + Omega_u <- if (is.null(Omega_u)) diag(dim(X)[1]) else Omega_u + Omega_v <- if (is.null(Omega_v)) diag(dim(X)[2]) else Omega_v prox_arg_list_u <- list( w = w_u, @@ -88,14 +88,16 @@ sfpca <- function(X, nonneg = nonneg_v, group = group_v ) - return(cpp_sfpca(X = X, - alpha_u = alpha_u,alpha_v = alpha_v, - Omega_u = Omega_u,Omega_v = Omega_v, - lambda_u = lambda_u,lambda_v = lambda_v, - prox_arg_list_u = prox_arg_list_u, - prox_arg_list_v = prox_arg_list_v, - EPS = EPS,MAX_ITER = MAX_ITER, - EPS_inner = EPS_inner,MAX_ITER_inner = MAX_ITER_inner, - solver = solver, - k = k)) + return(cpp_sfpca( + X = X, + alpha_u = alpha_u, alpha_v = alpha_v, + Omega_u = Omega_u, Omega_v = Omega_v, + lambda_u = lambda_u, lambda_v = lambda_v, + prox_arg_list_u = prox_arg_list_u, + prox_arg_list_v = prox_arg_list_v, + EPS = EPS, MAX_ITER = MAX_ITER, + EPS_inner = EPS_inner, MAX_ITER_inner = MAX_ITER_inner, + solver = solver, + k = k + )) } diff --git a/R/zzz.R b/R/zzz.R index 41333d8f..8e2774b8 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,10 +1,12 @@ .onAttach <- function(...) { # nocov start - if(interactive()){ - msg <- c("Thank you for using MoMA!", - "The current logging level is", - sQuote(paste0(moma_logger_level(), ".")), - "To change this, see ?moma_logging.") + if (interactive()) { + msg <- c( + "Thank you for using MoMA!", + "The current logging level is", + sQuote(paste0(moma_logger_level(), ".")), + "To change this, see ?moma_logging." + ) - packageStartupMessage(paste(msg, collapse=" ")) + packageStartupMessage(paste(msg, collapse = " ")) } -} # nocov end +} # nocov end diff --git a/build_steps.R b/build_steps.R index 93c7a813..24b3cb06 100644 --- a/build_steps.R +++ b/build_steps.R @@ -1,26 +1,28 @@ -before_install <- function(){ +before_install <- function() { ## Build various bits of autogenerated code install.packages(c("devtools", "roxygen2", "testthat", "rmarkdown")) - devtools::install_deps(dependencies=c("Depends", "Imports", "LinkingTo"), - quiet=FALSE, upgrade=TRUE) + devtools::install_deps( + dependencies = c("Depends", "Imports", "LinkingTo"), + quiet = FALSE, upgrade = TRUE + ) roxygen2::roxygenize() - Rcpp::compileAttributes(verbose=TRUE) + Rcpp::compileAttributes(verbose = TRUE) devtools::document() ## GitHash as used by moma:::moma_git_hash() - dir.create("inst", showWarnings=FALSE) - writeLines(system("git rev-parse HEAD", intern=TRUE), "inst/GIT.HASH") + dir.create("inst", showWarnings = FALSE) + writeLines(system("git rev-parse HEAD", intern = TRUE), "inst/GIT.HASH") ## Write custom dictionary words - dir.create(".aspell", showWarnings=FALSE) + dir.create(".aspell", showWarnings = FALSE) saveRDS(c("ArXiv"), ".aspell/moma.rds") } -after_success <- function(){ +after_success <- function() { devtools::install() rmarkdown::render("README.Rmd") - unlink(Sys.glob("moma.Rcheck"), recursive=TRUE, force=TRUE) - unlink(Sys.glob("moma*.tar.gz"), recursive=TRUE, force=TRUE) + unlink(Sys.glob("moma.Rcheck"), recursive = TRUE, force = TRUE) + unlink(Sys.glob("moma*.tar.gz"), recursive = TRUE, force = TRUE) file.rename(".gitignore.deploy", ".gitignore") - unlink(Sys.glob("src/*o"), force=TRUE) + unlink(Sys.glob("src/*o"), force = TRUE) } diff --git a/tests/testthat/helper_moma_tests.R b/tests/testthat/helper_moma_tests.R index 8a02a02f..988301a3 100644 --- a/tests/testthat/helper_moma_tests.R +++ b/tests/testthat/helper_moma_tests.R @@ -1,22 +1,23 @@ library(MoMA) library(stringr) -expect_no_error <- function(object, ..., all=FALSE, info=NULL, label=NULL){ - expect_error(object, regexp=NA, ..., all=all, info=info, label=label) +expect_no_error <- function(object, ..., all = FALSE, info = NULL, label = NULL) { + expect_error(object, regexp = NA, ..., all = all, info = info, label = label) } -expect_no_warning <- function(object, ..., all=FALSE, info=NULL, label=NULL){ - expect_warning(object, regexp=NA, ..., all=all, info=info, label=label) +expect_no_warning <- function(object, ..., all = FALSE, info = NULL, label = NULL) { + expect_warning(object, regexp = NA, ..., all = all, info = info, label = label) } -expect_no_message <- function(object, ..., all=FALSE, info=NULL, label=NULL){ - expect_message(object, regexp=NA, ..., all=all, info=info, label=label) +expect_no_message <- function(object, ..., all = FALSE, info = NULL, label = NULL) { + expect_message(object, regexp = NA, ..., all = all, info = info, label = label) } -expect_str_contains <- function(object, expected, info=NULL, label=NULL){ - if(!is.character(object)) object <- as.character(object) - if(!is.character(expected)) expected <- as.character(expected) +expect_str_contains <- function(object, expected, info = NULL, label = NULL) { + if (!is.character(object)) object <- as.character(object) + if (!is.character(expected)) expected <- as.character(expected) expect_true(all(str_detect(object, expected)), - info=info, label=label) + info = info, label = label + ) } diff --git a/tests/testthat/test_4Dlist_extractor.R b/tests/testthat/test_4Dlist_extractor.R index fc2ee4d7..1d82786e 100644 --- a/tests/testthat/test_4Dlist_extractor.R +++ b/tests/testthat/test_4Dlist_extractor.R @@ -1,30 +1,40 @@ context("4D List") set.seed(123) -X <- matrix(runif(12),3,4) +X <- matrix(runif(12), 3, 4) -n_alpha_u=7; n_alpha_v=5; n_lambda_u=3; n_lambda_v=2; # mutually prime -alpha_u=seq(0.3,1,length.out = n_alpha_u) -alpha_v=seq(0.3,1,length.out = n_alpha_v) -lambda_u=seq(0.3,1,length.out = n_lambda_u) -lambda_v=seq(0.3,1,length.out = n_lambda_v) +n_alpha_u <- 7 +n_alpha_v <- 5 +n_lambda_u <- 3 +n_lambda_v <- 2 +# mutually prime +alpha_u <- seq(0.3, 1, length.out = n_alpha_u) +alpha_v <- seq(0.3, 1, length.out = n_alpha_v) +lambda_u <- seq(0.3, 1, length.out = n_lambda_u) +lambda_v <- seq(0.3, 1, length.out = n_lambda_v) arg_list <- list( X, - alpha_u=alpha_u, alpha_v=alpha_v, - Omega_u=second_diff_mat(3), Omega_v=second_diff_mat(4), - lambda_u=lambda_u, lambda_v=lambda_v, - prox_arg_list_u=add_default_prox_args(lasso()), prox_arg_list_v=add_default_prox_args(empty()), - EPS=1e-6, MAX_ITER=1e+4, EPS_inner=1e-6, MAX_ITER_inner=1e+4, solver="ISTA" + alpha_u = alpha_u, alpha_v = alpha_v, + Omega_u = second_diff_mat(3), Omega_v = second_diff_mat(4), + lambda_u = lambda_u, lambda_v = lambda_v, + prox_arg_list_u = add_default_prox_args(lasso()), prox_arg_list_v = add_default_prox_args(empty()), + EPS = 1e-6, MAX_ITER = 1e+4, EPS_inner = 1e-6, MAX_ITER_inner = 1e+4, solver = "ISTA" ) -result <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=0, #grid - selection_criterion_alpha_v=0, #grid - selection_criterion_lambda_u=0, #grid - selection_criterion_lambda_v=0))) #grid +result <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 0, # grid + selection_criterion_alpha_v = 0, # grid + selection_criterion_lambda_u = 0, # grid + selection_criterion_lambda_v = 0 + ) + ) +) # grid test_that("Test 4D List attribute", { expect_true(inherits(result, "MoMA_4D_list")) @@ -32,21 +42,25 @@ test_that("Test 4D List attribute", { test_that("Passing wrong argument", { - expect_error(get_4Dlist_elem(c(1),1,1,1,1), - paste0(sQuote("x"), " should be a ",sQuote("MoMA_4D_list")," object")) + expect_error( + get_4Dlist_elem(c(1), 1, 1, 1, 1), + paste0(sQuote("x"), " should be a ", sQuote("MoMA_4D_list"), " object") + ) }) test_that("Access all elements", { # dim(result) = 7 3 5 2 # n_alpha_u=7; n_alpha_v=5; n_lambda_u=3; n_lambda_v=2; # mutually prime - cnt = 1 - for(i in 1:n_alpha_u){ - for(j in 1:n_lambda_u){ - for(k in 1:n_alpha_v){ - for(l in 1:n_lambda_v){ - expect_equal(get_4Dlist_elem(result,i,j,k,l)[[1]], - result[[cnt]]) - cnt = cnt + 1 + cnt <- 1 + for (i in 1:n_alpha_u) { + for (j in 1:n_lambda_u) { + for (k in 1:n_alpha_v) { + for (l in 1:n_lambda_v) { + expect_equal( + get_4Dlist_elem(result, i, j, k, l)[[1]], + result[[cnt]] + ) + cnt <- cnt + 1 } } } @@ -55,34 +69,48 @@ test_that("Access all elements", { test_that("Error when accessing broundary", { - expect_no_error(get_4Dlist_elem(result,n_alpha_u,n_lambda_u,n_alpha_v,n_lambda_v)) + expect_no_error(get_4Dlist_elem(result, n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v)) # NOTE: R index starts from 1 - expect_error(get_4Dlist_elem(result,n_alpha_u,n_lambda_u,n_alpha_v,0), - "Invalid index \\(7,3,5,0\\), dim = c\\(7, 3, 5, 2\\)") - - expect_error(get_4Dlist_elem(result,n_alpha_u,n_lambda_u,0,n_lambda_v), - "Invalid index \\(7,3,0,2\\), dim = c\\(7, 3, 5, 2\\)") - - expect_error(get_4Dlist_elem(result,n_alpha_u,0,n_alpha_v,n_lambda_v), - "Invalid index \\(7,0,5,2\\), dim = c\\(7, 3, 5, 2\\)") - - expect_error(get_4Dlist_elem(result,0,n_lambda_u,n_alpha_v,n_lambda_v), - "Invalid index \\(0,3,5,2\\), dim = c\\(7, 3, 5, 2\\)") - - - expect_error(get_4Dlist_elem(result,n_alpha_u,n_lambda_u,n_alpha_v,n_lambda_v+1), - "Invalid index \\(7,3,5,3\\), dim = c\\(7, 3, 5, 2\\)") - - expect_error(get_4Dlist_elem(result,n_alpha_u,n_lambda_u,n_alpha_v+1,n_lambda_v), - "Invalid index \\(7,3,6,2\\), dim = c\\(7, 3, 5, 2\\)") - - expect_error(get_4Dlist_elem(result,n_alpha_u,n_lambda_u+1,n_alpha_v,n_lambda_v), - "Invalid index \\(7,4,5,2\\), dim = c\\(7, 3, 5, 2\\)") - - expect_error(get_4Dlist_elem(result,n_alpha_u+1,n_lambda_u,n_alpha_v,n_lambda_v), - "Invalid index \\(8,3,5,2\\), dim = c\\(7, 3, 5, 2\\)") + expect_error( + get_4Dlist_elem(result, n_alpha_u, n_lambda_u, n_alpha_v, 0), + "Invalid index \\(7,3,5,0\\), dim = c\\(7, 3, 5, 2\\)" + ) + + expect_error( + get_4Dlist_elem(result, n_alpha_u, n_lambda_u, 0, n_lambda_v), + "Invalid index \\(7,3,0,2\\), dim = c\\(7, 3, 5, 2\\)" + ) + + expect_error( + get_4Dlist_elem(result, n_alpha_u, 0, n_alpha_v, n_lambda_v), + "Invalid index \\(7,0,5,2\\), dim = c\\(7, 3, 5, 2\\)" + ) + + expect_error( + get_4Dlist_elem(result, 0, n_lambda_u, n_alpha_v, n_lambda_v), + "Invalid index \\(0,3,5,2\\), dim = c\\(7, 3, 5, 2\\)" + ) + + + expect_error( + get_4Dlist_elem(result, n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v + 1), + "Invalid index \\(7,3,5,3\\), dim = c\\(7, 3, 5, 2\\)" + ) + + expect_error( + get_4Dlist_elem(result, n_alpha_u, n_lambda_u, n_alpha_v + 1, n_lambda_v), + "Invalid index \\(7,3,6,2\\), dim = c\\(7, 3, 5, 2\\)" + ) + + expect_error( + get_4Dlist_elem(result, n_alpha_u, n_lambda_u + 1, n_alpha_v, n_lambda_v), + "Invalid index \\(7,4,5,2\\), dim = c\\(7, 3, 5, 2\\)" + ) + + expect_error( + get_4Dlist_elem(result, n_alpha_u + 1, n_lambda_u, n_alpha_v, n_lambda_v), + "Invalid index \\(8,3,5,2\\), dim = c\\(7, 3, 5, 2\\)" + ) }) - - diff --git a/tests/testthat/test_BIC.R b/tests/testthat/test_BIC.R index 0ae9a19e..2c3919b1 100644 --- a/tests/testthat/test_BIC.R +++ b/tests/testthat/test_BIC.R @@ -1,16 +1,16 @@ context("BIC tests") -bic_lasso <- function(y, y_est){ +bic_lasso <- function(y, y_est) { p <- length(y) - res <- norm(as.matrix(y-y_est),"2") - df <-sum(y_est!=0) - bic <- log(res*res/p) + log(p)/p*df + res <- norm(as.matrix(y - y_est), "2") + df <- sum(y_est != 0) + bic <- log(res * res / p) + log(p) / p * df return(bic) } test_that("Test for lasso BIC", { - y <- c(1,2,3) - y_est <- c(2,2,2) + y <- c(1, 2, 3) + y_est <- c(2, 2, 2) p <- length(y) print(y_est) expect_equal(test_BIC( @@ -18,6 +18,6 @@ test_that("Test for lasso BIC", { "ISTA", 0, second_diff_mat(p), 0, add_default_prox_args(lasso()), - p), bic_lasso(y,y_est)) + p + ), bic_lasso(y, y_est)) }) - diff --git a/tests/testthat/test_BIC_gird_mixed.R b/tests/testthat/test_BIC_gird_mixed.R index 445a7d91..493b37d7 100644 --- a/tests/testthat/test_BIC_gird_mixed.R +++ b/tests/testthat/test_BIC_gird_mixed.R @@ -1,181 +1,234 @@ context("Test BIC-grid-mixed search") set.seed(123) -X <- matrix(runif(12),3,4) +X <- matrix(runif(12), 3, 4) -n_alpha_u=7; n_alpha_v=5; n_lambda_u=3; n_lambda_v=2; # mutually prime -alpha_u=seq(0.3,1,length.out = n_alpha_u) -alpha_v=seq(0.3,1,length.out = n_alpha_v) -lambda_u=seq(0.3,1,length.out = n_lambda_u) -lambda_v=seq(0.3,1,length.out = n_lambda_v) +n_alpha_u <- 7 +n_alpha_v <- 5 +n_lambda_u <- 3 +n_lambda_v <- 2 +# mutually prime +alpha_u <- seq(0.3, 1, length.out = n_alpha_u) +alpha_v <- seq(0.3, 1, length.out = n_alpha_v) +lambda_u <- seq(0.3, 1, length.out = n_lambda_u) +lambda_v <- seq(0.3, 1, length.out = n_lambda_v) arg_list <- list( X, - alpha_u=alpha_u, alpha_v=alpha_v, - Omega_u=second_diff_mat(3), Omega_v=second_diff_mat(4), - lambda_u=lambda_u, lambda_v=lambda_v, - prox_arg_list_u=add_default_prox_args(lasso()), prox_arg_list_v=add_default_prox_args(empty()), - EPS=1e-6, MAX_ITER=1e+4, EPS_inner=1e-6, MAX_ITER_inner=1e+4, solver="ISTA" + alpha_u = alpha_u, alpha_v = alpha_v, + Omega_u = second_diff_mat(3), Omega_v = second_diff_mat(4), + lambda_u = lambda_u, lambda_v = lambda_v, + prox_arg_list_u = add_default_prox_args(lasso()), prox_arg_list_v = add_default_prox_args(empty()), + EPS = 1e-6, MAX_ITER = 1e+4, EPS_inner = 1e-6, MAX_ITER_inner = 1e+4, solver = "ISTA" ) test_that("BIC search returns correct-sized grid: four grid requests", { # Case 1: four grid requests - result <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=0, #grid - selection_criterion_alpha_v=0, #grid - selection_criterion_lambda_u=0, #grid - selection_criterion_lambda_v=0))) #grid + result <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 0, # grid + selection_criterion_alpha_v = 0, # grid + selection_criterion_lambda_u = 0, # grid + selection_criterion_lambda_v = 0 + ) + ) + ) # grid # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - lv = sapply(result, function(x) x$v$lambda) - av = sapply(result, function(x) x$v$alpha) - lu = sapply(result, function(x) x$u$lambda) - au = sapply(result, function(x) x$u$alpha) + lv <- sapply(result, function(x) x$v$lambda) + av <- sapply(result, function(x) x$v$alpha) + lu <- sapply(result, function(x) x$u$lambda) + au <- sapply(result, function(x) x$u$alpha) - expect_equal(dim(result), c(n_alpha_u,n_lambda_u,n_alpha_v,n_lambda_v)) + expect_equal(dim(result), c(n_alpha_u, n_lambda_u, n_alpha_v, n_lambda_v)) - expect_equal(lv, rep(lambda_v, n_alpha_u*n_lambda_u*n_alpha_v, each=1)) - expect_equal(av, rep(alpha_v, n_alpha_u*n_lambda_u, each=n_lambda_v)) - expect_equal(lu, rep(lambda_u, n_alpha_u, each=n_lambda_v*n_alpha_v)) - expect_equal(au, rep(alpha_u, 1, each=n_lambda_v*n_alpha_v*n_lambda_u)) + expect_equal(lv, rep(lambda_v, n_alpha_u * n_lambda_u * n_alpha_v, each = 1)) + expect_equal(av, rep(alpha_v, n_alpha_u * n_lambda_u, each = n_lambda_v)) + expect_equal(lu, rep(lambda_u, n_alpha_u, each = n_lambda_v * n_alpha_v)) + expect_equal(au, rep(alpha_u, 1, each = n_lambda_v * n_alpha_v * n_lambda_u)) }) test_that("BIC search returns correct-sized grid: three grid requests", { # BIC on lambda_v - result2 <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=0, # grid - selection_criterion_alpha_v=0, # grid - selection_criterion_lambda_u=0, # grid - selection_criterion_lambda_v=1))) + result2 <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 0, # grid + selection_criterion_alpha_v = 0, # grid + selection_criterion_lambda_u = 0, # grid + selection_criterion_lambda_v = 1 + ) + ) + ) # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - av = sapply(result2, function(x) x$v$alpha) - lu = sapply(result2, function(x) x$u$lambda) - au = sapply(result2, function(x) x$u$alpha) + av <- sapply(result2, function(x) x$v$alpha) + lu <- sapply(result2, function(x) x$u$lambda) + au <- sapply(result2, function(x) x$u$alpha) - expect_equal(dim(result2), c(n_alpha_u,n_lambda_u,n_alpha_v,1)) + expect_equal(dim(result2), c(n_alpha_u, n_lambda_u, n_alpha_v, 1)) - expect_equal(av, rep(alpha_v, n_alpha_u*n_lambda_u, each=1)) - expect_equal(lu, rep(lambda_u, n_alpha_u, each=n_alpha_v)) - expect_equal(au, rep(alpha_u, 1, each=n_lambda_u*n_alpha_v)) + expect_equal(av, rep(alpha_v, n_alpha_u * n_lambda_u, each = 1)) + expect_equal(lu, rep(lambda_u, n_alpha_u, each = n_alpha_v)) + expect_equal(au, rep(alpha_u, 1, each = n_lambda_u * n_alpha_v)) # BIC on alpha_u - result2 <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=1, - selection_criterion_alpha_v=0, # grid - selection_criterion_lambda_u=0, # grid - selection_criterion_lambda_v=0))) # grid + result2 <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 1, + selection_criterion_alpha_v = 0, # grid + selection_criterion_lambda_u = 0, # grid + selection_criterion_lambda_v = 0 + ) + ) + ) # grid # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - lv = sapply(result2, function(x) x$v$lambda) - av = sapply(result2, function(x) x$v$alpha) - lu = sapply(result2, function(x) x$u$lambda) + lv <- sapply(result2, function(x) x$v$lambda) + av <- sapply(result2, function(x) x$v$alpha) + lu <- sapply(result2, function(x) x$u$lambda) - expect_equal(dim(result2), c(1,n_lambda_u,n_alpha_v,n_lambda_v)) + expect_equal(dim(result2), c(1, n_lambda_u, n_alpha_v, n_lambda_v)) - expect_equal(lv, rep(lambda_v, n_lambda_u*n_alpha_v, each=1)) - expect_equal(av, rep(alpha_v, n_lambda_u, each=n_lambda_v)) - expect_equal(lu, rep(lambda_u, 1, each=n_alpha_v*n_lambda_v)) + expect_equal(lv, rep(lambda_v, n_lambda_u * n_alpha_v, each = 1)) + expect_equal(av, rep(alpha_v, n_lambda_u, each = n_lambda_v)) + expect_equal(lu, rep(lambda_u, 1, each = n_alpha_v * n_lambda_v)) }) test_that("BIC search returns correct-sized grid: two grid requests on u", { # Case 3: two grid requests, both on u side, and two BIC - result3 <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=0, # grid - selection_criterion_lambda_u=0, # grid - selection_criterion_alpha_v=1, - selection_criterion_lambda_v=1))) + result3 <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 0, # grid + selection_criterion_lambda_u = 0, # grid + selection_criterion_alpha_v = 1, + selection_criterion_lambda_v = 1 + ) + ) + ) # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - lv = sapply(result3, function(x) x$v$lambda) - av = sapply(result3, function(x) x$v$alpha) - lu = sapply(result3, function(x) x$u$lambda) - au = sapply(result3, function(x) x$u$alpha) + lv <- sapply(result3, function(x) x$v$lambda) + av <- sapply(result3, function(x) x$v$alpha) + lu <- sapply(result3, function(x) x$u$lambda) + au <- sapply(result3, function(x) x$u$alpha) - expect_equal(dim(result3), c(n_alpha_u,n_lambda_u,1,1)) + expect_equal(dim(result3), c(n_alpha_u, n_lambda_u, 1, 1)) - expect_equal(lu, rep(lambda_u, n_alpha_u, each=1)) - expect_equal(au, rep(alpha_u, 1, each=n_lambda_u)) + expect_equal(lu, rep(lambda_u, n_alpha_u, each = 1)) + expect_equal(au, rep(alpha_u, 1, each = n_lambda_u)) }) test_that("BIC search returns correct-sized grid: two grid requests on different sides", { # Case 4: two grid requests, both on u side, and two BIC - result4 <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=1, - selection_criterion_lambda_u=0, # grid - selection_criterion_alpha_v=1, - selection_criterion_lambda_v=0))) # grid + result4 <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 1, + selection_criterion_lambda_u = 0, # grid + selection_criterion_alpha_v = 1, + selection_criterion_lambda_v = 0 + ) + ) + ) # grid # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - lv = sapply(result4, function(x) x$v$lambda) - av = sapply(result4, function(x) x$v$alpha) - lu = sapply(result4, function(x) x$u$lambda) - au = sapply(result4, function(x) x$u$alpha) + lv <- sapply(result4, function(x) x$v$lambda) + av <- sapply(result4, function(x) x$v$alpha) + lu <- sapply(result4, function(x) x$u$lambda) + au <- sapply(result4, function(x) x$u$alpha) - expect_equal(dim(result4), c(1,n_lambda_u,1,n_lambda_v)) + expect_equal(dim(result4), c(1, n_lambda_u, 1, n_lambda_v)) - expect_equal(lv, rep(lambda_v, n_lambda_u, each=1)) - expect_equal(lu, rep(lambda_u, 1, each=n_lambda_v)) + expect_equal(lv, rep(lambda_v, n_lambda_u, each = 1)) + expect_equal(lu, rep(lambda_u, 1, each = n_lambda_v)) }) test_that("BIC search returns correct-sized grid: one grid", { # Case 5: one grid requests, both on u side, and two BIC - result4 <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=1, - selection_criterion_lambda_u=1, - selection_criterion_alpha_v=1, - selection_criterion_lambda_v=0))) # grid + result4 <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 1, + selection_criterion_lambda_u = 1, + selection_criterion_alpha_v = 1, + selection_criterion_lambda_v = 0 + ) + ) + ) # grid # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - lv = sapply(result4, function(x) x$v$lambda) - av = sapply(result4, function(x) x$v$alpha) - lu = sapply(result4, function(x) x$u$lambda) - au = sapply(result4, function(x) x$u$alpha) + lv <- sapply(result4, function(x) x$v$lambda) + av <- sapply(result4, function(x) x$v$alpha) + lu <- sapply(result4, function(x) x$u$lambda) + au <- sapply(result4, function(x) x$u$alpha) - expect_equal(dim(result4), c(1,1,1,n_lambda_v)) + expect_equal(dim(result4), c(1, 1, 1, n_lambda_v)) - expect_equal(lv, rep(lv, 1, each=1)) + expect_equal(lv, rep(lv, 1, each = 1)) }) test_that("BIC search returns correct-sized grid: all BIC search", { # Case 5: one grid requests, both on u side, and two BIC - result4 <- do.call(testnestedBIC, - c(arg_list, - list(selection_criterion_alpha_u=1, - selection_criterion_lambda_u=1, - selection_criterion_alpha_v=1, - selection_criterion_lambda_v=1))) + result4 <- do.call( + testnestedBIC, + c( + arg_list, + list( + selection_criterion_alpha_u = 1, + selection_criterion_lambda_u = 1, + selection_criterion_alpha_v = 1, + selection_criterion_lambda_v = 1 + ) + ) + ) # Loop order in C++ is (outmost) au, lu, av, lv (innermost) - lv = sapply(result4, function(x) x$v$lambda) - av = sapply(result4, function(x) x$v$alpha) - lu = sapply(result4, function(x) x$u$lambda) - au = sapply(result4, function(x) x$u$alpha) + lv <- sapply(result4, function(x) x$v$lambda) + av <- sapply(result4, function(x) x$v$alpha) + lu <- sapply(result4, function(x) x$u$lambda) + au <- sapply(result4, function(x) x$u$alpha) - expect_equal(dim(result4), c(1,1,1,1)) + expect_equal(dim(result4), c(1, 1, 1, 1)) - expect_equal(lv, rep(lv, 1, each=1)) + expect_equal(lv, rep(lv, 1, each = 1)) }) test_that("testnestedBIC receivs a vector of length 0", { - - arglist <- c(arg_list, - list(selection_criterion_alpha_u=1, - selection_criterion_lambda_u=1, - selection_criterion_alpha_v=1, - selection_criterion_lambda_v=1)) - - arglist <- modifyList(arglist, - list(lambda_u=vector())) - expect_error(do.call(testnestedBIC, arglist), - "Please specify all four parameters") + arglist <- c( + arg_list, + list( + selection_criterion_alpha_u = 1, + selection_criterion_lambda_u = 1, + selection_criterion_alpha_v = 1, + selection_criterion_lambda_v = 1 + ) + ) + + arglist <- modifyList( + arglist, + list(lambda_u = vector()) + ) + expect_error( + do.call(testnestedBIC, arglist), + "Please specify all four parameters" + ) }) diff --git a/tests/testthat/test_SLOPE.R b/tests/testthat/test_SLOPE.R index 010bb4ba..2aa5f2c0 100644 --- a/tests/testthat/test_SLOPE.R +++ b/tests/testthat/test_SLOPE.R @@ -1,31 +1,33 @@ context("SLOPE") -proxSortedL1 <- function(x,l){ +proxSortedL1 <- function(x, l) { # Modification: Choose HB type lambda - lambda <- vector(mode="numeric",length = length(x)) + lambda <- vector(mode = "numeric", length = length(x)) - for(i in 1:length(x)){ - lambda[i] = qnorm(1 - i * 0.05 / 2 / length(x)) + for (i in 1:length(x)) { + lambda[i] <- qnorm(1 - i * 0.05 / 2 / length(x)) } lambda <- lambda * l # Compare to the SLOPE package on CRAN - result <- SLOPE::prox_sorted_L1(x, lambda, method="c") + result <- SLOPE::prox_sorted_L1(x, lambda, method = "c") return(result) } test_that("Compared to the SLOPE package", { - if(requireNamespace("SLOPE")){ + if (requireNamespace("SLOPE")) { set.seed(123) - reps = 100 - for(i in 1:reps){ + reps <- 100 + for (i in 1:reps) { x <- runif(10) - for(lambda in seq(0,3,0.2)){ - expect_equal(test_prox_slope(x,lambda), - as.matrix(proxSortedL1(x,lambda))) + for (lambda in seq(0, 3, 0.2)) { + expect_equal( + test_prox_slope(x, lambda), + as.matrix(proxSortedL1(x, lambda)) + ) } } } diff --git a/tests/testthat/test_arguments.R b/tests/testthat/test_arguments.R index 7a8be1c8..b8993d5b 100644 --- a/tests/testthat/test_arguments.R +++ b/tests/testthat/test_arguments.R @@ -9,15 +9,15 @@ test_that("Test for arguments names", { # Collect all the arguments test_args <- list() - for(fun in c(lasso, - scad, - mcp, - fusedlasso, - l1tf, - slope - )){ + for (fun in c( + lasso, + scad, + mcp, + fusedlasso, + l1tf, + slope + )) { test_args <- c(test_args, names(fun())) - } args <- names(grplasso(g = factor(rep(1:10)))) @@ -27,9 +27,9 @@ test_that("Test for arguments names", { test_args <- c(test_args, args) # Test - for(arg in test_args){ - expect_true(paste0(arg,"_u") %in% correct_args) - expect_true(paste0(arg,"_v") %in% correct_args) + for (arg in test_args) { + expect_true(paste0(arg, "_u") %in% correct_args) + expect_true(paste0(arg, "_v") %in% correct_args) } }) @@ -40,45 +40,70 @@ test_that("Prompt errors for wrong prox arguments", { # Wrong non-convexity arguments - expect_error(moma_svd(matrix(runif(12),3,4), - u_sparsity=scad(1),lambda_u = 3), - paste0("Non-convexity parameter of SCAD (",sQuote("gamma"),") must be larger than 2."),fixed=TRUE) - expect_error(moma_svd(matrix(runif(12),3,4), - u_sparsity=mcp(0.9),lambda_u = 3), - paste0("Non-convexity parameter of MCP (",sQuote("gamma"),") must be larger than 1."),fixed=TRUE) + expect_error(moma_svd(matrix(runif(12), 3, 4), + u_sparsity = scad(1), lambda_u = 3 + ), + paste0("Non-convexity parameter of SCAD (", sQuote("gamma"), ") must be larger than 2."), + fixed = TRUE + ) + expect_error(moma_svd(matrix(runif(12), 3, 4), + u_sparsity = mcp(0.9), lambda_u = 3 + ), + paste0("Non-convexity parameter of MCP (", sQuote("gamma"), ") must be larger than 1."), + fixed = TRUE + ) # Wrong grouping dimension in group lasso - expect_error(moma_svd(matrix(runif(12),3,4), - u_sparsity=grplasso(factor(1)),lambda_u = 3), - "Wrong dimension: length(group) != dim(x).",fixed=TRUE) + expect_error(moma_svd(matrix(runif(12), 3, 4), + u_sparsity = grplasso(factor(1)), lambda_u = 3 + ), + "Wrong dimension: length(group) != dim(x).", + fixed = TRUE + ) expect_error(grplasso(matrix(1)), - "Please provide a vector as an indicator of grouping. (Called from grplasso)",fixed=TRUE) + "Please provide a vector as an indicator of grouping. (Called from grplasso)", + fixed = TRUE + ) # Wrong weight matrix dimension in cluster penalty - expect_error(moma_svd(matrix(runif(12),3,4), - u_sparsity=cluster(matrix(1)),lambda_u = 3), - "Wrong dimension: dim(weight matrix) != dim(x).",fixed=TRUE) + expect_error(moma_svd(matrix(runif(12), 3, 4), + u_sparsity = cluster(matrix(1)), lambda_u = 3 + ), + "Wrong dimension: dim(weight matrix) != dim(x).", + fixed = TRUE + ) # Omega has wrong dimension - expect_error(moma_svd(matrix(runif(12),3,4), - Omega_u = matrix(c(1,2),1,2),alpha_u=2), - "Omega shoud be a square matrix: nrows = 1, ncols = 2 (Called from check_omega)",fixed=TRUE) - expect_error(moma_svd(matrix(runif(12),3,4), - Omega_u = matrix(c(1),1),alpha_u=2), - "Omega shoud be a compatible matrix. It should be of 3x3, but is actually 1x1 (Called from check_omega)",fixed=TRUE) + expect_error(moma_svd(matrix(runif(12), 3, 4), + Omega_u = matrix(c(1, 2), 1, 2), alpha_u = 2 + ), + "Omega shoud be a square matrix: nrows = 1, ncols = 2 (Called from check_omega)", + fixed = TRUE + ) + expect_error(moma_svd(matrix(runif(12), 3, 4), + Omega_u = matrix(c(1), 1), alpha_u = 2 + ), + "Omega shoud be a compatible matrix. It should be of 3x3, but is actually 1x1 (Called from check_omega)", + fixed = TRUE + ) # Prompt errors when users require rank-k svd and cross validation - expect_error(moma_svd(matrix(runif(12),3,4),lambda_u=c(1,2,3),k=2), - "We don't support a range of parameters in finding a rank-k svd (Called from moma_svd)",fixed=TRUE) - expect_error(moma_svd(matrix(runif(12),3,4), - lambda_u=c(1,2,3), - lambda_v = seq(10), - alpha_u = seq(10)), - "We only allow changing two parameters.",fixed=TRUE) + expect_error(moma_svd(matrix(runif(12), 3, 4), lambda_u = c(1, 2, 3), k = 2), + "We don't support a range of parameters in finding a rank-k svd (Called from moma_svd)", + fixed = TRUE + ) + expect_error(moma_svd(matrix(runif(12), 3, 4), + lambda_u = c(1, 2, 3), + lambda_v = seq(10), + alpha_u = seq(10) + ), + "We only allow changing two parameters.", + fixed = TRUE + ) }) @@ -87,112 +112,192 @@ test_that("Correct prox match", { MoMA::moma_logger_level("DEBUG") on.exit(MoMA::moma_logger_level(old_logger_level)) - expect_output(moma_svd(matrix(runif(12),3,4)), - "Initializing null proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4)), + "Initializing null proximal operator object" + ) - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=lasso(),lambda_u = 3), - "Initializing Lasso proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = lasso(), lambda_u = 3 + ), + "Initializing Lasso proximal operator object" + ) # SLOPE - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=slope(),lambda_u = 3), - "P_u SLOPE") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=slope(),lambda_u = 3), - "Initializing SLOPE proximal operator object") - expect_output(moma_svd(matrix(runif(12),3,4), - v_sparsity=slope(),lambda_u = 3), - "P_v SLOPE") - expect_output(moma_svd(matrix(runif(12),3,4), - v_sparsity=slope()), - "Initializing SLOPE proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = slope(), lambda_u = 3 + ), + "P_u SLOPE" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = slope(), lambda_u = 3 + ), + "Initializing SLOPE proximal operator object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + v_sparsity = slope(), lambda_u = 3 + ), + "P_v SLOPE" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + v_sparsity = slope() + ), + "Initializing SLOPE proximal operator object" + ) # lasso - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=lasso(),lambda_u = 3), - "Initializing Lasso proximal operator object") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=lasso(TRUE),lambda_u = 3), - "Initializing non-negative Lasso proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = lasso(), lambda_u = 3 + ), + "Initializing Lasso proximal operator object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = lasso(TRUE), lambda_u = 3 + ), + "Initializing non-negative Lasso proximal operator object" + ) # scad - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=scad(),lambda_u = 3), - "Initializing SCAD proximal operator object") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=scad(non_negative=TRUE),lambda_u = 3), - "Initializing non-negative SCAD proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = scad(), lambda_u = 3 + ), + "Initializing SCAD proximal operator object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = scad(non_negative = TRUE), lambda_u = 3 + ), + "Initializing non-negative SCAD proximal operator object" + ) # mcp - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=mcp(),lambda_u = 3), - "Initializing MCP proximal operator object") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=mcp(non_negative=TRUE),lambda_u = 3), - "Initializing non-negative MCP proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = mcp(), lambda_u = 3 + ), + "Initializing MCP proximal operator object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = mcp(non_negative = TRUE), lambda_u = 3 + ), + "Initializing non-negative MCP proximal operator object" + ) # group - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=grplasso(factor(seq(3))),lambda_u = 3), - "Initializing group lasso proximal operator object") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=grplasso(factor(seq(3)),non_negative=TRUE),lambda_u = 3), - "Initializing non-negative group lasso proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = grplasso(factor(seq(3))), lambda_u = 3 + ), + "Initializing group lasso proximal operator object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = grplasso(factor(seq(3)), non_negative = TRUE), lambda_u = 3 + ), + "Initializing non-negative group lasso proximal operator object" + ) # L1 linear trend filtering - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=l1tf(),lambda_u = 3), - "Initializing a L1 linear trend filtering proximal operator object of degree 1") - expect_output(moma_svd(matrix(runif(100),10,10), - u_sparsity=l1tf(l1tf_k = 2),lambda_u = 3), - "Initializing a L1 linear trend filtering proximal operator object of degree 2") - expect_error(moma_svd(matrix(runif(12),3,4), - u_sparsity=l1tf(l1tf_k = 2),lambda_u = 3), - "A difference matrix should have more columns.") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = l1tf(), lambda_u = 3 + ), + "Initializing a L1 linear trend filtering proximal operator object of degree 1" + ) + expect_output( + moma_svd(matrix(runif(100), 10, 10), + u_sparsity = l1tf(l1tf_k = 2), lambda_u = 3 + ), + "Initializing a L1 linear trend filtering proximal operator object of degree 2" + ) + expect_error( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = l1tf(l1tf_k = 2), lambda_u = 3 + ), + "A difference matrix should have more columns." + ) # sparse fused lasso - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=spfusedlasso(lambda2=3),lambda_u = 3), - "Initializing a sparse fused lasso proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = spfusedlasso(lambda2 = 3), lambda_u = 3 + ), + "Initializing a sparse fused lasso proximal operator object" + ) # fused lasso - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=fusedlasso(),lambda_u = 3), - "Initializing a ordered fusion lasso proximal operator object") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=fusedlasso(),lambda_u = 3), - "P_u ORDEREDFUSED P_v NONE") - expect_output(moma_svd(matrix(runif(12),3,4), - v_sparsity=fusedlasso(),lambda_u = 3), - "P_u NONE P_v ORDEREDFUSED") - - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=fusedlasso(algo="dp"),lambda_u = 3), - "P_u ORDEREDFUSEDDP P_v NONE") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=fusedlasso(algo="dp"), - v_sparsity=fusedlasso(), - lambda_u = 3), - "P_u ORDEREDFUSEDDP P_v ORDEREDFUSED") - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=fusedlasso(algo="dp"),lambda_u = 3), - "P_u ORDEREDFUSEDDP P_v NONE") - - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=fusedlasso(algo="dp"),lambda_u = 3), - "Initializing a ordered fusion lasso proximal operator object \\(DP\\)") - expect_output(moma_svd(matrix(runif(12),3,4), - v_sparsity=fusedlasso(algo="dp"),lambda_u = 3), - "Initializing a ordered fusion lasso proximal operator object \\(DP\\)") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = fusedlasso(), lambda_u = 3 + ), + "Initializing a ordered fusion lasso proximal operator object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = fusedlasso(), lambda_u = 3 + ), + "P_u ORDEREDFUSED P_v NONE" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + v_sparsity = fusedlasso(), lambda_u = 3 + ), + "P_u NONE P_v ORDEREDFUSED" + ) + + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = fusedlasso(algo = "dp"), lambda_u = 3 + ), + "P_u ORDEREDFUSEDDP P_v NONE" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = fusedlasso(algo = "dp"), + v_sparsity = fusedlasso(), + lambda_u = 3 + ), + "P_u ORDEREDFUSEDDP P_v ORDEREDFUSED" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = fusedlasso(algo = "dp"), lambda_u = 3 + ), + "P_u ORDEREDFUSEDDP P_v NONE" + ) + + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = fusedlasso(algo = "dp"), lambda_u = 3 + ), + "Initializing a ordered fusion lasso proximal operator object \\(DP\\)" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), + v_sparsity = fusedlasso(algo = "dp"), lambda_u = 3 + ), + "Initializing a ordered fusion lasso proximal operator object \\(DP\\)" + ) # cluster penalty - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=cluster(diag(3)),lambda_u = 3), - "Initializing a fusion lasso proximal operator object") + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = cluster(diag(3)), lambda_u = 3 + ), + "Initializing a fusion lasso proximal operator object" + ) }) test_that("Correct algorithm match", { @@ -200,29 +305,47 @@ test_that("Correct algorithm match", { MoMA::moma_logger_level("DEBUG") - expect_output(moma_svd(matrix(runif(12),3,4),solver = "ista"), - "Initializing a ISTA solver") - expect_output(moma_svd(matrix(runif(12),3,4),solver = "fista"), - "Initializing a FISTA solver") - expect_output(moma_svd(matrix(runif(12),3,4),solver = "onestepista"), - "Initializing an one-step ISTA solver") - - - expect_output(moma_svd(matrix(runif(12),3,4),solver = "ista"), - "Releasing a ISTA object") - expect_output(moma_svd(matrix(runif(12),3,4),solver = "fista"), - "Releasing a FISTA object") - expect_output(moma_svd(matrix(runif(12),3,4),solver = "onestepista"), - "Releasing a OneStepISTA object") - - - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=cluster(diag(3),ADMM=TRUE),lambda_u = 3), - "Running ADMM") - - expect_output(moma_svd(matrix(runif(12),3,4), - u_sparsity=cluster(diag(3)),lambda_u = 3), - "Running AMA") + expect_output( + moma_svd(matrix(runif(12), 3, 4), solver = "ista"), + "Initializing a ISTA solver" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), solver = "fista"), + "Initializing a FISTA solver" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), solver = "onestepista"), + "Initializing an one-step ISTA solver" + ) + + + expect_output( + moma_svd(matrix(runif(12), 3, 4), solver = "ista"), + "Releasing a ISTA object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), solver = "fista"), + "Releasing a FISTA object" + ) + expect_output( + moma_svd(matrix(runif(12), 3, 4), solver = "onestepista"), + "Releasing a OneStepISTA object" + ) + + + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = cluster(diag(3), ADMM = TRUE), lambda_u = 3 + ), + "Running ADMM" + ) + + expect_output( + moma_svd(matrix(runif(12), 3, 4), + u_sparsity = cluster(diag(3)), lambda_u = 3 + ), + "Running AMA" + ) on.exit(MoMA::moma_logger_level(old_logger_level)) }) @@ -232,20 +355,26 @@ test_that("Data matrix must be complete", { MoMA::moma_logger_level("DEBUG") on.exit(MoMA::moma_logger_level(old_logger_level)) - X <- matrix(runif(12),3,4) - X[2,1] <- NA + X <- matrix(runif(12), 3, 4) + X[2, 1] <- NA expect_error(moma_svd(X = X), - "X must not have NaN, NA, or Inf. (Called from moma_svd)",fixed=TRUE) + "X must not have NaN, NA, or Inf. (Called from moma_svd)", + fixed = TRUE + ) - X = matrix(runif(12),3,4) - X[3,2] <- Inf + X <- matrix(runif(12), 3, 4) + X[3, 2] <- Inf expect_error(moma_svd(X = X), - "X must not have NaN, NA, or Inf. (Called from moma_svd)",fixed=TRUE) + "X must not have NaN, NA, or Inf. (Called from moma_svd)", + fixed = TRUE + ) - X = matrix(runif(12),3,4) - X[1,4] <- NaN + X <- matrix(runif(12), 3, 4) + X[1, 4] <- NaN expect_error(moma_svd(X = X), - "X must not have NaN, NA, or Inf. (Called from moma_svd)",fixed=TRUE) + "X must not have NaN, NA, or Inf. (Called from moma_svd)", + fixed = TRUE + ) }) test_that("Negative penalty", { @@ -256,37 +385,53 @@ test_that("Negative penalty", { # Negative penalty set.seed(112) - X <- matrix(runif(12),3,4) - expect_error(moma_svd(X = X, lambda_u=c(0,1,2,3,4,-1)), - paste0("All penalty levels (", - sQuote("lambda_u"),", ", - sQuote("lambda_v"), ", ", - sQuote("alpha_u"), ", ", - sQuote("alpha_v"),") must be non-negative numeric. "),fixed=TRUE) - - - expect_error(moma_svd(X = X, lambda_v=c(0,1,2,3,4,-1)), - paste0("All penalty levels (", - sQuote("lambda_u"),", ", - sQuote("lambda_v"), ", ", - sQuote("alpha_u"), ", ", - sQuote("alpha_v"),") must be non-negative numeric. "),fixed=TRUE) + X <- matrix(runif(12), 3, 4) + expect_error(moma_svd(X = X, lambda_u = c(0, 1, 2, 3, 4, -1)), + paste0( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), ") must be non-negative numeric. " + ), + fixed = TRUE + ) + + + expect_error(moma_svd(X = X, lambda_v = c(0, 1, 2, 3, 4, -1)), + paste0( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), ") must be non-negative numeric. " + ), + fixed = TRUE + ) # Prompt error when passing a matrix - expect_error(moma_svd(X = X, lambda_v=matrix(1:12,3)), - paste0("All penalty levels (", - sQuote("lambda_u"),", ", - sQuote("lambda_v"), ", ", - sQuote("alpha_u"), ", ", - sQuote("alpha_v"),") must be numeric."),fixed=TRUE) - - - - expect_no_error(moma_svd(X = X, lambda_v=1,lambda_u=1), - paste0("All penalty levels (", - sQuote("lambda_u"),", ", - sQuote("lambda_v"), ", ", - sQuote("alpha_u"), ", ", - sQuote("alpha_v"),") must be non-negative numeric."),fixed=TRUE) + expect_error(moma_svd(X = X, lambda_v = matrix(1:12, 3)), + paste0( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), ") must be numeric." + ), + fixed = TRUE + ) + + + + expect_no_error(moma_svd(X = X, lambda_v = 1, lambda_u = 1), + paste0( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), ") must be non-negative numeric." + ), + fixed = TRUE + ) }) diff --git a/tests/testthat/test_dof.R b/tests/testthat/test_dof.R index 0f6f6f25..345951ca 100644 --- a/tests/testthat/test_dof.R +++ b/tests/testthat/test_dof.R @@ -3,19 +3,19 @@ context("Test degree of freedom") test_that("DoF of fused lasso", { # constant - x <- c(1,1,1,1) + x <- c(1, 1, 1, 1) expect_equal(1, test_df_orderedfusion(x)) # fused group at the start - x <- c(1,1,1,2,1) + x <- c(1, 1, 1, 2, 1) expect_equal(3, test_df_orderedfusion(x)) # fused group at the end - x <- c(1,2,1,1,1,1) + x <- c(1, 2, 1, 1, 1, 1) expect_equal(3, test_df_orderedfusion(x)) # multiple fused groups - x <- c(1,2,2,3,3,4,4,4,5,5,6) + x <- c(1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 6) expect_equal(6, test_df_orderedfusion(x)) # no fusion happens @@ -25,19 +25,19 @@ test_that("DoF of fused lasso", { test_that("DoF of sparse fused lasso", { # constant - x <- c(1,1,1,1) + x <- c(1, 1, 1, 1) expect_equal(1, test_df_spfusedlasso(x)) # fused group at the beginning - x <- c(1,1,1,2,1) + x <- c(1, 1, 1, 2, 1) expect_equal(3, test_df_spfusedlasso(x)) # fused group at the end - x <- c(1,2,1,1,1,1) + x <- c(1, 2, 1, 1, 1, 1) expect_equal(3, test_df_spfusedlasso(x)) # multiple fused groups - x <- c(1,2,2,3,3,4,4,4,5,5,6) + x <- c(1, 2, 2, 3, 3, 4, 4, 4, 5, 5, 6) expect_equal(6, test_df_spfusedlasso(x)) # no fusion happens @@ -45,82 +45,82 @@ test_that("DoF of sparse fused lasso", { expect_equal(20, test_df_spfusedlasso(x)) # zeros at the beginning - x <- c(0,0,1,2,1,1) + x <- c(0, 0, 1, 2, 1, 1) expect_equal(3, test_df_spfusedlasso(x)) # zeros in the middle - x <- c(1,0,0,2,1,1) + x <- c(1, 0, 0, 2, 1, 1) expect_equal(3, test_df_spfusedlasso(x)) # multiple groups of zeros in the middle - x <- c(1,0,0,2,0,0,0,3,3,0,1,1) + x <- c(1, 0, 0, 2, 0, 0, 0, 3, 3, 0, 1, 1) expect_equal(4, test_df_spfusedlasso(x)) # zeros in the end - x <- c(1,0,0,2,1,1,0) + x <- c(1, 0, 0, 2, 1, 1, 0) expect_equal(3, test_df_spfusedlasso(x)) }) test_that("DoF of linear trend filtering", { - x <- c(1,1,1,1) - expect_equal(2, test_df_l1gf(x,1)) + x <- c(1, 1, 1, 1) + expect_equal(2, test_df_l1gf(x, 1)) # given any line (knot = 0) it should return DoF = 2 - x <- seq(0,20,0.3) - for(rep in 1:10){ + x <- seq(0, 20, 0.3) + for (rep in 1:10) { alpha <- runif(1) beta <- runif(1) xx <- alpha * x + beta - expect_equal(2, test_df_l1gf(x,1)) + expect_equal(2, test_df_l1gf(x, 1)) } # one knot - x <- seq(0,20,0.3) + x <- seq(0, 20, 0.3) x <- 2 * abs(x - x[37]) - 2 - expect_equal(3, test_df_l1gf(x,1)) + expect_equal(3, test_df_l1gf(x, 1)) # three knots - x <- seq(0,20,0.3) + x <- seq(0, 20, 0.3) x <- 2 * abs(x - x[37]) - 2 x <- 2 * abs(x - x[10]) - 2 ## plot(x) - expect_equal(5, test_df_l1gf(x,1)) + expect_equal(5, test_df_l1gf(x, 1)) # Find out knots using `diff`` x <- runif(40) change_in_sec_diff <- sum(abs(diff(diff(x))) > 1e-10) - expect_equal(change_in_sec_diff + 1 + 1, test_df_l1gf(x,2)) + expect_equal(change_in_sec_diff + 1 + 1, test_df_l1gf(x, 2)) }) test_that("DoF of quadratic trend filtering", { # constant - x <- c(1,1,1,1,1) - expect_equal(3, test_df_l1gf(x,2)) + x <- c(1, 1, 1, 1, 1) + expect_equal(3, test_df_l1gf(x, 2)) # given any line it should return DoF = 3 - x <- seq(0,20,0.3) - for(rep in 1:10){ + x <- seq(0, 20, 0.3) + for (rep in 1:10) { alpha <- runif(1) - beta <- runif(1) - xx <- alpha * x + beta - expect_equal(3, test_df_l1gf(x,2)) + beta <- runif(1) + xx <- alpha * x + beta + expect_equal(3, test_df_l1gf(x, 2)) } # given any quadratic curve it should return DoF = 3 - x <- seq(0,20,0.3) - for(rep in 1:10){ + x <- seq(0, 20, 0.3) + for (rep in 1:10) { alpha <- runif(1) - beta <- runif(1) - c <- runif(1) - xx <- alpha * x^2 + beta * x + c - expect_equal(3, test_df_l1gf(x,2)) + beta <- runif(1) + c <- runif(1) + xx <- alpha * x^2 + beta * x + c + expect_equal(3, test_df_l1gf(x, 2)) } # Find out knots using `diff`` change_in_sec_diff <- sum(abs(diff(diff(diff(x)))) > 1e-10) - expect_equal(change_in_sec_diff + 2 + 1, test_df_l1gf(x,2)) + expect_equal(change_in_sec_diff + 2 + 1, test_df_l1gf(x, 2)) }) diff --git a/tests/testthat/test_fused_lasso.R b/tests/testthat/test_fused_lasso.R index 25f72e1a..de2e1e0c 100644 --- a/tests/testthat/test_fused_lasso.R +++ b/tests/testthat/test_fused_lasso.R @@ -5,54 +5,59 @@ test_that("A numeric example: Ordered fused lasso should return correct values u x <- 10 * runif(10) # result generated by flsa # These lambdas are the knots where merges happen. - + # library(flsa) # flsa::flsaTopDown(x) - goal <-matrix(c(4.447685, 5.447685, 6.447685, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593 - ,9.985404, 8.417172, 7.417172, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593 - ,8.848940, 8.417172, 7.417172, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593 - ,2.384260, 3.328699, 4.328699, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 - ,2.273138, 3.328699, 4.328699, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 - ,8.477694, 6.477694, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 - ,2.825617, 4.825617, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 - ,7.176086, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 - ,3.960512, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 - ,5.746595, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593), - nrow=10, - byrow=T) - lambdas <- seq(0,10,1) - for(l in 1:10){ - expect_lte(norm(test_prox_fusedlassopath(x,lambdas[l])-matrix(goal[,l],nrow=10)),1e-5) + goal <- matrix(c( + 4.447685, 5.447685, 6.447685, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593, + 9.985404, 8.417172, 7.417172, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593, + 8.848940, 8.417172, 7.417172, 6.760676, 6.427343, 6.094010, 5.760676, 5.612593, 5.612593, 5.612593, 5.612593, + 2.384260, 3.328699, 4.328699, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, + 2.273138, 3.328699, 4.328699, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, + 8.477694, 6.477694, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, + 2.825617, 4.825617, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, + 7.176086, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, + 3.960512, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593, + 5.746595, 5.294398, 5.237301, 5.120557, 5.263415, 5.406272, 5.549129, 5.612593, 5.612593, 5.612593, 5.612593 + ), + nrow = 10, + byrow = T + ) + lambdas <- seq(0, 10, 1) + for (l in 1:10) { + expect_lte(norm(test_prox_fusedlassopath(x, lambdas[l]) - matrix(goal[, l], nrow = 10)), 1e-5) } }) test_that("Equals to mean when lambda is large enough", { l <- 1e+100 set.seed(34) - for(i in 1000){ + for (i in 1000) { x <- 10 * runif(10) - proxed.x <- test_prox_fusedlassopath(x,l) - for(i in 1:9){ - expect_equal(proxed.x[i],proxed.x[i+1]) + proxed.x <- test_prox_fusedlassopath(x, l) + for (i in 1:9) { + expect_equal(proxed.x[i], proxed.x[i + 1]) } - expect_equal(mean(x),proxed.x[1]) + expect_equal(mean(x), proxed.x[1]) } }) test_that("Same results as the `flsa` package", { set.seed(43) - if(requireNamespace("flsa")){ + if (requireNamespace("flsa")) { library(flsa) # Problem size ranging from 2 to 200 - for(p in seq(2,200,10)){ + for (p in seq(2, 200, 10)) { # Repeat 10 times - for(i in 1:10){ + for (i in 1:10) { x <- 10 * runif(p) # Penalty levels - for(lambda in seq(0,5,0.5)){ - expect_equal(test_prox_fusedlassopath(x,lambda), - t(flsa::flsaGetSolution(flsa::flsa(x),lambda2=lambda))) + for (lambda in seq(0, 5, 0.5)) { + expect_equal( + test_prox_fusedlassopath(x, lambda), + t(flsa::flsaGetSolution(flsa::flsa(x), lambda2 = lambda)) + ) } } } @@ -61,21 +66,23 @@ test_that("Same results as the `flsa` package", { test_that("DP approach should give the same results as the `flsa` package", { set.seed(43) - if(requireNamespace("flsa")){ + if (requireNamespace("flsa")) { library(flsa) # Problem size ranging from 2 to 200 - for(p in seq(2,200,10)){ + for (p in seq(2, 200, 10)) { # Repeat 10 times - for(i in 1:10){ + for (i in 1:10) { x <- 10 * runif(p) # Penalty levels - for(lambda in seq(0,5,0.5)){ - expect_equal(test_prox_fusedlassodp(x,lambda), - t(flsa::flsaGetSolution(flsa::flsa(x),lambda2=lambda))) - if(lambda == 5){ + for (lambda in seq(0, 5, 0.5)) { + expect_equal( + test_prox_fusedlassodp(x, lambda), + t(flsa::flsaGetSolution(flsa::flsa(x), lambda2 = lambda)) + ) + if (lambda == 5) { # make sure we test the entire path - expect(sum(abs(test_prox_fusedlassodp(x,lambda))), 0) + expect(sum(abs(test_prox_fusedlassodp(x, lambda))), 0) } } } @@ -85,20 +92,21 @@ test_that("DP approach should give the same results as the `flsa` package", { test_that("Test DP approach buffer size", { set.seed(43) - if(requireNamespace("flsa")){ + if (requireNamespace("flsa")) { library(flsa) lambda <- 1 # Problem size - for(p in c(10000000)){ + for (p in c(10000000)) { # Repeat 10 times - for(i in 1:10){ + for (i in 1:10) { print(i) x <- 10 * runif(p) # Path algorithm takes 10 seconds to solve each. # DP takes 0.5 seconds. - expect_equal(test_prox_fusedlassodp(x, lambda), - test_prox_fusedlassopath(x, lambda) - ) + expect_equal( + test_prox_fusedlassodp(x, lambda), + test_prox_fusedlassopath(x, lambda) + ) } } } diff --git a/tests/testthat/test_grid.R b/tests/testthat/test_grid.R index db3e37c3..85b143d6 100644 --- a/tests/testthat/test_grid.R +++ b/tests/testthat/test_grid.R @@ -4,52 +4,54 @@ test_that("Using cpp_sfpca_grid is equivalent to run cpp_sfpca multiple times", set.seed(332) n <- 7 # set n != p to avoid bugs p <- 11 - X = matrix(runif(n*p),n) + X <- matrix(runif(n * p), n) # generate p.d. matrices - O_v = crossprod(matrix(runif(p*p),p,p)) - O_u = crossprod(matrix(runif(n*n),n,n)) + O_v <- crossprod(matrix(runif(p * p), p, p)) + O_u <- crossprod(matrix(runif(n * n), n, n)) # run tests # NOTE: there's no need to test for large # lambda's and alpha's because in those # cases u and v are zeros - sp_set <- seq(0,3,0.5) - sm_set <- seq(0,3,0.5) + sp_set <- seq(0, 3, 0.5) + sm_set <- seq(0, 3, 0.5) # WARNING: cannot add scad or mcp here # I guess because they are non-convex, so # there is slight difference in the results # TODO: Add l1tf - for(sptype in c(lasso,fusedlasso)){ + for (sptype in c(lasso, fusedlasso)) { ista.cv <- moma_svd(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=0,alpha_v=sm_set, - lambda_u=0,lambda_v=sp_set,u_sparsity=lasso(),v_sparsity=sptype(), - EPS=1e-14,MAX_ITER = 1e+5,solve="ISTA",EPS_inner = 1e-9) + Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm_set, + lambda_u = 0, lambda_v = sp_set, u_sparsity = lasso(), v_sparsity = sptype(), + EPS = 1e-14, MAX_ITER = 1e+5, solve = "ISTA", EPS_inner = 1e-9 + ) fista.cv <- moma_svd(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=0,alpha_v=sm_set, - lambda_u=0,lambda_v=sp_set,u_sparsity=lasso(),v_sparsity=sptype(), - EPS=1e-14,MAX_ITER = 1e+5,solve="FISTA",EPS_inner = 1e-9) - cnt = 1 - for(sp in sp_set){ - for(sm in sm_set){ + Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm_set, + lambda_u = 0, lambda_v = sp_set, u_sparsity = lasso(), v_sparsity = sptype(), + EPS = 1e-14, MAX_ITER = 1e+5, solve = "FISTA", EPS_inner = 1e-9 + ) + cnt <- 1 + for (sp in sp_set) { + for (sm in sm_set) { ista <- moma_svd(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=0,alpha_v=sm, - lambda_u=0,lambda_v=sp,u_sparsity=lasso(),v_sparsity=sptype(), - EPS=1e-14,MAX_ITER = 1e+5,solve="ISTA",EPS_inner = 1e-9) + Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm, + lambda_u = 0, lambda_v = sp, u_sparsity = lasso(), v_sparsity = sptype(), + EPS = 1e-14, MAX_ITER = 1e+5, solve = "ISTA", EPS_inner = 1e-9 + ) fista <- moma_svd(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=0,alpha_v=sm, - lambda_u=0,lambda_v=sp,u_sparsity=lasso(),v_sparsity=sptype(), - EPS=1e-14,MAX_ITER = 1e+5,solve="FISTA",EPS_inner = 1e-9) + Omega_u = O_u, Omega_v = O_v, alpha_u = 0, alpha_v = sm, + lambda_u = 0, lambda_v = sp, u_sparsity = lasso(), v_sparsity = sptype(), + EPS = 1e-14, MAX_ITER = 1e+5, solve = "FISTA", EPS_inner = 1e-9 + ) # Cannot use expect_equal here due to numerical error - expect_lte(sum((ista$v[,1]-ista.cv$v[,cnt])^2),1e-7) - expect_lte(sum((fista$v[,1]-fista.cv$v[,cnt])^2),1e-7) - cnt = cnt + 1 - + expect_lte(sum((ista$v[, 1] - ista.cv$v[, cnt])^2), 1e-7) + expect_lte(sum((fista$v[, 1] - fista.cv$v[, cnt])^2), 1e-7) + cnt <- cnt + 1 } } } }) - diff --git a/tests/testthat/test_l1tf.R b/tests/testthat/test_l1tf.R index 6d599dde..af561ad7 100644 --- a/tests/testthat/test_l1tf.R +++ b/tests/testthat/test_l1tf.R @@ -3,9 +3,9 @@ test_that("Return original data when lambda = 0", { set.seed(33) rep <- 23 p <- 29 - for(i in 1:rep){ + for (i in 1:rep) { x <- runif(p) - expect_equal(test_prox_l1gf(x,0),matrix(t(x))) + expect_equal(test_prox_l1gf(x, 0), matrix(t(x))) } }) @@ -14,20 +14,20 @@ test_that("Return linear regression fit when lambda = infty", { rep <- 23 p <- 29 infty <- 1e+5 - for(i in 1:rep){ + for (i in 1:rep) { x <- runif(p) t <- 1:p - lr_fit <- predict(lm(x~t,data.frame(t=t))) - expect_equal(test_prox_l1gf(x,infty),matrix(lr_fit)) + lr_fit <- predict(lm(x ~ t, data.frame(t = t))) + expect_equal(test_prox_l1gf(x, infty), matrix(lr_fit)) } }) -sec_diff_mat <- function(m){ - D <- matrix(rep(0,m*(m-2)),m-2) - for(i in 1:m-2){ - D[i,i] = 1 - D[i,(i+1)] = -2 - D[i,(i+2)] = 1 +sec_diff_mat <- function(m) { + D <- matrix(rep(0, m * (m - 2)), m - 2) + for (i in 1:m - 2) { + D[i, i] <- 1 + D[i, (i + 1)] <- -2 + D[i, (i + 2)] <- 1 } return(D) } @@ -36,32 +36,32 @@ test_that("Compare with `CVX` with random lambda's", { p <- 10 # answers obtained from matlab package `CVX` - x = c(.22,.11,.11,.06,.4,.45,.37,.76,.63,.77) + x <- c(.22, .11, .11, .06, .4, .45, .37, .76, .63, .77) # WARNING: probably it it not accurate itself ans <- matrix(c( - 0.220000,0.176667,0.151667,0.126667,0.109894,0.095532,0.081170,0.066809,0.052447,0.038364,0.038364, - 0.110000,0.146667,0.146667,0.146667,0.142553,0.137234,0.131915,0.126596,0.121277,0.116061,0.116061, - 0.110000,0.116667,0.141667,0.166667,0.175213,0.178936,0.182660,0.186383,0.190106,0.193758,0.193758, - 0.060000,0.160000,0.190143,0.196786,0.207872,0.220638,0.233404,0.246170,0.258936,0.271455,0.271455, - 0.400000,0.286404,0.291000,0.295000,0.302979,0.312249,0.321520,0.330790,0.340061,0.349152,0.349152, - 0.450000,0.399298,0.391857,0.393214,0.398085,0.403860,0.409635,0.415410,0.421185,0.426848,0.426848, - 0.370000,0.512193,0.492714,0.491429,0.493191,0.495471,0.497751,0.500030,0.502310,0.504545,0.504545, - 0.760000,0.625088,0.593571,0.589643,0.588298,0.587082,0.585866,0.584650,0.583435,0.582242,0.582242, - 0.630000,0.694035,0.691429,0.687857,0.683404,0.678693,0.673982,0.669271,0.664559,0.659939,0.659939, - 0.770000,0.762982,0.789286,0.786071,0.778511,0.770304,0.762097,0.753891,0.745684,0.737636,0.737636 + 0.220000, 0.176667, 0.151667, 0.126667, 0.109894, 0.095532, 0.081170, 0.066809, 0.052447, 0.038364, 0.038364, + 0.110000, 0.146667, 0.146667, 0.146667, 0.142553, 0.137234, 0.131915, 0.126596, 0.121277, 0.116061, 0.116061, + 0.110000, 0.116667, 0.141667, 0.166667, 0.175213, 0.178936, 0.182660, 0.186383, 0.190106, 0.193758, 0.193758, + 0.060000, 0.160000, 0.190143, 0.196786, 0.207872, 0.220638, 0.233404, 0.246170, 0.258936, 0.271455, 0.271455, + 0.400000, 0.286404, 0.291000, 0.295000, 0.302979, 0.312249, 0.321520, 0.330790, 0.340061, 0.349152, 0.349152, + 0.450000, 0.399298, 0.391857, 0.393214, 0.398085, 0.403860, 0.409635, 0.415410, 0.421185, 0.426848, 0.426848, + 0.370000, 0.512193, 0.492714, 0.491429, 0.493191, 0.495471, 0.497751, 0.500030, 0.502310, 0.504545, 0.504545, + 0.760000, 0.625088, 0.593571, 0.589643, 0.588298, 0.587082, 0.585866, 0.584650, 0.583435, 0.582242, 0.582242, + 0.630000, 0.694035, 0.691429, 0.687857, 0.683404, 0.678693, 0.673982, 0.669271, 0.664559, 0.659939, 0.659939, + 0.770000, 0.762982, 0.789286, 0.786071, 0.778511, 0.770304, 0.762097, 0.753891, 0.745684, 0.737636, 0.737636 ), - ncol = 10) - lambda_set <- seq(0,0.5,0.05) + ncol = 10 + ) + lambda_set <- seq(0, 0.5, 0.05) cnt <- 1 - for(lambda in lambda_set){ - - my_l1tf <- round(test_prox_l1gf(x,lambda),2) + for (lambda in lambda_set) { + my_l1tf <- round(test_prox_l1gf(x, lambda), 2) # At least the first two digits are the same. - expect_lt(sum((my_l1tf-as.matrix(ans[cnt,]))^2),0.6e-3) + expect_lt(sum((my_l1tf - as.matrix(ans[cnt, ]))^2), 0.6e-3) - cnt = cnt + 1 + cnt <- cnt + 1 } }) @@ -77,102 +77,112 @@ test_that("Commutability with affine adjustment", { alpha <- runif(1) beta <- runif(1) - for(i in 1:rep){ + for (i in 1:rep) { x <- runif(p) # remove a line from x t <- 1:p x_ <- x - alpha * t - beta - for(lambda in seq(0,3,0.2)){ - expect_equal(test_prox_l1gf(x_,lambda), - test_prox_l1gf(x,lambda) - alpha*t - beta) + for (lambda in seq(0, 3, 0.2)) { + expect_equal( + test_prox_l1gf(x_, lambda), + test_prox_l1gf(x, lambda) - alpha * t - beta + ) } } }) -test_that("Eqivalent to fused lasso when using first-diff-mat",{ +test_that("Eqivalent to fused lasso when using first-diff-mat", { set.seed(2) rep <- 5 p <- 17 - for(i in 1:rep){ + for (i in 1:rep) { x <- runif(p) - for(lambda in seq(0,5,0.3)){ + for (lambda in seq(0, 5, 0.3)) { # WARNING: primal-dual method only attains # low precision # primal-dual methods - pd <- test_prox_l1gf(x,lambda,0) + pd <- test_prox_l1gf(x, lambda, 0) # path algorithm - pa <- test_prox_fusedlassopath(x,lambda) + pa <- test_prox_fusedlassopath(x, lambda) # Most of the results are the same # for at least 5 digits after decimal points, # but some give outrageous errors - expect_lte(sum((pd-pa)^2),1e-9) + expect_lte(sum((pd - pa)^2), 1e-9) } } }) -test_that("Tests for difference matrix",{ - mat1 <- matrix(c(1,-1,0,0, - 0,1,-1,0, - 0,0,1,-1),byrow=TRUE,nrow=3) - - mat2 <- matrix(c(-1,2,-1,0,0, - 0,-1,2,-1,0, - 0,0,-1,2,-1),byrow=TRUE,nrow=3) - - mat3 <- matrix(c(1,-5,10 , -10, 5,-1, 0, 0, 0, 0, - 0, 1,-5,10 , -10, 5,-1, 0, 0, 0, - 0, 0, 1,-5,10 , -10, 5,-1, 0, 0, - 0, 0, 0, 1,-5,10 , -10, 5,-1, 0, - 0, 0, 0, 0, 1,-5,10 , -10, 5, -1),byrow=TRUE,nrow=5) +test_that("Tests for difference matrix", { + mat1 <- matrix(c( + 1, -1, 0, 0, + 0, 1, -1, 0, + 0, 0, 1, -1 + ), byrow = TRUE, nrow = 3) + + mat2 <- matrix(c( + -1, 2, -1, 0, 0, + 0, -1, 2, -1, 0, + 0, 0, -1, 2, -1 + ), byrow = TRUE, nrow = 3) + + mat3 <- matrix(c( + 1, -5, 10, -10, 5, -1, 0, 0, 0, 0, + 0, 1, -5, 10, -10, 5, -1, 0, 0, 0, + 0, 0, 1, -5, 10, -10, 5, -1, 0, 0, + 0, 0, 0, 1, -5, 10, -10, 5, -1, 0, + 0, 0, 0, 0, 1, -5, 10, -10, 5, -1 + ), byrow = TRUE, nrow = 5) mat4 <- matrix(c( - -1, 4,-6, 4,-1, 0, 0, 0, 0, 0, - 0,-1, 4,-6, 4,-1, 0, 0, 0, 0, - 0, 0,-1, 4,-6, 4,-1, 0, 0, 0, - 0, 0, 0,-1, 4,-6, 4,-1, 0, 0, - 0, 0, 0, 0,-1, 4,-6, 4,-1, 0, - 0, 0, 0, 0, 0,-1, 4,-6, 4, -1),byrow=TRUE,nrow=6) - - mat5 <- matrix(c(1,-3, 3,-1, 0, 0, 0, - 0, 1,-3, 3,-1, 0, 0, - 0, 0, 1,-3, 3,-1, 0, - 0, 0, 0, 1,-3, 3,-1),byrow=TRUE,nrow=4) - expect_equal(norm(mat1-l1tf_diff_mat(4,0)),0) - expect_equal(norm(mat2-l1tf_diff_mat(5,1)),0) - expect_equal(norm(mat5-l1tf_diff_mat(7,2)),0) - expect_equal(norm(mat4-l1tf_diff_mat(10,3)),0) - expect_equal(norm(mat3-l1tf_diff_mat(10,4)),0) - + -1, 4, -6, 4, -1, 0, 0, 0, 0, 0, + 0, -1, 4, -6, 4, -1, 0, 0, 0, 0, + 0, 0, -1, 4, -6, 4, -1, 0, 0, 0, + 0, 0, 0, -1, 4, -6, 4, -1, 0, 0, + 0, 0, 0, 0, -1, 4, -6, 4, -1, 0, + 0, 0, 0, 0, 0, -1, 4, -6, 4, -1 + ), byrow = TRUE, nrow = 6) + + mat5 <- matrix(c( + 1, -3, 3, -1, 0, 0, 0, + 0, 1, -3, 3, -1, 0, 0, + 0, 0, 1, -3, 3, -1, 0, + 0, 0, 0, 1, -3, 3, -1 + ), byrow = TRUE, nrow = 4) + expect_equal(norm(mat1 - l1tf_diff_mat(4, 0)), 0) + expect_equal(norm(mat2 - l1tf_diff_mat(5, 1)), 0) + expect_equal(norm(mat5 - l1tf_diff_mat(7, 2)), 0) + expect_equal(norm(mat4 - l1tf_diff_mat(10, 3)), 0) + expect_equal(norm(mat3 - l1tf_diff_mat(10, 4)), 0) }) -test_that("Equivalent to polynomial regression",{ +test_that("Equivalent to polynomial regression", { # NOTE: theory to be confirmed set.seed(22) large_lam <- 100000 - t <- seq(0,10,0.1) + t <- seq(0, 10, 0.1) # an "N"-shape curve - y <- (t - 2)^2 + 0.2 * (3 - t)^3 + rnorm(length(t),sd = 2) + y <- (t - 2)^2 + 0.2 * (3 - t)^3 + rnorm(length(t), sd = 2) - for(deg in seq(2)){ + for (deg in seq(2)) { # WARNING: tests fail for deg >= 5 # polynomial regression fit - md <- lm(y~poly(t,deg,raw=TRUE)) - pr <- rep(0,length(t)) - for(i in 1:(deg+1)){ + md <- lm(y ~ poly(t, deg, raw = TRUE)) + pr <- rep(0, length(t)) + for (i in 1:(deg + 1)) { # poly regression - pr = pr + coef(md)[i] * t^(i-1) + pr <- pr + coef(md)[i] * t^(i - 1) } # trend filtering fit - tf <- test_prox_l1gf(y,1000000,deg) + tf <- test_prox_l1gf(y, 1000000, deg) - expect_equal(matrix(pr),tf) + expect_equal(matrix(pr), tf) } }) diff --git a/tests/testthat/test_logging.R b/tests/testthat/test_logging.R index 697e9400..5c9e513e 100644 --- a/tests/testthat/test_logging.R +++ b/tests/testthat/test_logging.R @@ -62,16 +62,16 @@ test_that("Supressing messages works", { test_that("No extra newlines", { moma_logger_level("DEBUG") - e <- tryCatch(MoMA:::moma_error("MY ERROR"), error=identity) + e <- tryCatch(MoMA:::moma_error("MY ERROR"), error = identity) expect_equal(str_count(e$message, "\n"), 1) - e <- tryCatch(MoMA:::moma_warning("MY WARNING"), warning=identity) + e <- tryCatch(MoMA:::moma_warning("MY WARNING"), warning = identity) expect_equal(str_count(e$message, "\n"), 1) - e <- tryCatch(MoMA:::moma_message("MY MESSAGE"), message=identity) + e <- tryCatch(MoMA:::moma_message("MY MESSAGE"), message = identity) expect_equal(str_count(e$message, "\n"), 1) - e <- tryCatch(MoMA:::moma_error("MY ERROR\nON TWO LINES"), error=identity) + e <- tryCatch(MoMA:::moma_error("MY ERROR\nON TWO LINES"), error = identity) expect_equal(str_count(e$message, "\n"), 2) moma_logger_level("MESSAGE") @@ -80,31 +80,41 @@ test_that("No extra newlines", { test_that("Function capture works at R level", { moma_logger_level("MESSAGE") - f <- function(x){MoMA:::moma_error("ERROR MESSAGE")} + f <- function(x) { + MoMA:::moma_error("ERROR MESSAGE") + } - e <- tryCatch(f(), error=identity) + e <- tryCatch(f(), error = identity) expect_str_contains(e$message, "ERROR MESSAGE") expect_str_contains(e$message, "(Called from f)") expect_true(is.null(e$call)) expect_true(is.null(e$cppstack)) - f <- function(x){MoMA:::moma_error("ERROR MESSAGE", call=FALSE)} - e <- tryCatch(f(), error=identity) + f <- function(x) { + MoMA:::moma_error("ERROR MESSAGE", call = FALSE) + } + e <- tryCatch(f(), error = identity) expect_false(grepl("\\(Called from f\\)", e$message)) - f <- function(x){MoMA:::moma_error("ERROR MESSAGE", call="my func")} - e <- tryCatch(f(), error=identity) + f <- function(x) { + MoMA:::moma_error("ERROR MESSAGE", call = "my func") + } + e <- tryCatch(f(), error = identity) expect_true(grepl("\\(Called from my func\\)", e$message)) - f <- function(x){MoMA:::moma_warning("WARNING MESSAGE", call=FALSE)} - e <- tryCatch(f(), warning=identity) + f <- function(x) { + MoMA:::moma_warning("WARNING MESSAGE", call = FALSE) + } + e <- tryCatch(f(), warning = identity) expect_false(grepl("\\(Called from f\\)", e$message)) - f <- function(x){MoMA:::moma_warning("WARNING MESSAGE", call="my func")} - e <- tryCatch(f(), warning=identity) + f <- function(x) { + MoMA:::moma_warning("WARNING MESSAGE", call = "my func") + } + e <- tryCatch(f(), warning = identity) expect_true(grepl("\\(Called from my func\\)", e$message)) }) diff --git a/tests/testthat/test_sfpca.R b/tests/testthat/test_sfpca.R index 82d26980..b7b4d840 100644 --- a/tests/testthat/test_sfpca.R +++ b/tests/testthat/test_sfpca.R @@ -2,131 +2,134 @@ context("SFPCA tests") test_that("Equivalent to SVD when no penalty imposed", { set.seed(32) - for(i in 1:30){ + for (i in 1:30) { n <- 17 # set n != p to test bugs p <- 23 - X = matrix(runif(n*p),n) + X <- matrix(runif(n * p), n) sfpca <- sfpca(X) svd.result <- svd(X) - svd.result$u[,1:4] + svd.result$u[, 1:4] sfpca$u - expect_equal(norm(svd.result$v[,1]-sfpca$v),0) - expect_equal(norm(svd.result$u[,1]-sfpca$u),0) - expect_equal(svd.result$d[1],sfpca$d[1]); + expect_equal(norm(svd.result$v[, 1] - sfpca$v), 0) + expect_equal(norm(svd.result$u[, 1] - sfpca$u), 0) + expect_equal(svd.result$d[1], sfpca$d[1]) } }) -test_that("Closed-form solution when Omega = I and no sparsity",{ +test_that("Closed-form solution when Omega = I and no sparsity", { set.seed(32) n <- 17 # set n != p to test bugs p <- 23 - a_u.range <- seq(0,3,0.05) - a_v.range <- seq(0,3,0.05) - for(a_u in a_u.range){ - for(a_v in a_v.range){ - for(solver in c("ISTA","FISTA","ONESTEPISTA")){ + a_u.range <- seq(0, 3, 0.05) + a_v.range <- seq(0, 3, 0.05) + for (a_u in a_u.range) { + for (a_v in a_v.range) { + for (solver in c("ISTA", "FISTA", "ONESTEPISTA")) { # NOTE: We can have one-step ISTA here - X = matrix(runif(n*p),n) + X <- matrix(runif(n * p), n) sfpca <- sfpca(X, - alpha_u=a_u,alpha_v=a_v,Omega_u=diag(n),Omega_v=diag(p), - EPS=1e-9,MAX_ITER = 1e+5,solver = solver) + alpha_u = a_u, alpha_v = a_v, Omega_u = diag(n), Omega_v = diag(p), + EPS = 1e-9, MAX_ITER = 1e+5, solver = solver + ) svd.result <- svd(X) - expect_equal(norm(svd.result$v[,1] - sqrt(1 + a_v) * sfpca$v),0) - expect_equal(norm(svd.result$u[,1] - sqrt(1 + a_u) * sfpca$u),0) - expect_equal(svd.result$d[1],sqrt((1 + a_v) * (1 + a_u)) * sfpca$d[1]); + expect_equal(norm(svd.result$v[, 1] - sqrt(1 + a_v) * sfpca$v), 0) + expect_equal(norm(svd.result$u[, 1] - sqrt(1 + a_u) * sfpca$u), 0) + expect_equal(svd.result$d[1], sqrt((1 + a_v) * (1 + a_u)) * sfpca$d[1]) } } } }) -test_that("Closed-form solution when no sparsity imposed",{ +test_that("Closed-form solution when no sparsity imposed", { n <- 17 # set n != p to test bugs p <- 23 set.seed(32) - X = matrix(runif(n*p),n) + X <- matrix(runif(n * p), n) # construct p.d. matrix as smoothing matrix - O_v = crossprod(matrix(runif(p*p),p,p)) - O_u = crossprod(matrix(runif(n*n),n,n)) + O_v <- crossprod(matrix(runif(p * p), p, p)) + O_u <- crossprod(matrix(runif(n * n), n, n)) # set some random alpha's # WARNING: running time increases quickly as alpha increases a_u.range <- seq(5) a_v.range <- seq(5) - for(a_u in a_u.range){ - for(a_v in a_v.range){ + for (a_u in a_u.range) { + for (a_v in a_v.range) { # Cholesky decomposition, note S = I + alpah * Omega - Lv = chol(a_v * O_v + diag(p)) - Lu = chol(a_u * O_u + diag(n)) + Lv <- chol(a_v * O_v + diag(p)) + Lu <- chol(a_u * O_u + diag(n)) svd.result <- svd(t(solve(Lu)) %*% X %*% solve(Lv)) - svd.result.v = svd.result$v[,1] - svd.result.u = svd.result$u[,1] + svd.result.v <- svd.result$v[, 1] + svd.result.u <- svd.result$u[, 1] - for(solver in c("ISTA","FISTA")){ + for (solver in c("ISTA", "FISTA")) { # WARNING: One-step ISTA does not pass this test res <- sfpca(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=a_u,alpha_v=a_v, - EPS=1e-7,MAX_ITER=1e+5,solve=solver) + Omega_u = O_u, Omega_v = O_v, alpha_u = a_u, alpha_v = a_v, + EPS = 1e-7, MAX_ITER = 1e+5, solve = solver + ) # The sfpca solutions and the svd solutions are related by an `L` matrix - res.v = Lv %*% res$v - res.u = Lu %*% res$u + res.v <- Lv %*% res$v + res.u <- Lu %*% res$u # same.direction = 1 if same direction else -1 - same.direction = ((svd.result$v[,1][1] * res.v[1]) > 0) * 2 - 1 + same.direction <- ((svd.result$v[, 1][1] * res.v[1]) > 0) * 2 - 1 # tests - expect_lte(norm(svd.result$v[,1] - same.direction * res.v),1e-5) - expect_lte(norm(svd.result$u[,1] - same.direction * res.u),1e-5) + expect_lte(norm(svd.result$v[, 1] - same.direction * res.v), 1e-5) + expect_lte(norm(svd.result$u[, 1] - same.direction * res.u), 1e-5) } } } }) test_that("ISTA and FISTA should yield similar results, - in the presence of both sparse and smooth penalty",{ + in the presence of both sparse and smooth penalty", { set.seed(332) n <- 7 # set n != p to test bugs p <- 11 - X = matrix(runif(n*p),n) + X <- matrix(runif(n * p), n) # generate p.d. matrices - O_v = crossprod(matrix(runif(p*p),p,p)) - O_u = crossprod(matrix(runif(n*n),n,n)) + O_v <- crossprod(matrix(runif(p * p), p, p)) + O_u <- crossprod(matrix(runif(n * n), n, n)) # run tests # NOTE: there's no need to test for large # lambda's and alpha's because in those # cases u and v are zeros - cnt = 0 - for(sp in seq(0,5,0.1)){ - for(sm in seq(0,5,0.1)){ + cnt <- 0 + for (sp in seq(0, 5, 0.1)) { + for (sm in seq(0, 5, 0.1)) { # TODO: Add "L1TRENDFILTERING" - for(sptype in c("LASSO","SCAD","MCP","ORDEREDFUSED")){ + for (sptype in c("LASSO", "SCAD", "MCP", "ORDEREDFUSED")) { ista <- sfpca(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=sp,alpha_v=sp, - lambda_u=sm,lambda_v=sm,P_u="LASSO",P_v=sptype, - EPS=1e-14,MAX_ITER = 1e+3,solve="ISTA",EPS_inner = 1e-9) + Omega_u = O_u, Omega_v = O_v, alpha_u = sp, alpha_v = sp, + lambda_u = sm, lambda_v = sm, P_u = "LASSO", P_v = sptype, + EPS = 1e-14, MAX_ITER = 1e+3, solve = "ISTA", EPS_inner = 1e-9 + ) fista <- sfpca(X, - Omega_u=O_u,Omega_v=O_v,alpha_u=sp,alpha_v=sp, - lambda_u=sm,lambda_v=sm,P_u="LASSO",P_v=sptype, - EPS=1e-6,MAX_ITER = 1e+3,solve="FISTA",EPS_inner = 1e-9) + Omega_u = O_u, Omega_v = O_v, alpha_u = sp, alpha_v = sp, + lambda_u = sm, lambda_v = sm, P_u = "LASSO", P_v = sptype, + EPS = 1e-6, MAX_ITER = 1e+3, solve = "FISTA", EPS_inner = 1e-9 + ) # WARNING: We observe if zero appears in either v or u, ista and fista # might not give identical results. # Maybe they will both eventually go to the same point, but ista slows # down a lot before it reaches it and consequently meets the stopping criterion. - if(sum(ista$v[,1] == 0.0) == 0 - && sum(fista$v[,1] == 0.0) == 0){ - expect_lte(sum((ista$v[,1]-fista$v[,1])^2),1e-6) - expect_lte(sum((ista$u[,1]-fista$u[,1])^2),1e-6) + if (sum(ista$v[, 1] == 0.0) == 0 + && sum(fista$v[, 1] == 0.0) == 0) { + expect_lte(sum((ista$v[, 1] - fista$v[, 1])^2), 1e-6) + expect_lte(sum((ista$u[, 1] - fista$u[, 1])^2), 1e-6) } } } } }) - diff --git a/tests/testthat/test_sparse_fused_lasso.R b/tests/testthat/test_sparse_fused_lasso.R index e1b57d48..cf72c81c 100644 --- a/tests/testthat/test_sparse_fused_lasso.R +++ b/tests/testthat/test_sparse_fused_lasso.R @@ -2,17 +2,19 @@ context("Sparse fused lasso tests") test_that("Same results as the `flsa` package", { set.seed(43) - if(requireNamespace("flsa")){ + if (requireNamespace("flsa")) { library(flsa) - pset = seq(2,8) - for(p in pset){ - for(i in 1:20){ + pset <- seq(2, 8) + for (p in pset) { + for (i in 1:20) { x <- 10 * runif(p) - for(lambda in seq(0,2,0.1)){ - for(lambda2 in seq(0,2,0.2)){ - expect_equal(test_prox_spfusedlasso(x,lambda,lambda2=lambda2), - matrix(flsaGetSolution(flsa(x),lambda2=lambda,lambda1=lambda2))) - } + for (lambda in seq(0, 2, 0.1)) { + for (lambda2 in seq(0, 2, 0.2)) { + expect_equal( + test_prox_spfusedlasso(x, lambda, lambda2 = lambda2), + matrix(flsaGetSolution(flsa(x), lambda2 = lambda, lambda1 = lambda2)) + ) + } } } } diff --git a/tests/testthat/test_sparsity_thresholding.R b/tests/testthat/test_sparsity_thresholding.R index 1f1c8420..b326b3f0 100644 --- a/tests/testthat/test_sparsity_thresholding.R +++ b/tests/testthat/test_sparsity_thresholding.R @@ -1,105 +1,121 @@ context("Thresolding Tests") test_that("Non-convexity parameter checks", { lambda <- 1 - x <- seq(-4, 4, 0.01) + x <- seq(-4, 4, 0.01) # Check valid non-convexity parameter for SCAD, MCP # Throw error if below threshold expect_error(test_prox_scad(x, lambda, 1.99)) - expect_error(test_prox_mcp( x, lambda, 0.99)) + expect_error(test_prox_mcp(x, lambda, 0.99)) expect_error(test_prox_scad(x, lambda, 2)) - expect_error(test_prox_mcp( x, lambda, 1)) + expect_error(test_prox_mcp(x, lambda, 1)) # Otherwise succeed expect_no_error(test_prox_scad(x, lambda, 2.1)) - expect_no_error(test_prox_mcp( x, lambda, 1.1)) - + expect_no_error(test_prox_mcp(x, lambda, 1.1)) }) test_that("When lambda = 0, prox operators are no-ops", { lambda <- 0 - x <- matrix(seq(-4, 4, 0.01), ncol=1) - - for(prox_func in c(test_prox_lasso, - test_prox_scad, - test_prox_mcp, - test_prox_scadvec, - test_prox_mcpvec, - test_prox_fusedlassopath)){ - expect_equal(x, - prox_func(x, lambda)) + x <- matrix(seq(-4, 4, 0.01), ncol = 1) + + for (prox_func in c( + test_prox_lasso, + test_prox_scad, + test_prox_mcp, + test_prox_scadvec, + test_prox_mcpvec, + test_prox_fusedlassopath + )) { + expect_equal( + x, + prox_func(x, lambda) + ) } }) test_that("When lambda = 0, non-negative prox operators zero-out negative values", { lambda <- 0 - x <- matrix(seq(-4, 4, 0.01), ncol=1) - - for(prox_func in c(test_prox_nnlasso, - test_prox_nnscad, - test_prox_nnmcp)){ - expect_equal(x * (x >= 0), - prox_func(x, lambda)) + x <- matrix(seq(-4, 4, 0.01), ncol = 1) + + for (prox_func in c( + test_prox_nnlasso, + test_prox_nnscad, + test_prox_nnmcp + )) { + expect_equal( + x * (x >= 0), + prox_func(x, lambda) + ) } }) test_that("Prox operators return correct results for lambda = 3", { lambda <- 1 - gamma <- 3 - x <- seq(-4, 4, 0.05) + gamma <- 3 + x <- seq(-4, 4, 0.05) # Worked out by hand, gamma = 3 for non-convex operators - lasso.goal <- matrix(c(-3.00,-2.95,-2.90,-2.85,-2.80,-2.75,-2.70,-2.65,-2.60,-2.55,-2.50,-2.45,-2.40,-2.35,-2.30,-2.25,-2.20,-2.15,-2.10,-2.05,-2.00,-1.95,-1.90,-1.85,-1.80,-1.75,-1.70,-1.65,-1.60,-1.55,-1.50,-1.45,-1.40,-1.35,-1.30,-1.25,-1.20,-1.15,-1.10,-1.05,-1.00,-0.95,-0.90,-0.85,-0.80,-0.75,-0.70,-0.65,-0.60,-0.55,-0.50,-0.45,-0.40,-0.35,-0.30,-0.25,-0.20,-0.15,-0.10,-0.05, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.05, 0.10, 0.15, 0.20, 0.25, 0.30, 0.35, 0.40, 0.45, 0.50, 0.55, 0.60, 0.65, 0.70, 0.75, 0.80, 0.85, 0.90, 0.95, 1.00, 1.05, 1.10, 1.15, 1.20, 1.25, 1.30, 1.35, 1.40, 1.45, 1.50, 1.55, 1.60, 1.65, 1.70, 1.75, 1.80, 1.85, 1.90, 1.95, 2.00, 2.05, 2.10, 2.15, 2.20, 2.25, 2.30, 2.35, 2.40, 2.45, 2.50, 2.55, 2.60, 2.65, 2.70, 2.75, 2.80, 2.85, 2.90, 2.95, 3.00), ncol=1) - scad.goal <- matrix(c(-4.00,-3.95,-3.90,-3.85,-3.80,-3.75,-3.70,-3.65,-3.60,-3.55,-3.50,-3.45,-3.40,-3.35,-3.30,-3.25,-3.20,-3.15,-3.10,-3.05,-3.00,-2.90,-2.80,-2.70,-2.60,-2.50,-2.40,-2.30,-2.20,-2.10,-2.00,-1.90,-1.80,-1.70,-1.60,-1.50,-1.40,-1.30,-1.20,-1.10,-1.00,-0.95,-0.90,-0.85,-0.80,-0.75,-0.70,-0.65,-0.60,-0.55,-0.50,-0.45,-0.40,-0.35,-0.30,-0.25,-0.20,-0.15,-0.10,-0.05, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.05, 0.10, 0.15, 0.20, 0.25, 0.30, 0.35, 0.40, 0.45, 0.50, 0.55, 0.60, 0.65, 0.70, 0.75, 0.80, 0.85, 0.90, 0.95, 1.00, 1.10, 1.20, 1.30, 1.40, 1.50, 1.60, 1.70, 1.80, 1.90, 2.00, 2.10, 2.20, 2.30, 2.40, 2.50, 2.60, 2.70, 2.80, 2.90, 3.00, 3.05, 3.10, 3.15, 3.20, 3.25, 3.30, 3.35, 3.40, 3.45, 3.50, 3.55, 3.60, 3.65, 3.70, 3.75, 3.80, 3.85, 3.90, 3.95, 4.00), ncol=1) - mcp.goal <- matrix(c(-4.000,-3.950,-3.900,-3.850,-3.800,-3.750,-3.700,-3.650,-3.600,-3.550,-3.500,-3.450,-3.400,-3.350,-3.300,-3.250,-3.200,-3.150,-3.100,-3.050,-3.000,-2.925,-2.850,-2.775,-2.700,-2.625,-2.550,-2.475,-2.400,-2.325,-2.250,-2.175,-2.100,-2.025,-1.950,-1.875,-1.800,-1.725,-1.650,-1.575,-1.500,-1.425,-1.350,-1.275,-1.200,-1.125,-1.050,-0.975,-0.900,-0.825,-0.750,-0.675,-0.600,-0.525,-0.450,-0.375,-0.300,-0.225,-0.150,-0.075, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.075, 0.150, 0.225, 0.300, 0.375, 0.450, 0.525, 0.600, 0.675, 0.750, 0.825, 0.900, 0.975, 1.050, 1.125, 1.200, 1.275, 1.350, 1.425, 1.500, 1.575, 1.650, 1.725, 1.800, 1.875, 1.950, 2.025, 2.100, 2.175, 2.250, 2.325, 2.400, 2.475, 2.550, 2.625, 2.700, 2.775, 2.850, 2.925, 3.000, 3.050, 3.100, 3.150, 3.200, 3.250, 3.300, 3.350, 3.400, 3.450, 3.500, 3.550, 3.600, 3.650, 3.700, 3.750, 3.800, 3.850, 3.900, 3.950, 4.000), ncol=1) + lasso.goal <- matrix(c(-3.00, -2.95, -2.90, -2.85, -2.80, -2.75, -2.70, -2.65, -2.60, -2.55, -2.50, -2.45, -2.40, -2.35, -2.30, -2.25, -2.20, -2.15, -2.10, -2.05, -2.00, -1.95, -1.90, -1.85, -1.80, -1.75, -1.70, -1.65, -1.60, -1.55, -1.50, -1.45, -1.40, -1.35, -1.30, -1.25, -1.20, -1.15, -1.10, -1.05, -1.00, -0.95, -0.90, -0.85, -0.80, -0.75, -0.70, -0.65, -0.60, -0.55, -0.50, -0.45, -0.40, -0.35, -0.30, -0.25, -0.20, -0.15, -0.10, -0.05, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.05, 0.10, 0.15, 0.20, 0.25, 0.30, 0.35, 0.40, 0.45, 0.50, 0.55, 0.60, 0.65, 0.70, 0.75, 0.80, 0.85, 0.90, 0.95, 1.00, 1.05, 1.10, 1.15, 1.20, 1.25, 1.30, 1.35, 1.40, 1.45, 1.50, 1.55, 1.60, 1.65, 1.70, 1.75, 1.80, 1.85, 1.90, 1.95, 2.00, 2.05, 2.10, 2.15, 2.20, 2.25, 2.30, 2.35, 2.40, 2.45, 2.50, 2.55, 2.60, 2.65, 2.70, 2.75, 2.80, 2.85, 2.90, 2.95, 3.00), ncol = 1) + scad.goal <- matrix(c(-4.00, -3.95, -3.90, -3.85, -3.80, -3.75, -3.70, -3.65, -3.60, -3.55, -3.50, -3.45, -3.40, -3.35, -3.30, -3.25, -3.20, -3.15, -3.10, -3.05, -3.00, -2.90, -2.80, -2.70, -2.60, -2.50, -2.40, -2.30, -2.20, -2.10, -2.00, -1.90, -1.80, -1.70, -1.60, -1.50, -1.40, -1.30, -1.20, -1.10, -1.00, -0.95, -0.90, -0.85, -0.80, -0.75, -0.70, -0.65, -0.60, -0.55, -0.50, -0.45, -0.40, -0.35, -0.30, -0.25, -0.20, -0.15, -0.10, -0.05, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.05, 0.10, 0.15, 0.20, 0.25, 0.30, 0.35, 0.40, 0.45, 0.50, 0.55, 0.60, 0.65, 0.70, 0.75, 0.80, 0.85, 0.90, 0.95, 1.00, 1.10, 1.20, 1.30, 1.40, 1.50, 1.60, 1.70, 1.80, 1.90, 2.00, 2.10, 2.20, 2.30, 2.40, 2.50, 2.60, 2.70, 2.80, 2.90, 3.00, 3.05, 3.10, 3.15, 3.20, 3.25, 3.30, 3.35, 3.40, 3.45, 3.50, 3.55, 3.60, 3.65, 3.70, 3.75, 3.80, 3.85, 3.90, 3.95, 4.00), ncol = 1) + mcp.goal <- matrix(c(-4.000, -3.950, -3.900, -3.850, -3.800, -3.750, -3.700, -3.650, -3.600, -3.550, -3.500, -3.450, -3.400, -3.350, -3.300, -3.250, -3.200, -3.150, -3.100, -3.050, -3.000, -2.925, -2.850, -2.775, -2.700, -2.625, -2.550, -2.475, -2.400, -2.325, -2.250, -2.175, -2.100, -2.025, -1.950, -1.875, -1.800, -1.725, -1.650, -1.575, -1.500, -1.425, -1.350, -1.275, -1.200, -1.125, -1.050, -0.975, -0.900, -0.825, -0.750, -0.675, -0.600, -0.525, -0.450, -0.375, -0.300, -0.225, -0.150, -0.075, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.075, 0.150, 0.225, 0.300, 0.375, 0.450, 0.525, 0.600, 0.675, 0.750, 0.825, 0.900, 0.975, 1.050, 1.125, 1.200, 1.275, 1.350, 1.425, 1.500, 1.575, 1.650, 1.725, 1.800, 1.875, 1.950, 2.025, 2.100, 2.175, 2.250, 2.325, 2.400, 2.475, 2.550, 2.625, 2.700, 2.775, 2.850, 2.925, 3.000, 3.050, 3.100, 3.150, 3.200, 3.250, 3.300, 3.350, 3.400, 3.450, 3.500, 3.550, 3.600, 3.650, 3.700, 3.750, 3.800, 3.850, 3.900, 3.950, 4.000), ncol = 1) - expect_equal(test_prox_lasso(x, lambda), lasso.goal) + expect_equal(test_prox_lasso(x, lambda), lasso.goal) expect_equal(test_prox_scad(x, lambda, gamma), scad.goal) - expect_equal(test_prox_mcp(x, lambda, gamma), mcp.goal) + expect_equal(test_prox_mcp(x, lambda, gamma), mcp.goal) }) test_that("Non-negative prox operators match for non-negative input", { lambda <- seq(1, 4) - x <- matrix(seq(0, 5, 0.05), ncol=1) - - for(l in lambda){ - expect_equal(test_prox_lasso(x, l), - test_prox_nnlasso(x, l)) - - expect_equal(test_prox_scad(x, l), - test_prox_nnscad(x, l)) - - expect_equal(test_prox_mcp(x, l), - test_prox_nnmcp(x, l)) + x <- matrix(seq(0, 5, 0.05), ncol = 1) + + for (l in lambda) { + expect_equal( + test_prox_lasso(x, l), + test_prox_nnlasso(x, l) + ) + + expect_equal( + test_prox_scad(x, l), + test_prox_nnscad(x, l) + ) + + expect_equal( + test_prox_mcp(x, l), + test_prox_nnmcp(x, l) + ) } }) -test_that("Group lasso proximal operators return correct results",{ +test_that("Group lasso proximal operators return correct results", { set.seed(32) - for(grp_prox in c(test_prox_grplasso)){ - for(rep in 1:10){ + for (grp_prox in c(test_prox_grplasso)) { + for (rep in 1:10) { x <- runif(7) # When every element forms a group = lasso - gp <- as.factor(c(1,2,3,4,5,6,7)) - expect_equal(test_prox_lasso(x,0),grp_prox(x,gp,0)) - for(lambda in seq(0,10,0.2)){ - expect_equal(test_prox_lasso(x,lambda),grp_prox(x,gp,lambda)) + gp <- as.factor(c(1, 2, 3, 4, 5, 6, 7)) + expect_equal(test_prox_lasso(x, 0), grp_prox(x, gp, 0)) + for (lambda in seq(0, 10, 0.2)) { + expect_equal(test_prox_lasso(x, lambda), grp_prox(x, gp, lambda)) } } } - for(grp_prox in c(test_prox_grplasso)){ + for (grp_prox in c(test_prox_grplasso)) { # When the all the elements are grouped - for(rep in 1:10){ + for (rep in 1:10) { x <- runif(10) - gp <- factor(rep(0,10)) - lambda <- seq(0,5,0.2) - for(l in lambda){ - scale <- 1-l/sqrt(sum(x^2)) - if(scale < 0) - scale = 0 - expect_equal(matrix(scale*x,10,1), - test_prox_grplasso(x,gp,l)) + gp <- factor(rep(0, 10)) + lambda <- seq(0, 5, 0.2) + for (l in lambda) { + scale <- 1 - l / sqrt(sum(x^2)) + if (scale < 0) { + scale <- 0 + } + expect_equal( + matrix(scale * x, 10, 1), + test_prox_grplasso(x, gp, l) + ) } } } @@ -107,20 +123,25 @@ test_that("Group lasso proximal operators return correct results",{ # TODO: test for non-negative group lasso # When the all the elements are grouped - for(rep in 1:10){ + for (rep in 1:10) { x <- runif(10) - gp <- factor(rep(0,10)) - lambda <- seq(0,1,0.1) + gp <- factor(rep(0, 10)) + lambda <- seq(0, 1, 0.1) - for(l in lambda){ + for (l in lambda) { x_pos <- x * (x > 0) - scale <- 1-l/sqrt(sum(x^2)) - expect_equal(matrix(scale*x_pos,10,1), - test_prox_nngrplasso(x,gp,l)) - if(scale < 0) - scale = 0 - expect_equal(matrix(scale*x_pos,10,1), - test_prox_grplasso(x_pos,gp,l)) + scale <- 1 - l / sqrt(sum(x^2)) + expect_equal( + matrix(scale * x_pos, 10, 1), + test_prox_nngrplasso(x, gp, l) + ) + if (scale < 0) { + scale <- 0 + } + expect_equal( + matrix(scale * x_pos, 10, 1), + test_prox_grplasso(x_pos, gp, l) + ) } } }) diff --git a/tests/testthat/test_unordered_fusion.R b/tests/testthat/test_unordered_fusion.R index b4bd6946..ad1c0d84 100644 --- a/tests/testthat/test_unordered_fusion.R +++ b/tests/testthat/test_unordered_fusion.R @@ -7,25 +7,27 @@ test_that("Find means of everything when lambda is large enough and the graph is set.seed(43) rep <- 10 large.lambda <- 10000 - for(p in c(5,30,40,100)){ + for (p in c(5, 30, 40, 100)) { y <- runif(p) # A fully connected graph with random weights - w <- matrix(rep(0,p*p),p,byrow = T) - for(i in 1:p-1){ - for(j in (i+1):p){ - w[i,j] = runif(1)+1 + w <- matrix(rep(0, p * p), p, byrow = T) + for (i in 1:p - 1) { + for (j in (i + 1):p) { + w[i, j] <- runif(1) + 1 } } - for(i in 1:rep){ - res.AMA = test_prox_fusion(y,large.lambda,w,ADMM=FALSE,acc=FALSE) - res.AMA.acc = test_prox_fusion(y,large.lambda,w,ADMM=FALSE,acc=TRUE) - res.ADMM = test_prox_fusion(y,large.lambda,w,ADMM=TRUE,acc=FALSE) - for(j in c(res.AMA, - res.AMA.acc, - res.ADMM)){ - expect_equal(j,mean(y)) + for (i in 1:rep) { + res.AMA <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = FALSE) + res.AMA.acc <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = TRUE) + res.ADMM <- test_prox_fusion(y, large.lambda, w, ADMM = TRUE, acc = FALSE) + for (j in c( + res.AMA, + res.AMA.acc, + res.ADMM + )) { + expect_equal(j, mean(y)) } } } @@ -35,27 +37,29 @@ test_that("Find means of connected components when lambda is large enough", { set.seed(33) rep <- 10 large.lambda <- 1000 - for(p in c(9,99)){ + for (p in c(9, 99)) { # A weight matrix of 3 connected components - w <- matrix(rep(0,p*p),p,byrow = T) - num.comp.nodes <- p/3 # the number of nodes in each component - for(i in seq(1,p,num.comp.nodes)){ - w[i,(i+1):(i+num.comp.nodes-1)] <- 1+runif(num.comp.nodes-1) + w <- matrix(rep(0, p * p), p, byrow = T) + num.comp.nodes <- p / 3 # the number of nodes in each component + for (i in seq(1, p, num.comp.nodes)) { + w[i, (i + 1):(i + num.comp.nodes - 1)] <- 1 + runif(num.comp.nodes - 1) } - for(j in 1:rep){ + for (j in 1:rep) { y <- 10 * runif(p) - res.AMA.unacc = test_prox_fusion(y,large.lambda,w,ADMM=FALSE,acc=TRUE) - res.AMA.acc = test_prox_fusion(y,large.lambda,w,ADMM=FALSE,acc=TRUE) - res.ADMM = test_prox_fusion(y,large.lambda,w,ADMM=TRUE,acc=FALSE) - for(res in list(res.AMA.unacc, - res.AMA.acc, - res.ADMM)){ - for(i in 1:p){ - start <- ((i-1) %/% num.comp.nodes) * num.comp.nodes + 1 + res.AMA.unacc <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = TRUE) + res.AMA.acc <- test_prox_fusion(y, large.lambda, w, ADMM = FALSE, acc = TRUE) + res.ADMM <- test_prox_fusion(y, large.lambda, w, ADMM = TRUE, acc = FALSE) + for (res in list( + res.AMA.unacc, + res.AMA.acc, + res.ADMM + )) { + for (i in 1:p) { + start <- ((i - 1) %/% num.comp.nodes) * num.comp.nodes + 1 end <- start + num.comp.nodes - 1 - expect_lte(abs(res[i]-mean(y[start:end])),1e-6) + expect_lte(abs(res[i] - mean(y[start:end])), 1e-6) } } } @@ -68,23 +72,25 @@ test_that("Find means of connected components when lambda is large enough", { test_that("Ordered fused lasso when w_ij = 1 all j = i+1", { set.seed(44) rep <- 20 - for(p in c(3,20,100)){ + for (p in c(3, 20, 100)) { # A chained graph - w <- matrix(rep(0,p*p),p,byrow = T); - for(i in 1:(p-1)){ - w[i,i+1] = 1 + w <- matrix(rep(0, p * p), p, byrow = T) + for (i in 1:(p - 1)) { + w[i, i + 1] <- 1 } - for(i in 1:rep){ + for (i in 1:rep) { y <- 10 * runif(p) - err.AMA.unacc <- norm(test_prox_fusedlassodp(y,1)-test_prox_fusion(y,1,w,ADMM=FALSE,acc=TRUE)) - err.AMA.acc <- norm(test_prox_fusedlassodp(y,1)-test_prox_fusion(y,1,w,ADMM=FALSE,acc=TRUE)) - err.ADMM <- norm(test_prox_fusedlassodp(y,1)-test_prox_fusion(y,1,w,ADMM=TRUE,acc=FALSE)) - for(err in c(err.AMA.unacc, - err.AMA.acc, - err.ADMM)){ - expect_lte(err,1e-4) + err.AMA.unacc <- norm(test_prox_fusedlassodp(y, 1) - test_prox_fusion(y, 1, w, ADMM = FALSE, acc = TRUE)) + err.AMA.acc <- norm(test_prox_fusedlassodp(y, 1) - test_prox_fusion(y, 1, w, ADMM = FALSE, acc = TRUE)) + err.ADMM <- norm(test_prox_fusedlassodp(y, 1) - test_prox_fusion(y, 1, w, ADMM = TRUE, acc = FALSE)) + for (err in c( + err.AMA.unacc, + err.AMA.acc, + err.ADMM + )) { + expect_lte(err, 1e-4) } } } @@ -96,53 +102,57 @@ test_that("Ordered fused lasso when w_ij = 1 all j = i+1", { # Find the weight vector required by the # `cvxclustr` package -mat_to_vec <- function(my.w,p){ - cnt = 1 - cvx.w <- vector(mode="numeric",length=p*(p-1)/2) - for(jj in 1:(p-1)) for(ii in (jj+1):p){ - cvx.w[cnt] <-my.w[jj,ii] - cnt = cnt + 1 +mat_to_vec <- function(my.w, p) { + cnt <- 1 + cvx.w <- vector(mode = "numeric", length = p * (p - 1) / 2) + for (jj in 1:(p - 1)) { + for (ii in (jj + 1):p) { + cvx.w[cnt] <- my.w[jj, ii] + cnt <- cnt + 1 + } } return(cvx.w) } test_that("Unweighted and fully connected graph, i.e., w_ij = 1 for all i, j", { - if(requireNamespace("cvxclustr")){ + if (requireNamespace("cvxclustr")) { set.seed(33) rep <- 20 - for(p in c(30,100)){ + for (p in c(30, 100)) { # A weight matrix where w_ij = 1, all i, j - w <- matrix(rep(1,p*p),p,byrow = T); - for(i in 1:(p-1)){ - for(j in (i+1):p){ - w[i,j] <- runif(1) + 1 + w <- matrix(rep(1, p * p), p, byrow = T) + for (i in 1:(p - 1)) { + for (j in (i + 1):p) { + w[i, j] <- runif(1) + 1 } } - for(i in 1:rep){ + for (i in 1:rep) { y <- 10 * runif(p) y <- t(matrix(y)) # The cvxclustr package stores weights as a vector. # For Gaussian kernel, wij = exp(-phi ||X[,i]-X[,j]||^2) # So phi = 0 makes a fully connected and unweighted graph - for(lambda in seq(0,1,0.13)){ - cvx.result <- cvxclustr::cvxclust(y,mat_to_vec(w,p),lambda,method = "admm",tol=1e-10)$U[[1]] + for (lambda in seq(0, 1, 0.13)) { + cvx.result <- cvxclustr::cvxclust(y, mat_to_vec(w, p), lambda, method = "admm", tol = 1e-10)$U[[1]] - admm <- t(matrix(test_prox_fusion(y,lambda,w,ADMM=TRUE,acc=FALSE))) - ama <- t(matrix(test_prox_fusion(y,lambda,w,ADMM=FALSE,acc=FALSE))) - ama.acc <- t(matrix(test_prox_fusion(y,lambda,w,ADMM=FALSE,acc=TRUE))) + admm <- t(matrix(test_prox_fusion(y, lambda, w, ADMM = TRUE, acc = FALSE))) + ama <- t(matrix(test_prox_fusion(y, lambda, w, ADMM = FALSE, acc = FALSE))) + ama.acc <- t(matrix(test_prox_fusion(y, lambda, w, ADMM = FALSE, acc = TRUE))) } - err.AMA.unacc <- norm(cvx.result-ama) - err.AMA.acc <- norm(cvx.result-ama.acc) - err.ADMM <- norm(cvx.result-admm) - for(err in c(err.AMA.unacc, - err.AMA.acc, - err.ADMM)){ - expect_lte(err,1e-6) + err.AMA.unacc <- norm(cvx.result - ama) + err.AMA.acc <- norm(cvx.result - ama.acc) + err.ADMM <- norm(cvx.result - admm) + for (err in c( + err.AMA.unacc, + err.AMA.acc, + err.ADMM + )) { + expect_lte(err, 1e-6) } } } From 781db8add51a79ea388320cf5ff89fb6fc25c3f1 Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Tue, 18 Jun 2019 20:46:23 +0800 Subject: [PATCH 6/7] case 5 -> case 6 --- tests/testthat/test_BIC_gird_mixed.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test_BIC_gird_mixed.R b/tests/testthat/test_BIC_gird_mixed.R index 493b37d7..9a271260 100644 --- a/tests/testthat/test_BIC_gird_mixed.R +++ b/tests/testthat/test_BIC_gird_mixed.R @@ -187,7 +187,7 @@ test_that("BIC search returns correct-sized grid: one grid", { test_that("BIC search returns correct-sized grid: all BIC search", { - # Case 5: one grid requests, both on u side, and two BIC + # Case 6: one grid requests, both on u side, and two BIC result4 <- do.call( testnestedBIC, c( From 7786ab61dadc7da466589d3844035bbc8513f1d0 Mon Sep 17 00:00:00 2001 From: Luofeng Liao Date: Mon, 24 Jun 2019 14:20:40 +0800 Subject: [PATCH 7/7] sum( ) > 0 -> any( ) --- .gitignore | 1 + R/moma_svd.R | 4 ++-- tests/testthat/test_arguments.R | 11 +++++++++++ 3 files changed, 14 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 3f740efb..a07ee71f 100644 --- a/.gitignore +++ b/.gitignore @@ -45,3 +45,4 @@ figs/* # visualization plots tests/testthat/*.pdf .vscode/settings.json +myformat.sh diff --git a/R/moma_svd.R b/R/moma_svd.R index 65d9217b..c86460bd 100644 --- a/R/moma_svd.R +++ b/R/moma_svd.R @@ -90,7 +90,7 @@ moma_svd <- function( all_para <- c(alpha_u, alpha_v, lambda_u, lambda_v) # verify all alphas and lambdas are positive numbers - if (sum(all_para < 0) > 0 || sum(!is.finite(all_para)) > 0) { + if (any(all_para < 0) || any(!is.finite(all_para))) { moma_error( "All penalty levels (", sQuote("lambda_u"), ", ", @@ -128,7 +128,7 @@ moma_svd <- function( if (!is.matrix(X)) { moma_error("X must be a matrix.") } - if (sum(!is.finite(X)) >= 1) { + if (any(!is.finite(X))) { moma_error("X must not have NaN, NA, or Inf.") } n <- dim(X)[1] diff --git a/tests/testthat/test_arguments.R b/tests/testthat/test_arguments.R index b8993d5b..9b190be2 100644 --- a/tests/testthat/test_arguments.R +++ b/tests/testthat/test_arguments.R @@ -409,6 +409,17 @@ test_that("Negative penalty", { fixed = TRUE ) + # Prompt error when penalty contains Infty + expect_error(moma_svd(X = X, lambda_v = c(1:3, Inf)), + paste0( + "All penalty levels (", + sQuote("lambda_u"), ", ", + sQuote("lambda_v"), ", ", + sQuote("alpha_u"), ", ", + sQuote("alpha_v"), ") must be non-negative numeric." + ), + fixed = TRUE + ) # Prompt error when passing a matrix expect_error(moma_svd(X = X, lambda_v = matrix(1:12, 3)),