Code cleanup

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: JointAI
-Version: 1.0.6
+Version: 1.0.6.9000
 Title: Joint Analysis and Imputation of Incomplete Data
 Authors@R: c(person("Nicole S.", "Erler", email = "n.s.erler@umcutrecht.nl",
                   role = c("aut", "cre"),

NEWS.md

@@ -1,13 +1,25 @@
 # JointAI (development version)
 
+## Bug fixes
+* Error when using the same function twice in a model formula with different 
+  number of variables (e.g., I(x^2) and I(a/b)) fixed.
+
+## Small improvements
+* `all_vars()`: update of the function; can now handle an unspecified number of
+  input objects and can extract variable names from formulas and character 
+  strings that are valid variable names
+
+
+--------------------------------------------------------------------------------
+
+# JointAI 1.0.6
+
 * clean-up of helper functions and additional unit tests
 * fix typos in argument names in helpfiles
 * fix documentation syntax (CRAN NOTEs)
 
 --------------------------------------------------------------------------------
 
-
-
 # JointAI 1.0.5
 
 (update request by CRAN)

R/divide_matrices.R

@@ -9,8 +9,7 @@ divide_matrices <- function(data, fixed, random = NULL, analysis_type,
                             rd_vcov = rd_vcov, ...) {
 
   # id's and groups ------------------------------------------------------------
-  # extract the id variable from the random effects formula and get groups
-  idvar <- extract_id(random, warn = warn)
+  idvar <- extract_grouping(random, warn = warn)
 
   # re-format data for survival with time-varying covariates:
   # the time variables of the longitudinal measurements and the survival times
@@ -243,7 +242,7 @@ divide_matrices <- function(data, fixed, random = NULL, analysis_type,
   }
 
 
-  nranef <- get_nranef(idvar = idvar, random = random, data = data)
+  nranef <- get_nranef(random = random, data = data)
   rd_vcov <- check_rd_vcov(rd_vcov = rd_vcov, nranef = nranef)
 
   list(data = data,

R/get_modeltypes.R

@@ -26,7 +26,7 @@ get_models <- function(fixed, random = NULL, data, auxvars = NULL,
   }
 
   # check that all variables are found in the data
-  allvars <- unique(c(all_vars(c(fixed, random, auxvars)), timevar))
+  allvars <- all_vars(fixed, random, auxvars, timevar)
 
   if (any(!names(models) %in% names(data))) {
     errormsg("Variable(s) %s were not found in the data." ,
@@ -53,16 +53,18 @@ get_models <- function(fixed, random = NULL, data, auxvars = NULL,
 
 
   # extract the id variable from the random effects formula and get groups
-  idvar <- extract_id(random, warn = warn)
+  idvar <- extract_grouping(random, warn = warn)
   groups <- get_groups(idvar, data)
 
   random2 <- remove_grouping(random)
 
 
-  # new version of allvars, without the grouping variable
+  # NOTE: all_vars() checks if a string is a valid variable name but that is
+  # not the case for all names of fixed (e.g., Surv(time, status))
   allvars <- unique(c(names(fixed),
-                      all_vars(c(remove_lhs(fixed), random2, auxvars)),
-                      names(models), timevar))
+               all_vars(remove_lhs(fixed), random2, auxvars,
+                        names(models), timevar)
+  ))
 
   group_lvls <- colSums(!identify_level_relations(groups))
   max_lvl <- max(group_lvls)

R/get_refs.R

@@ -153,7 +153,7 @@ set_refcat <- function(data, formula, covars, auxvars = NULL) {# nocov start
     covars <- all_vars(remove_lhs(formula))
   }
   if (!is.null(auxvars))
-    covars <- unique(c(covars, all_vars(auxvars)))
+    covars <- all_vars(covars, auxvars)
 
   factors <- covars[sapply(data[covars], is.factor)]
 

R/helpfunctions.R

@@ -62,48 +62,88 @@ cvapply <- function(x, fun, ...) {
 
 # variable levels and grouping -------------------------------------------------
 
-get_groups <- function(idvar, data) {
-  # identify clusters/groups based on the id variables
-  # - idvar: vector of names of the id variables
-  # - data: a data.frame
+#' Get grouping information
+#'
+#' A helper function that generates grouping information from a data.frame
+#' and a character vector with the names of grouping variables.
+#' In all cases, the level "lvlone" is added to indicate the lowest level of
+#' the data (i.e., each observation is its own group).
+#'
+#' @param idvars a character vector with the names of grouping variables
+#' @param data a data.frame
+#'
+#' @returns a list with grouping information for each grouping level:
+#'          each element is a vector of length `nrow(data)` with the group
+#'          membership indices of each observation for the corresponding
+#'          grouping level.
+#' @keywords internal
+#'
+get_groups <- function(idvars, data) {
 
-  if (!is.null(idvar)) {
-    groups <- nlapply(idvar, function(i) {
+  if (!is.null(idvars)) {
+    groups <- nlapply(idvars, function(i) {
       match(data[, i], unique(data[, i]))
     })
 
-    # check for unnecessary nesting levels
-    gr_length <- ivapply(groups, function(x) length(unique(x))) == nrow(data)
-    if (any(gr_length)) {
-      if (sum(gr_length) == 1L) {
-        errormsg("The grouping level %s seem to be unnecessary.
-                 There are only unique observations at this level.",
-                 dQuote(names(gr_length[gr_length])))
-      } else {
-        errormsg("The grouping levels %s seem to be unnecessary.
-                 There are only unique observations at these levels.",
-                 paste_and(dQuote(names(gr_length[gr_length]))))
-      }
-    }
+    check_unnecessary_grouping_levels(groups, nrow(data))
+    check_duplicate_groupings(groups)
 
+    # add lowest-level grouping "lvlone"
     groups$lvlone <- seq_len(nrow(data))
 
-    # check for duplicate levels
-    gr_dupl <- duplicated(groups)
-    if (any(gr_dupl)) {
-      gr_dupl2 <- duplicated(groups, fromLast = TRUE)
-      errormsg("The grouping levels %s are duplicates.",
-               paste_and(dQuote(unique(c(names(groups)[gr_dupl],
-                                         names(groups)[gr_dupl2])))))
-    }
   } else {
     groups <- list(lvlone = seq_len(nrow(data)))
   }
 
-  groups
+  return(groups)
 }
 
 
+
+#' Check for unnecessary grouping levels
+#'
+#' @param groups a list of grouping information, as obtained from `get_groups()`
+#'
+#' @returns NULL; throws an error if unnecessary grouping levels are found
+#' @keywords internal
+#'
+check_unnecessary_grouping_levels <- function(groups, nrow_data) {
+  group_lengths <- ivapply(groups, function(x) length(unique(x)) == nrow_data)
+
+  if (any(group_lengths)) {
+    errormsg(
+      "The grouping level(s) %s seem(s) to be unnecessary.
+      There are only unique observations at these levels.",
+      paste_and(dQuote(names(group_lengths[group_lengths])))
+    )
+  }
+}
+
+#' Check for duplicate grouping levels
+#'
+#' @param groups a list of grouping information, as obtained from `get_groups()`
+#'
+#' @returns NULL; throws an error if duplicate grouping levels are found
+#' @keywords internal
+#'
+check_duplicate_groupings <- function(groups) {
+  group_duplicates <- duplicated(groups)
+  if (any(group_duplicates)) {
+    group_dupl2 <- duplicated(groups, fromLast = TRUE)
+    errormsg(
+      "The grouping levels %s are duplicates.",
+      paste_and(dQuote(unique(c(
+        names(groups)[group_duplicates],
+        names(groups)[group_dupl2]
+      ))))
+    )
+  }
+}
+
+
+
+
+
 check_cluster <- function(x, grouping) {
   # check if a variable varies within one cluster
   # - x: a vector

R/helpfunctions_JAGS.R

@@ -117,7 +117,7 @@ run_parallel <- function(n_adapt, n_iter, n_chains, inits, thin = 1L,
 
       if (isTRUE(mess) & isTRUE(parallel))
         msg("Parallel sampling with %s workers started (%s).",
-            length(f$workers), Sys.time())
+            future::nbrOfWorkers(), Sys.time())
 
       if (isTRUE(mess) & !isTRUE(parallel))
         msg("Note: the original model was run in parallel.")
@@ -165,7 +165,7 @@ run_parallel <- function(n_adapt, n_iter, n_chains, inits, thin = 1L,
     }
 
     fit$parallel <- parallel
-    fit$workers <- length(f$workers)
+    fit$workers <- future::nbrOfWorkers()
 
     if (!isTRUE(parallel)) {
       fit$time_adapt <- difftime_df(fit$time_adapt)