Archetype fixes

R/brm_archetype_average_cells.R

@@ -194,7 +194,6 @@ archetype_average_cells <- function(data, prefix) {
   names_group <- rep(levels_group, each = n_time)
   names_time <- rep(levels_time, times = length(levels_group))
   names <- paste0(prefix, paste(names_group, names_time, sep = "_"))
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(
@@ -243,7 +242,6 @@ archetype_average_cells_subgroup <- function(data, prefix) {
     prefix,
     paste(names_group, names_subgroup, names_time, sep = "_")
   )
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(

R/brm_archetype_average_effects.R

@@ -203,7 +203,6 @@ archetype_average_effects <- function(data, prefix) {
   names_group <- rep(levels_group, each = n_time)
   names_time <- rep(levels_time, times = length(levels_group))
   names <- paste0(prefix, paste(names_group, names_time, sep = "_"))
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(
@@ -258,7 +257,6 @@ archetype_average_effects_subgroup <- function(data, prefix) {
     prefix,
     paste(names_group, names_subgroup, names_time, sep = "_")
   )
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(

R/brm_archetype_cells.R

@@ -158,7 +158,6 @@ archetype_cells <- function(data, prefix) {
   names_group <- rep(levels_group, each = length(levels_time))
   names_time <- rep(levels_time, times = length(levels_group))
   names <- paste0(prefix, paste(names_group, names_time, sep = "_"))
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(
@@ -197,7 +196,6 @@ archetype_cells_subgroup <- function(data, prefix) {
     prefix,
     paste(names_group, names_subgroup, names_time, sep = "_")
   )
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(

R/brm_archetype_effects.R

@@ -188,7 +188,6 @@ archetype_effects <- function(data, prefix) {
   names_group <- rep(levels_group, each = length(levels_time))
   names_time <- rep(levels_time, times = length(levels_group))
   names <- paste0(prefix, paste(names_group, names_time, sep = "_"))
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(
@@ -233,7 +232,6 @@ archetype_effects_subgroup <- function(data, prefix) {
     prefix,
     paste(names_group, names_subgroup, names_time, sep = "_")
   )
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(

R/brm_archetype_successive_cells.R

@@ -192,7 +192,7 @@ archetype_successive_cells <- function(data, prefix) {
   levels_group <- brm_levels(data[[group]])
   levels_time <- brm_levels(data[[time]])
   n_time <- length(levels_time)
-  data_first <- data[data[[time]] == data[[time]][1L], ]
+  data_first <- data[data[[time]] == levels_time[1L], ]
   matrix_group <- NULL
   for (name in levels_group) {
     matrix_group <- cbind(
@@ -205,7 +205,6 @@ archetype_successive_cells <- function(data, prefix) {
   names_group <- rep(levels_group, each = n_time)
   names_time <- rep(levels_time, times = length(levels_group))
   names <- paste0(prefix, paste(names_group, names_time, sep = "_"))
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(
@@ -244,7 +243,6 @@ archetype_successive_cells_subgroup <- function(data, prefix) {
     prefix,
     paste(names_group, names_subgroup, names_time, sep = "_")
   )
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(

R/brm_archetype_successive_effects.R

@@ -198,7 +198,6 @@ archetype_successive_effects <- function(data, prefix) {
   names_group <- rep(levels_group, each = n_time)
   names_time <- rep(levels_time, times = length(levels_group))
   names <- paste0(prefix, paste(names_group, names_time, sep = "_"))
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(
@@ -242,7 +241,6 @@ archetype_successive_effects_subgroup <- function(data, prefix) {
     prefix,
     paste(names_group, names_subgroup, names_time, sep = "_")
   )
-  names <- brm_levels(names)
   colnames(matrix) <- names
   interest <- tibble::as_tibble(as.data.frame(matrix))
   mapping <- tibble::tibble(

R/brm_data.R

@@ -340,9 +340,13 @@ brm_data_validate.default <- function(data) {
   for (column in c(group, subgroup, time)) {
     assert(
       is.atomic(data[[column]]) || is.factor(data[[column]]),
+      !is.factor(data[[column]]) || !anyNA(levels(data[[column]])),
       message = paste(
         column,
-        "column in the data must be an atomic or factor type."
+        paste(
+          "column in the data must be an atomic or factor type,",
+          "and all factor levels must be non-missing."
+        )
       )
     )
   }
@@ -393,6 +397,7 @@ brm_data_fill.brms_mmrm_data <- function(data) {
   missing <- attr(data, "brm_missing")
   interest <- attr(data, "brm_archetype_interest")
   nuisance <- attr(data, "brm_archetype_nuisance")
+  data <- droplevels(data)
   args <- list(data = data, as.symbol(patient), as.symbol(time))
   data <- do.call(what = tidyr::complete, args = args)
   args <- list(.data = data, as.symbol(patient), as.symbol(time))
@@ -452,7 +457,7 @@ brm_time_contrasts <- function(data) {
 }
 
 brm_levels <- function(x) {
-  if_any(is.factor(x), levels(x), sort(unique(x)))
+  if_any(is.factor(x), intersect(levels(x), unique(x)), sort(unique(x)))
 }
 
 brm_data_fill_column <- function(x, index) {

tests/testthat/test-brm_data.R

@@ -339,6 +339,10 @@ test_that("brm_levels()", {
   expect_equal(brm_levels(c(3L, 2L, 1L, 2L, 3L)), c(1L, 2L, 3L))
   x <- ordered(rep(c("a", "c", "b"), times = 2), levels = c("c", "b", "a"))
   expect_equal(brm_levels(x), c("c", "b", "a"))
+  expect_equal(
+    brm_levels(ordered(c("x", "y"), levels = c("z", "y", "x"))),
+    c("y", "x")
+  )
 })
 
 test_that("brm_data() deprecate level_control", {