Merge pull request #639 from bbolker/master

migrate formula machinery from lme4 to reformulas

Author: jgabry

DESCRIPTION

@@ -48,7 +48,8 @@ Imports:
     stats,
     survival (>= 2.40.1),
     RcppParallel (>= 5.0.1),
-    utils
+    utils,
+    reformulas
 Suggests:
     biglm,
     betareg,

NAMESPACE

@@ -229,7 +229,7 @@ importFrom(ggplot2,scale_x_discrete)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,theme_bw)
 importFrom(ggplot2,xlab)
-importFrom(lme4,findbars)
+importFrom(reformulas,findbars)
 importFrom(lme4,fixef)
 importFrom(lme4,glFormula)
 importFrom(lme4,glmer)

R/jm_data_block.R

@@ -148,13 +148,13 @@ reformulate_lhs <- function(x) {
 # Reformulate an expression as the RHS of a model formula
 # 
 # @param x The expression to reformulate
-# @param subbars A logical specifying whether to call lme4::subbars
+# @param subbars A logical specifying whether to call reformulas::subbars
 #   on the result
 # @return A model formula
 reformulate_rhs <- function(x, subbars = FALSE) {
   fm <- formula(substitute(~ RHS, list(RHS = x)))
   if (subbars) {
-    lme4::subbars(fm)
+    reformulas::subbars(fm)
   } else {
     fm
   }
@@ -579,7 +579,7 @@ rename_t_and_cauchy <- function(prior_stuff, has) {
 #   has_aux: logical specifying whether the glmer submodel 
 #     requires an auxiliary parameter.
 handle_y_mod <- function(formula, data, family) {
-  mf <- stats::model.frame(lme4::subbars(formula), data)
+  mf <- stats::model.frame(reformulas::subbars(formula), data)
   if (!length(formula) == 3L)
     stop2("An outcome variable must be specified.")
 
@@ -647,7 +647,7 @@ make_y_for_stan <- function(formula, model_frame, family) {
 #   N,K: number of rows (observations) and columns (predictors) in the
 #     fixed effects model matrix
 make_x_for_stan <- function(formula, model_frame) {
-  x_form <- lme4::nobars(formula)
+  x_form <- reformulas::nobars(formula)
   x <- model.matrix(x_form, model_frame)
   has_intercept <- check_for_intercept(x, logical = TRUE)
   xtemp <- drop_intercept(x)
@@ -680,7 +680,7 @@ make_x_for_stan <- function(formula, model_frame) {
 #     grouping factor
 #   ngrps: a vector with the number of groups for each grouping factor 
 make_z_for_stan <- function(formula, model_frame) {
-  bars <- lme4::findbars(formula)
+  bars <- reformulas::findbars(formula)
   if (length(bars) > 2L)
     stop2("A maximum of 2 grouping factors are allowed.")
   z_parts <- lapply(bars, split_at_bars)
@@ -816,7 +816,7 @@ append_mvmer_famlink <- function(family, is_bernoulli = FALSE) {
 #   - the formula part (ie. the formula on the LHS of "|"), and 
 #   - the name of the grouping factor (ie. the variable on the RHS of "|")
 #
-# @param x Random effects part of a model formula, as returned by lme4::findbars
+# @param x Random effects part of a model formula, as returned by reformulas::findbars
 # @return A named list with the following elements:
 #   re_form: a formula specifying the random effects structure
 #   group_var: the name of the grouping factor
@@ -919,13 +919,13 @@ check_id_list <- function(id_var, y_flist) {
 #
 # @param terms The existing model frame terms object
 # @param formula The formula that was used to build the model frame
-#   (but prior to having called lme4::subbars on it!)
+#   (but prior to having called reformulas::subbars on it!)
 # @param data The data frame that was used to build the model frame
 # @return A terms object with predvars.fixed and predvars.random as
 #   additional attributes
 append_predvars_attribute <- function(terms, formula, data) {
-  fe_form <- lme4::nobars(formula)
-  re_form <- lme4::subbars(justRE(formula, response = TRUE))
+  fe_form <- reformulas::nobars(formula)
+  re_form <- reformulas::subbars(justRE(formula, response = TRUE))
   fe_frame <- stats::model.frame(fe_form, data)
   re_frame <- stats::model.frame(re_form, data)
   fe_terms <- attr(fe_frame, "terms")
@@ -1587,7 +1587,7 @@ parse_assoc_data <- function(x, user_x) {
     if (identical(length(fm), 3L))
       stop(paste0("Formula specified for '", x, "' association structure should not ",
                   "include a response."), call. = FALSE)
-    if (length(lme4::findbars(fm)))
+    if (length(reformulas::findbars(fm)))
       stop(paste0("Formula specified for '", x, "' association structure should only ",
                   "include fixed effects."), call. = FALSE)
     if (fm[[2L]] == 1)

R/jm_make_assoc_parts.R

@@ -190,17 +190,17 @@ make_assoc_parts_for_stan <- function(newdata, y_mod, include_Zt = TRUE) {
   # construct model frame using predvars
   formula <- use_predvars(y_mod, keep_response = FALSE)
   data <- as.data.frame(newdata)
-  model_frame <- stats::model.frame(lme4::subbars(formula), data)
+  model_frame <- stats::model.frame(reformulas::subbars(formula), data)
 
   # fe design matrices
-  x_form <- lme4::nobars(formula)
+  x_form <- reformulas::nobars(formula)
   x <- model.matrix(x_form, model_frame)
   xtemp <- drop_intercept(x)
   x_bar <- y_mod$x$x_bar
   xtemp <- sweep(xtemp, 2, x_bar, FUN = "-")
 
   # re design matrices
-  bars <- lme4::findbars(formula)
+  bars <- reformulas::findbars(formula)
   if (length(bars) > 2L)
     stop2("A maximum of 2 grouping factors are allowed.")
   z_parts <- lapply(bars, split_at_bars)
@@ -214,7 +214,7 @@ make_assoc_parts_for_stan <- function(newdata, y_mod, include_Zt = TRUE) {
 
   # optionally add the sparse Zt matrix
   if (include_Zt) 
-    ret$Zt <- lme4::mkReTrms(bars, model_frame)$Zt
+    ret$Zt <- reformulas::mkReTrms(bars, model_frame)$Zt
 
   # add offset values
   if ('offset' %in% colnames(newdata))

R/pp_data.R

@@ -97,7 +97,7 @@ pp_data <-
   offset <- model.offset(model.frame(object, m = m))
   if (!is.null(newdata) && (!is.null(offset) || !is.null(object$call$offset))) {
     if (is.jm(object)) {
-      form <- lme4::subbars(object$formula[[m]])
+      form <- reformulas::subbars(object$formula[[m]])
       form[2] <- NULL # get rid of response to avoid error that it isn't found in newdata
       mf <- stats::model.frame(form, data = newdata)
       offset <- model.offset(mf)
@@ -157,7 +157,7 @@ pp_data <-
   form <- if (is.null(m)) attr(object$glmod$fr, "formula") else 
     formula(object, m = m)
   L <- length(form)
-  form[[L]] <- lme4::nobars(form[[L]])
+  form[[L]] <- reformulas::nobars(form[[L]])
   RHS <- formula(substitute(~R, list(R = form[[L]])))
   Terms <- terms(object, m = m)
   mf <- model.frame(object, m = m)
@@ -225,7 +225,7 @@ pp_data <-
   if (length(fit.na.action <- attr(mfnew,"na.action")) > 0) {
     newdata <- newdata[-fit.na.action,]
   }
-  ReTrms <- lme4::mkReTrms(lme4::findbars(re.form[[2]]), rfd)
+  ReTrms <- reformulas::mkReTrms(reformulas::findbars(re.form[[2]]), rfd)
   if (!allow.new.levels && any(vapply(ReTrms$flist, anyNA, NA)))
     stop("NAs are not allowed in prediction data",
          " for grouping variables unless 'allow.new.levels' is TRUE.")

R/stan_clogit.R

@@ -90,7 +90,7 @@
 #' # not a random variable b/c probabilities add to 1 within strata
 #' all.equal(rep(sum(nd$case), nrow(pr)), rowSums(pr)) 
 #' }
-#' @importFrom lme4 findbars
+#' @importFrom reformulas findbars
 stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NULL,
                         ..., 
                         strata, prior = normal(autoscale=TRUE), 

R/stanmvreg-methods.R

@@ -192,7 +192,7 @@ formula.stanmvreg <- function (x, fixed.only = FALSE, random.only = FALSE, m = N
     stop2("Could not find formula in stanmvreg object.")
   if (fixed.only) {
     for (i in 1:M)
-      form[[i]][[length(form[[i]])]] <- lme4::nobars(form[[i]][[length(form[[i]])]])
+      form[[i]][[length(form[[i]])]] <- reformulas::nobars(form[[i]][[length(form[[i]])]])
   }
   if (random.only) {
     for (i in 1:M)
@@ -229,7 +229,7 @@ terms.stanmvreg <- function(x, fixed.only = TRUE, random.only = FALSE, m = NULL,
     } else if (random.only) {
       Terms <- lapply(seq(M), function(i) {
         re_form <- formula.stanmvreg(x, random.only = TRUE, m = i) 
-        tt <- terms.formula(lme4::subbars(re_form))
+        tt <- terms.formula(reformulas::subbars(re_form))
         attr(tt, "predvars") <- attr(mvmer_terms[[i]], "predvars.random")
         tt
       })      

R/stanreg-methods.R

@@ -459,7 +459,7 @@ terms.stanreg <- function(x, ..., fixed.only = TRUE, random.only = FALSE) {
     attr(Terms, "predvars") <- attr(terms(fr), "predvars.fixed")
   } 
   if (random.only) {
-    Terms <- terms.formula(lme4::subbars(formula.stanreg(x, random.only = TRUE)))
+    Terms <- terms.formula(reformulas::subbars(formula.stanreg(x, random.only = TRUE)))
     attr(Terms, "predvars") <- attr(terms(fr), "predvars.random")
   }
 
@@ -513,7 +513,7 @@ coef_mer <- function(object, ...) {
 
 justRE <- function(f, response = FALSE) {
   response <- if (response && length(f) == 3) f[[2]] else NULL
-  reformulate(paste0("(", vapply(lme4::findbars(f), 
+  reformulate(paste0("(", vapply(reformulas::findbars(f), 
                                  function(x) paste(deparse(x, 500L), 
                                                    collapse = " "), 
                                  ""), ")"), 
@@ -533,7 +533,7 @@ formula_mer <- function (x, fixed.only = FALSE, random.only = FALSE, ...) {
   }
   if (fixed.only) {
     form <- attr(fr, "formula")
-    form[[length(form)]] <- lme4::nobars(form[[length(form)]])
+    form[[length(form)]] <- reformulas::nobars(form[[length(form)]])
   }
   if (random.only)
     form <- justRE(form, response = TRUE)