Fix106

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: JointAI
-Version: 1.0.5.9000
+Version: 1.0.6
 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,6 +1,8 @@
 # JointAI (development version)
 
 * clean-up of helper functions and additional unit tests
+* fix typos in argument names in helpfiles
+* fix documentation syntax (CRAN NOTEs)
 
 --------------------------------------------------------------------------------
 

R/JAGSmodel_glmm.R

@@ -37,11 +37,11 @@ jagsmodel_glmm <- function(info) {
   ranefpriors <- paste0(
     unlist(
       lapply(names(info$hc_list$hcvars), function(lvl) {
-      if (isTRUE(info$rd_vcov[[lvl]] != "full")) {
-        ranef_priors(info$nranef[lvl], paste0("_", info$varname, "_", lvl),
-                     rd_vcov = info$rd_vcov[[lvl]])
-      }
-    })), collapse = "\n")
+        if (isTRUE(info$rd_vcov[[lvl]] != "full")) {
+          ranef_priors(info$nranef[lvl], paste0("_", info$varname, "_", lvl),
+                       rd_vcov = info$rd_vcov[[lvl]])
+        }
+      })), collapse = "\n")
 
 
 
@@ -101,7 +101,7 @@ jagsmodel_glmm <- function(info) {
          tab(), "}", "\n",
          "\n",
          paste0(unlist(sapply(names(rdintercept), write_ranefs, info = info,
-                       rdintercept = rdintercept, rdslopes = rdslopes)),
+                              rdintercept = rdintercept, rdslopes = rdslopes)),
                 collapse = ''),
          tab(), "# Priors for the model for ", info$varname, "\n",
          tab(), "for (k in ", min(unlist(info$parelmts)), ":",

R/JAGSmodel_surv.R

@@ -85,7 +85,7 @@ jagsmodel_survreg <- function(info) {
 
 
   paste0(tab(2L), add_dashes(paste0("# Weibull survival model for ",
-                                   info$varname)), "\n",
+                                    info$varname)), "\n",
          tab(), "for (", index, " in 1:", info$N[gsub("M_", "",
                                                       info$resp_mat[2L])],
          ") {", "\n",
@@ -177,7 +177,7 @@ jagsmodel_coxph <- function(info) {
                          assoc_type = info$assoc_type,
                          covnames = vector(mode = "list",
                                            length = length(info$lp[["M_lvlone"]]
-                                                           )),
+                                           )),
                          trafo = info$fcts_all,
                          isgk = FALSE)
       }), collapse = " + ")

R/build_model.R

@@ -25,19 +25,19 @@ write_model <- function(info_list, Mlist, modelfile = "") {
 
 
         paste0("\r",
-          tab(), "for (", index[lvl], " in 1:", Mlist$N[lvl], ") {", "\n",
+               tab(), "for (", index[lvl], " in 1:", Mlist$N[lvl], ") {", "\n",
 
-          # distribution specification
-          ranef_distr(nam = paste0(nam, "_", lvl),
-                      index = index[lvl],
-                      nranef = max(unlist(nranef))),
+               # distribution specification
+               ranef_distr(nam = paste0(nam, "_", lvl),
+                           index = index[lvl],
+                           nranef = max(unlist(nranef))),
 
-          paste_mu_b_full(lps = unlist(rd_lps, recursive = FALSE),
-                          nranef, paste0(nam, "_", lvl), index[lvl]),
-          "\n",
-          tab(), "}", "\n\n",
-          ranef_priors(max(unlist(nranef)), paste0(nam, "_", lvl),
-                       rd_vcov = "full")
+               paste_mu_b_full(lps = unlist(rd_lps, recursive = FALSE),
+                               nranef, paste0(nam, "_", lvl), index[lvl]),
+               "\n",
+               tab(), "}", "\n\n",
+               ranef_priors(max(unlist(nranef)), paste0(nam, "_", lvl),
+                            rd_vcov = "full")
         )
       })
     }
@@ -50,7 +50,7 @@ write_model <- function(info_list, Mlist, modelfile = "") {
         } else {
           k$custom
         }
-        }), collapse = "\n\n\n"),
+      }), collapse = "\n\n\n"),
 
       if (length(unlist(rd_vcov_full)) > 0) {
         paste0("\n\n\n\r", tab(),

R/get_model_info.R

@@ -186,8 +186,8 @@ get_model1_info <- function(k, Mlist, par_index_main, par_index_other,
     as.integer(attr(x, "rd_intercept")) +
       if (!is.null(x$rd_slope_coefs)) {
         nrow(x$rd_slope_coefs)
-      # if (any(!vapply(x$rd_slope_coefs, is.null, FUN.VALUE = logical(1L)))) {
-      #   nrow(do.call(rbind, x$rd_slope_coefs))
+        # if (any(!vapply(x$rd_slope_coefs, is.null, FUN.VALUE = logical(1L)))) {
+        #   nrow(do.call(rbind, x$rd_slope_coefs))
       } else {
         0L
       }
@@ -225,7 +225,7 @@ get_model1_info <- function(k, Mlist, par_index_main, par_index_other,
                       covrs)
 
     get_assoc_type(covrs[covrs %in% tvars],
-                             Mlist$models, assoc_type, Mlist$refs)
+                   Mlist$models, assoc_type, Mlist$refs)
   } else if (modeltype %in% "coxph") {
     "obs.value"
   } else if (isTRUE(isgk)) {

R/get_modeltypes.R

@@ -78,7 +78,7 @@ get_models <- function(fixed, random = NULL, data, auxvars = NULL,
     data[, allvars, drop = FALSE]
   }
 
-    all_lvls <- get_datlvls(dat_all, groups)
+  all_lvls <- get_datlvls(dat_all, groups)
 
 
 
@@ -149,14 +149,14 @@ get_models <- function(fixed, random = NULL, data, auxvars = NULL,
     models <- do.call(rbind,
                       c(types['outcome'],
                         if (any(!varinfo$out) & length(NA_lvls) > 0)
-                        lapply(1:max(NA_lvls), function(k) {
-                          set <- if (k == max(NA_lvls)) {
-                            c('incomplete_lvl')
-                          } else {
-                            c('incomplete_lvl', 'complete_lvl')
-                          }
-                          do.call(rbind, types[paste0(set, k)])
-                        })
+                          lapply(1:max(NA_lvls), function(k) {
+                            set <- if (k == max(NA_lvls)) {
+                              c('incomplete_lvl')
+                            } else {
+                              c('incomplete_lvl', 'complete_lvl')
+                            }
+                            do.call(rbind, types[paste0(set, k)])
+                          })
                       ))
 
     models <- unlist(setNames(models$type, models$L1))

R/helpfunctions.R

@@ -623,9 +623,9 @@ get_locf <- function(fixed, data, idvar, group_lvls, groups, timevar,
 
   md_list <- lapply(seq_len(nrow(md)), get_row, dat = md)
   locf <- lapply(md_list, find_locf_cols,
-              gk_time = which(names(md) == timevar),
-              time_cols = grep(paste0("^", timevar, "."), colnames(md)),
-              val_cols = valcol_nrs, longvars = longvars)
+                 gk_time = which(names(md) == timevar),
+                 time_cols = grep(paste0("^", timevar, "."), colnames(md)),
+                 val_cols = valcol_nrs, longvars = longvars)
 
 
   # locf <- nlapply(seq_len(nrow(md)), function(i) {

R/helpfunctions_melt.R

@@ -25,7 +25,7 @@ melt_list <- function(l, varname = "L1", valname = "value") {
       "In melt_list(): Element(s) %s has/have length zero.
              I will ignore this.",
       paste_and(names(Filter(\(x) length(x) == 0, x = l)),
-        dQ = TRUE
+                dQ = TRUE
       )
     )
     l <- Filter(Negate(\(x) length(x) == 0), l)
@@ -37,7 +37,7 @@ melt_list <- function(l, varname = "L1", valname = "value") {
     errormsg(
       "In melt_list(): Not all elements are atomic vectors (%s).",
       paste_and(names(Filter(\(x) !is.atomic(x) | !is.vector(x), l)),
-        dQ = TRUE
+                dQ = TRUE
       )
     )
   }
@@ -46,8 +46,8 @@ melt_list <- function(l, varname = "L1", valname = "value") {
     rbind,
     lapply(seq_along(l), function(k) {
       df <- as.data.frame(list(l[[k]]),
-        col.names = valname,
-        stringsAsFactors = FALSE
+                          col.names = valname,
+                          stringsAsFactors = FALSE
       )
 
       df[, varname] <- names(l)[k]
@@ -132,7 +132,7 @@ melt_matrix_list <- function(l, varnames = NULL) {
 
 
   if (is.null(varnames) &&
-    length(unique(lapply(l, \(x) names(dimnames(x))))) > 1L) {
+      length(unique(lapply(l, \(x) names(dimnames(x))))) > 1L) {
     errormsg(
       "In melt_matrix_list(): When the argument %s is not provided,
              all matrices must have the same names of their %s.",
@@ -218,7 +218,7 @@ melt_data_frame <- function(data, id_vars = NULL, varname = "variable",
     do.call(
       rbind,
       replicate(ncol(d), subset(data, select = id_vars),
-        simplify = FALSE
+                simplify = FALSE
       )
     )
   }
@@ -257,14 +257,14 @@ melt_data_frame <- function(data, id_vars = NULL, varname = "variable",
 melt_data_frame_list <- function(l, id_vars = NULL, varname = NULL,
                                  valname = "value", lname = "L1") {
   if (!inherits(l, "list") || !all(sapply(l, inherits, "data.frame") |
-    sapply(l, inherits, "NULL"))) {
+                                   sapply(l, inherits, "NULL"))) {
     errormsg("This function may not work for objects that are not a
              list of data frames.")
   }
 
   lnew <- lapply(l[!sapply(l, is.null)],
-    melt_data_frame, valname = valname,
-    varname = varname, id_vars = id_vars
+                 melt_data_frame, valname = valname,
+                 varname = varname, id_vars = id_vars
   )
 
   if (is.null(names(lnew))) {
@@ -278,3 +278,58 @@ melt_data_frame_list <- function(l, id_vars = NULL, varname = NULL,
 
   do.call(rbind, lnew)
 }
+
+
+
+# old version of the function; included for reverse dependency remiod;
+# re-introduced 2 April 2024
+#
+melt_data.frame <- function(data, id.vars = NULL, varnames = NULL,
+                            valname = 'value') {
+  if (!inherits(data, 'data.frame'))
+    errormsg("This function may not work for objects that are not data.frames.")
+
+  data$rowID <- paste0('rowID', seq_len(nrow(data)))
+  X <- data[, !names(data) %in% c('rowID', id.vars), drop = FALSE]
+
+  g <- list(rowID = data$rowID,
+            variable = if (ncol(X) > 0) names(X)
+  )
+
+  out <- expand.grid(Filter(Negate(is.null), g), stringsAsFactors = FALSE)
+
+  if (length(unique(sapply(X, class))) > 1) {
+    out[, valname] <- unlist(lapply(X, as.character))
+  } else {
+    out[, valname] <- unlist(X)
+  }
+
+  mout <- merge(data[, c("rowID", id.vars)], out)
+
+  attr(mout, 'out.attrs') <- NULL
+
+  if (ncol(X) > 0) mout[order(mout$variable), -1] else mout
+}
+
+melt_data.frame_list <- function(X, id.vars = NULL, varnames = NULL,
+                                 valname = 'value') {
+  if (!inherits(X, 'list') || !all(sapply(X, inherits, 'data.frame') |
+                                   sapply(X, inherits, 'NULL')))
+    errormsg("This function may not work for objects that are not a
+             list of data frames.")
+
+  Xnew <- lapply(X[!sapply(X, is.null)],
+                 melt_data.frame, varnames = varnames, id.vars = id.vars)
+
+  if (is.null(names(Xnew)))
+    names(Xnew) <- seq_along(Xnew)
+
+  Xnew <- lapply(names(Xnew), function(k) {
+    cbind(Xnew[[k]], L1 = k, stringsAsFactors = FALSE)
+  })
+
+  out <- do.call(rbind, Xnew)
+
+  attr(out, 'out.attrs') <- NULL
+  return(out)
+}

R/model_imp.R

@@ -731,7 +731,7 @@ model_imp <- function(formula = NULL, fixed = NULL, data, random = NULL,
   args <- as.list(match.call())
   if (!is.null(args$meth))
     errormsg("The argument %s has been replaced by the argument %s.",
-              dQuote("meth"), dQuote("models"))
+             dQuote("meth"), dQuote("models"))
 
   if (!is.null(args$parallel) | !is.null(args$n.cores)) {
     errormsg("The arguments %s and %s are no longer used. To perform the
@@ -757,11 +757,11 @@ model_imp <- function(formula = NULL, fixed = NULL, data, random = NULL,
 
   # * model dimensions ---------------------------------------------------------
   par_index_main <- get_model_dim(Mlist$lp_cols[names(Mlist$lp_cols) %in%
-                                     names(Mlist$fixed)],
-                     Mlist = Mlist)
+                                                  names(Mlist$fixed)],
+                                  Mlist = Mlist)
   par_index_other <- get_model_dim(Mlist$lp_cols[!names(Mlist$lp_cols) %in%
-                                         names(Mlist$fixed)],
-                         Mlist = Mlist)
+                                                   names(Mlist$fixed)],
+                                   Mlist = Mlist)
 
   # * model info ---------------------------------------------------------------
   info_list <- get_model_info(Mlist, par_index_main = par_index_main,

R/plot_imp_distr.R

@@ -41,8 +41,8 @@ plot_imp_distr <- function(data, imp = 'Imputation_', id = '.id',
   }
 
   subDF <- data[, (colSums(is.na(data[data[, imp] == 0, ])) > 0 &
-                   colSums(is.na(data[data[, imp] != 0, ])) == 0) |
-                names(data) %in% c(imp, id, rownr)]
+                     colSums(is.na(data[data[, imp] != 0, ])) == 0) |
+                  names(data) %in% c(imp, id, rownr)]
 
   DForig <- subDF[subDF[, imp] == 0, ]
 
@@ -84,44 +84,44 @@ plot_imp_distr <- function(data, imp = 'Imputation_', id = '.id',
                             labeller else "label_value"
       ) +
       ggplot2::scale_color_manual(name = '',
-                         limits = c(FALSE, TRUE),
-                         values = c('dodgerblue3', 'midnightblue'),
-                         labels = c('imputed', 'observed')) +
+                                  limits = c(FALSE, TRUE),
+                                  values = c('dodgerblue3', 'midnightblue'),
+                                  labels = c('imputed', 'observed')) +
       ggplot2::scale_fill_manual(name = '', limits = c(FALSE, TRUE),
-                        values = c('dodgerblue3', 'midnightblue'),
-                        labels = c('imputed', 'observed')) +
+                                 values = c('dodgerblue3', 'midnightblue'),
+                                 labels = c('imputed', 'observed')) +
       ggplot2::scale_linewidth_manual(name = '',
                                       limits = c(FALSE, TRUE),
                                       values = c(0.5, 1.3),
                                       labels = c('imputed', 'observed')) +
       ggplot2::xlab('')
-      if (unique(na.omit(dat$type) == 'numeric')) {
-        if (min(table(dat[, imp])) == 1) {
-          pl + ggplot2::stat_density(ggplot2::aes(x = as.numeric(.data$value),
-                                             color = get(imp) == 0,
-                                             linewidth = get(imp) == 0),
-                                     geom = 'line',
-                                position = 'identity', na.rm = TRUE) +
-            ggplot2::geom_point(data = subset(dat, get(imp) > 0),
-                                ggplot2::aes(x = as.numeric(.data$value),
-                                             y = 0, color = get(imp) == 0,
-                                             shape = get(imp) == 0),
-                                alpha = 0.5, show.legend = FALSE)
-        } else {
-          pl + ggplot2::stat_density(ggplot2::aes(x = as.numeric(.data$value),
-                                             linewidth = get(imp) == 0,
-                                             color = get(imp) == 0,
-                                             group = get(imp)), geom = 'line',
-                                position = 'identity', na.rm = TRUE)
-        }
+    if (unique(na.omit(dat$type) == 'numeric')) {
+      if (min(table(dat[, imp])) == 1) {
+        pl + ggplot2::stat_density(ggplot2::aes(x = as.numeric(.data$value),
+                                                color = get(imp) == 0,
+                                                linewidth = get(imp) == 0),
+                                   geom = 'line',
+                                   position = 'identity', na.rm = TRUE) +
+          ggplot2::geom_point(data = subset(dat, get(imp) > 0),
+                              ggplot2::aes(x = as.numeric(.data$value),
+                                           y = 0, color = get(imp) == 0,
+                                           shape = get(imp) == 0),
+                              alpha = 0.5, show.legend = FALSE)
       } else {
-        pl + ggplot2::geom_bar(ggplot2::aes(x = .data$value,
-                                            y = .data$proportion,
-                                       group = get(imp), fill = get(imp) == 0),
-                          position = "dodge", stat = 'identity',
-                          color = 'midnightblue') +
-          ggplot2::ylab('proportion')
+        pl + ggplot2::stat_density(ggplot2::aes(x = as.numeric(.data$value),
+                                                linewidth = get(imp) == 0,
+                                                color = get(imp) == 0,
+                                                group = get(imp)), geom = 'line',
+                                   position = 'identity', na.rm = TRUE)
       }
+    } else {
+      pl + ggplot2::geom_bar(ggplot2::aes(x = .data$value,
+                                          y = .data$proportion,
+                                          group = get(imp), fill = get(imp) == 0),
+                             position = "dodge", stat = 'identity',
+                             color = 'midnightblue') +
+        ggplot2::ylab('proportion')
+    }
   })
 
   # get number of rows and columns of plots