Refactor the use of additional parameters for netsgcca

R/format_output.R

@@ -65,15 +65,15 @@ format_output <- function(func_out, rgcca_args, opt, blocks) {
   names(func_out$a) <- names(blocks)
   names(func_out$Y) <- names(blocks)
 
-  is_optimal <- any(rgcca_args[[opt$par]] == "optimal")
+  is_optimal <- any(rgcca_args[[opt$param]] == "optimal")
   func_out[["optimal"]] <- is_optimal
 
   if (is_optimal) {
-    rgcca_args[[opt$par]] <- func_out$tau
+    rgcca_args[[opt$param]] <- func_out$tau
   }
 
-  if (NCOL(rgcca_args[[opt$par]]) > 1) {
-    colnames(rgcca_args[[opt$par]]) <- names(blocks)
+  if (NCOL(rgcca_args[[opt$param]]) > 1) {
+    colnames(rgcca_args[[opt$param]]) <- names(blocks)
   }
 
   if (!is.null(func_out$tau)) {

R/netsgcca.R

@@ -38,7 +38,7 @@
 
 netsgcca <- function(blocks, connection = 1 - diag(length(blocks)),
                      sparsity = rep(1, length(blocks)),
-                     lambda = rep(1, length(A)),
+                     lambda = rep(1, length(blocks)),
                      graph_laplacians,
                      ncomp = rep(1, length(blocks)), scheme = "centroid",
                      init = "svd", bias = TRUE, tol = .Machine$double.eps,

R/rgcca.R

@@ -444,7 +444,7 @@ rgcca <- function(blocks, connection = NULL, tau = 1, ncomp = 1,
     warning("Argument C is deprecated, use connection instead.")
     connection <- C
   }
-  
+
   rgcca_args <- as.list(environment())
   ### If specific objects are given for blocks, parameters are imported from
   #   these objects.
@@ -453,15 +453,15 @@ rgcca <- function(blocks, connection = NULL, tau = 1, ncomp = 1,
   rgcca_args <- tmp$rgcca_args
   rgcca_args$quiet <- quiet
   rgcca_args$verbose <- verbose
-  
+
   blocks <- remove_null_sd(rgcca_args$blocks)$list_m
-  
+
   if (opt$disjunction) {
     blocks[[rgcca_args$response]] <- as_disjunctive(
       blocks[[rgcca_args$response]]
     )
   }
-  
+
   ### Apply strategy to deal with NA, scale and prepare superblock
   tmp <- handle_NA(blocks, NA_method = rgcca_args$NA_method)
   na.rm <- tmp$na.rm
@@ -477,7 +477,7 @@ rgcca <- function(blocks, connection = NULL, tau = 1, ncomp = 1,
       "s-", colnames(blocks[["superblock"]])
     )
   }
-  
+
   ### Call the gcca function
   gcca_args <- rgcca_args[c(
     "connection", "ncomp", "scheme", "init", "bias", "tol",
@@ -487,14 +487,12 @@ rgcca <- function(blocks, connection = NULL, tau = 1, ncomp = 1,
   gcca_args[["blocks"]] <- blocks
   gcca_args[["disjunction"]] <- opt$disjunction
   gcca_args[[opt$param]] <- rgcca_args[[opt$param]]
-  if (method == "netsgcca") {
-    gcca_args <- modifyList(gcca_args, rgcca_args[c("lambda", "graph_laplacians")])
-  }
+  gcca_args <- modifyList(gcca_args, opt$supplementary_parameters)
   func_out <- do.call(opt$gcca, gcca_args)
-  
+
   ### Format the output
   func_out <- format_output(func_out, rgcca_args, opt, blocks)
-  
+
   class(func_out) <- "rgcca"
   invisible(func_out)
 }