droplevels in full_model.matrix, run-extended

R/model_matrix.R

@@ -1,35 +1,41 @@
 #' Combine `model.matrix` Objects of All Formulas of a `dynamiteformula`
 #'
-#' @inheritParams dynamite
+#' @inheritParams prepare_stan_input
 #' @srrstats {RE1.3, RE1.3a} `full_model.matrix` preserves relevant attributes.
 #' @noRd
-full_model.matrix <- function(dformula, data, verbose) {
+full_model.matrix <- function(dformula, data, group_var, fixed, verbose) {
   model_matrices <- vector(mode = "list", length = length(dformula))
   model_matrices_type <- vector(mode = "list", length = length(dformula))
   types <- c("fixed", "varying", "random")
+  idx <- data[,
+    .I[base::seq.int(fixed + 1L, .N)],
+    by = group,
+    env = list(fixed = fixed, group = group_var)
+  ]$V1
+  data_nonfixed <- droplevels(data[idx, , env = list(idx = idx)])
   for (i in seq_along(dformula)) {
     mm <- stats::model.matrix.lm(
       dformula[[i]]$formula,
-      data = data,
+      data = data_nonfixed,
       na.action = na.pass
     )
     if (verbose) {
-      test_collinearity(dformula[[i]]$resp, mm, data)
+      test_collinearity(dformula[[i]]$resp, mm, data_nonfixed)
     }
     model_matrices_type[[i]] <- list()
     for (type in c("fixed", "varying", "random")) {
       type_formula <- get_type_formula(dformula[[i]], type)
       if (!is.null(type_formula)) {
         model_matrices_type[[i]][[type]] <- stats::model.matrix.lm(
           type_formula,
-          data = data,
+          data = data_nonfixed,
           na.action = na.pass
         )
       }
     }
     tmp <- do.call(cbind, model_matrices_type[[i]])
     ifelse_(identical(length(tmp), 0L),
-      model_matrices[[i]] <- matrix(nrow = nrow(mm), ncol = 0),
+      model_matrices[[i]] <- matrix(nrow = nrow(mm), ncol = 0L),
       model_matrices[[i]] <- tmp
     )
   }

R/prepare_stan_input.R

@@ -32,7 +32,7 @@ prepare_stan_input <- function(dformula, data, group_var, time_var,
     "Can't find variable{?s} {.var {resp[resp_missing]}} in {.arg data}."
   )
   specials <- lapply(dformula, evaluate_specials, data = data)
-  model_matrix <- full_model.matrix(dformula, data, verbose)
+  model_matrix <- full_model.matrix(dformula, data, group_var, fixed, verbose)
   cg <- attr(dformula, "channel_groups")
   n_cg <- n_unique(cg)
   n_channels <- length(resp_names)
@@ -85,8 +85,7 @@ prepare_stan_input <- function(dformula, data, group_var, time_var,
   N <- n_unique(group)
   K <- ncol(model_matrix)
   X <- model_matrix[, ]
-  dim(X) <- c(T_full, N, K)
-  X <- X[T_idx, , , drop = FALSE]
+  dim(X) <- c(T_full - fixed, N, K)
   x_tmp <- X[1L, , , drop = FALSE]
   sd_x <- pmax(
     stats::setNames(apply(X, 3L, sd, na.rm = TRUE), colnames(model_matrix)),

tests/testthat/test-warnings.R

@@ -24,22 +24,32 @@ test_that("factor time conversion warns", {
 test_that("perfect collinearity warns", {
   f1 <- obs(y ~ -1 + x + z, family = "gaussian")
   f2 <- obs(y ~ z, family = "gaussian")
-  test_data1 <- data.frame(y = rnorm(10), x = rep(1, 10), z = rep(2, 10))
-  test_data2 <- data.frame(y = rep(1, 10), x = rep(1, 10), z = rnorm(10))
+  test_data1 <- data.table::data.table(
+    y = rnorm(10),
+    x = rep(1, 10),
+    z = rep(2, 10),
+    id = 1L
+  )
+  test_data2 <- data.table::data.table(
+    y = rep(1, 10),
+    x = rep(1, 10),
+    z = rnorm(10),
+    id = 1L
+  )
   expect_warning(
-    full_model.matrix(f1, test_data1, TRUE),
+    full_model.matrix(f1, test_data1, "id", 0L, TRUE),
     "Perfect collinearity found between predictor variables of channel `y`\\."
   )
   expect_warning(
-    full_model.matrix(f2, test_data2, TRUE),
+    full_model.matrix(f2, test_data2, "id", 0L, TRUE),
     paste0(
       "Perfect collinearity found between response and predictor variable:\n",
       "i Response variable `y` is perfectly collinear ",
       "with predictor variable `\\(Intercept\\)`\\."
     )
   )
   expect_warning(
-    full_model.matrix(f1, test_data2, TRUE),
+    full_model.matrix(f1, test_data2, "id", 0L, TRUE),
     paste0(
       "Perfect collinearity found between response and predictor variable:\n",
       "i Response variable `y` is perfectly collinear ",
@@ -50,14 +60,15 @@ test_that("perfect collinearity warns", {
 
 test_that("too few observations warns", {
   f <- obs(y ~ x + z + w, family = "gaussian")
-  test_data <- data.frame(
+  test_data <- data.table::data.table(
     y = rnorm(3),
     x = rnorm(3),
     z = rnorm(3),
-    w = rnorm(3)
+    w = rnorm(3),
+    id = 1L
   )
   expect_warning(
-    full_model.matrix(f, test_data, TRUE),
+    full_model.matrix(f, test_data, "id", 0L, TRUE),
     paste0(
       "Number of non-missing observations 3 in channel `y` ",
       "is less than 4, the number of predictors \\(including possible ",
@@ -68,13 +79,14 @@ test_that("too few observations warns", {
 
 test_that("zero predictor warns", {
   f <- obs(y ~ -1 + x + z, family = "gaussian")
-  test_data <- data.frame(
+  test_data <- data.table::data.table(
     y = rnorm(6),
     x = c(NA, rnorm(2), NA, rnorm(2)),
-    z = factor(1:3)
+    z = factor(1:3),
+    id = 1L
   )
   expect_warning(
-    full_model.matrix(f, test_data, TRUE),
+    full_model.matrix(f, test_data, "id", 0L, TRUE),
     paste0(
       "Predictor `z1` contains only zeros in the complete case rows of the ",
       "design matrix for the channel `y`\\."