Put parameters values in sparsity / smoothness specification

R/moma_arguments.R

@@ -15,11 +15,6 @@
 #' @name moma_sparsity
 NULL
 
-# Check whether `x` is a boolean value
-is_logical_scalar <- function(x) {
-    return(is.logical(x) && (length(x) == 1) && !is.na(x))
-}
-
 empty <- function() {
     arglist <- list()
     class(arglist) <- "moma_sparsity"
@@ -359,3 +354,67 @@ moma_pg_settings <- function(..., EPS = 1e-10, MAX_ITER = 1000,
     class(arglist) <- "moma_pg_settings"
     return(arglist)
 }
+
+create_moma_sparsity_func <- function(f) {
+    # Given f, we want to generate a new function, which
+    # 1. contains all arguments in f;
+    # 2. has two extra arguments `lambda` and `select_scheme`;
+    # 3. returns a list that contains ( f(...), lambda = ..., select_scheme = ... ).
+    aug_f <- function(..., lambda = 0, select_scheme = "g") {
+        chkDots(...)
+
+        # Step 2: check lambda
+        error_if_not_valid_parameters(lambda)
+
+        # Step 3: check select_scheme
+        error_if_not_valid_select_str(select_scheme)
+
+        # step 4: return
+        # WARNING: do not define local variables before
+        # `mget(ls())`
+        arg_for_f <- mget(ls())
+        arg_for_f <- arg_for_f[
+            names(arg_for_f) %in% c("lambda", "select_scheme") == FALSE
+        ] # fetch arguments for the function `f`
+        a <- list(
+            sparsity_type = do.call(f, arg_for_f),
+            lambda = lambda,
+            select_scheme = select_scheme
+        )
+        class(a) <- "moma_sparsity_type"
+        return(a)
+    }
+    formals(aug_f) <- c(formals(f), formals(aug_f))
+    aug_f
+}
+
+moma_empty <- create_moma_sparsity_func(empty)
+moma_lasso <- create_moma_sparsity_func(lasso)
+moma_mcp <- create_moma_sparsity_func(mcp)
+moma_scad <- create_moma_sparsity_func(scad)
+moma_slope <- create_moma_sparsity_func(slope)
+moma_grplasso <- create_moma_sparsity_func(grplasso)
+moma_fusedlasso <- create_moma_sparsity_func(fusedlasso)
+moma_l1tf <- create_moma_sparsity_func(l1tf)
+moma_spfusedlasso <- create_moma_sparsity_func(spfusedlasso)
+moma_cluster <- create_moma_sparsity_func(cluster)
+
+# What this function does now is just wrap three arguement
+# into a list.
+# TODO: `Omega` could be a user-defined function
+moma_smoothness <- function(Omega = NULL, ..., alpha = 0, select_scheme = "g") {
+
+    # Step 2: check lambda
+    error_if_not_valid_parameters(alpha)
+
+    # Step 3: check select_scheme
+    error_if_not_valid_select_str(select_scheme)
+
+    a <- list(
+        Omega = Omega,
+        alpha = alpha,
+        select_scheme = select_scheme
+    )
+    class(a) <- "moma_smoothness_type"
+    return(a)
+}

R/moma_expose.R

@@ -1,81 +1,3 @@
-MOMA_EMPTYMAT <- matrix()
-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) {
-    # 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
-    # `df_prox_arg_list_u/_v` and
-    # then update them.
-    return(modifyList(MOMA_DEFAULT_PROX, sparsity_type))
-}
-
-is.wholenumber <-
-    function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol
-
-# This function checks the validity of Omega and alpha
-check_omega <- function(Omega, alpha, n) {
-
-    # check if Omega is a matrix
-    if (!is.matrix(Omega) && !is.null(Omega)) {
-        moma_error("Omega_u/v is not a matrix.")
-    }
-
-    # TODO: store them as sparse matrices using the package Matrix
-    if (length(alpha) == 1 && alpha == 0) {
-        # discard the Omega matrix specified by users
-        Omega <- diag(n)
-    }
-    else if (is.null(Omega)) {
-        # The user wants smooth penalty
-        # but does not specify Omega matrix
-        Omega <- second_diff_mat(n) # TODO: should not overwrite
-    }
-    else {
-        # At this point, users have specified an Omega and
-        # non-zero penalty levels explicitly
-
-        # 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] != 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]
-            )
-        }
-        # TODO: check definiteness and symmetry of Omega
-    }
-    return(Omega)
-}
-
-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