Merge branch 'main' into opt_model_names

Author: lebebr01

NAMESPACE

@@ -17,6 +17,7 @@ export(parse_multiplemember)
 export(parse_power)
 export(parse_randomeffect)
 export(parse_varyarguments)
+export(parse_varyarguments_mf)
 export(parse_varyarguments_w)
 export(random_missing)
 export(rbimod)

R/parse_formula.r

@@ -243,28 +243,63 @@ parse_varyarguments_w <- function(sim_args, name) {
 
   conditions <- expand.grid(list_select(sim_args[['vary_arguments']],
                                         names = name,
-                                        exclude = FALSE), 
+                                        exclude = FALSE),
                             KEEP.OUT.ATTRS = FALSE)
+  # conditions <- list_select(sim_args[['vary_arguments']],
+  #                           names = name,
+  #                           exclude = FALSE)
   if(any(sapply(conditions, is.list))) {
     loc <- sapply(conditions, is.list)
     simp_conditions <- conditions[loc != TRUE]
     list_conditions <- conditions[loc == TRUE]
-    list_conditions <- lapply(seq_along(list_conditions), function(xx) 
+    list_conditions <- lapply(seq_along(list_conditions), function(xx)
       unlist(list_conditions[xx], recursive = FALSE))
     for(tt in seq_along(list_conditions)) {
       names(list_conditions[[tt]]) <- gsub("[0-9]*", "", names(list_conditions[[tt]]))
     }
-    lapply(1:nrow(conditions), function(xx) c(sim_args, 
+    lapply(seq_along(conditions), function(xx) c(sim_args, 
                                               simp_conditions[xx, , drop = FALSE], 
-                                              do.call('c', lapply(seq_along(list_conditions), function(tt) 
-                                                list_conditions[[tt]][xx]))
+                                              do.call('c', lapply(seq_along(list_conditions), function(tt)
+                                                model_fit = list_conditions[xx]))
     ))
   } else {
     lapply(1:nrow(conditions), function(xx) c(sim_args, 
                                               conditions[xx, , drop = FALSE]))
   }
 
 }
+#' Parse within varying arguments
+#' 
+#' @param sim_args A named list with special model formula syntax. See details and examples
+#'   for more information. The named list may contain the following:
+#'   \itemize{
+#'     \item fixed: This is the fixed portion of the model (i.e. covariates)
+#'     \item random: This is the random portion of the model (i.e. random effects)
+#'     \item error: This is the error (i.e. residual term).
+#'   }
+#' @param name The name of the within simulation condition. This is primarily 
+#' an internal function.
+#'   
+#' @export
+parse_varyarguments_mf <- function(sim_args, name) {
+
+  conditions <- list_select(sim_args[['vary_arguments']],
+                            names = name,
+                            exclude = FALSE)
+  if(any(sapply(conditions, is.list))) {
+    loc <- sapply(conditions, is.list)
+    list_conditions <- conditions[loc == TRUE]
+    update_conditions <- lapply(seq_along(conditions), function(xx) c(sim_args, 
+                                                 model_fit = list_conditions[xx]))
+    for(xx in seq_along(update_conditions)) {
+      names(update_conditions[[xx]]) <- gsub("\\..*", "", names(update_conditions[[xx]]))
+    }
+  } else {
+    lapply(1:nrow(conditions), function(xx) c(sim_args, 
+                                              conditions[xx, , drop = FALSE]))
+  }
+  
+}
 
 
 #' Parse correlation arguments

R/pow_sim.r

@@ -144,20 +144,26 @@ replicate_simulation_vary <- function(sim_args, return_list = FALSE,
 
   within_conditions <- list_select(sim_args[['vary_arguments']],
                                    names = c('model_fit'),
-                                   exclude = FALSE)
+                                   exclude = FALSE, simplify = FALSE)
+  if(length(within_conditions) > 0 ) {
+    within_conditions_name <- names(
+      list_select(sim_args[['vary_arguments']],
+                  names = c('model_fit'),
+                  exclude = FALSE, simplify = TRUE)
+    )
+  }
   between_conditions <- list_select(sim_args[['vary_arguments']],
                                     names = c('model_fit', 'power'),
-                                    exclude = TRUE)
+                                    exclude = TRUE, simplify = FALSE)
 
   between_conditions_name <- data.frame(sapply(expand.grid(between_conditions, KEEP.OUT.ATTRS = FALSE),
                                                as.character))
-  within_conditions_name <- data.frame(sapply(expand.grid(within_conditions, KEEP.OUT.ATTRS = FALSE),
-                                              as.character))
+
 
   sim_arguments <- parse_varyarguments(sim_args)
 
-  if(length(within_conditions_name) > 0) {
-    sim_arguments_w <- parse_varyarguments_w(sim_args, name = c('model_fit'))
+  if(length(within_conditions) > 0) {
+    sim_arguments_w <- parse_varyarguments_mf(sim_args, name = c('model_fit'))
 
     if(any(unlist(lapply(seq_along(sim_arguments_w),  function(xx) 
       sim_arguments_w[[xx]][['model_fit']] |> names())) == 'name')) {
@@ -184,7 +190,7 @@ replicate_simulation_vary <- function(sim_args, return_list = FALSE,
       }, future.seed = future.seed)
     }, future.seed = future.seed)
   }
-  if(length(within_conditions_name) == 0) {
+  if(length(within_conditions) == 0) {
 
     power_out <- future.apply::future_lapply(seq_along(sim_arguments), function(xx) {
       future.apply::future_replicate(sim_arguments[[xx]][['replications']], 
@@ -209,7 +215,7 @@ replicate_simulation_vary <- function(sim_args, return_list = FALSE,
       rep(1:sim_args[['replications']], 
           each = num_rows[xx]/sim_args[['replications']]))
 
-    if(length(within_conditions_name) > 0) {
+    if(length(within_conditions) > 0) {
       num_terms <- lapply(seq_along(power_out), function(xx)
         lapply(seq_along(power_out[[xx]]), function(yy)
           lapply(power_out[[xx]][[yy]], nrow))

R/simglm_master_function.r

@@ -67,4 +67,4 @@ simglm_modelfit <- function(data, sim_args) {
   }
 
 data
-}
+}

R/util.r

@@ -393,7 +393,6 @@ list_select <- function(list, names, exclude = TRUE, simplify = FALSE) {
   } else {
     list[index]
   }
- 
 }
 
 # Horrible hack to keep CRAN happy and suppress NOTES about