posterior_epred_ordinal() in case of grouped thresholds: Fill missing…

… categories with NA, not zero.
paul-buerkner · Apr 30, 2021 · b690b75 · b690b75
1 parent d689fd7
commit b690b75
Show file tree

Hide file tree

Showing 2 changed files with 18 additions and 15 deletions.
diff --git a/R/posterior_epred.R b/R/posterior_epred.R
@@ -597,7 +597,7 @@ posterior_epred_ordinal <- function(prep) {
   adjust <- ifelse(prep$family$link == "identity", 0, 1)
   ncat_max <- max(prep$data$nthres) + adjust
   nact_min <- min(prep$data$nthres) + adjust
-  zero_mat <- matrix(0, nrow = prep$nsamples, ncol = ncat_max - nact_min)
+  na_mat <- matrix(NA, nrow = prep$nsamples, ncol = ncat_max - nact_min)
   args <- list(link = prep$family$link)
   out <- vector("list", prep$nobs)
   for (i in seq_along(out)) {
@@ -610,7 +610,7 @@ posterior_epred_ordinal <- function(prep) {
     out[[i]] <- do_call(dens, args_i)
     if (ncat_i < ncat_max) {
       sel <- seq_len(ncat_max - ncat_i)
-      out[[i]] <- cbind(out[[i]], zero_mat[, sel])
+      out[[i]] <- cbind(out[[i]], na_mat[, sel])
     }
   }
   out <- abind(out, along = 3)

diff --git a/tests/local/tests.models_new.R b/tests/local/tests.models_new.R
@@ -960,19 +960,14 @@ test_that("ordinal model with grouped thresholds works correctly", {
   ce <- conditional_effects(fit, categorical = TRUE)
   expect_ggplot(plot(ce, ask = FALSE)[[1]])
   thres_minus_eta <- posterior_linpred(fit, incl_thres = TRUE)
-  # TODO: The unmatching group/threshold combinations seem to have been assigned
-  # a value of zero which is probably misleading (NA or a completely different
-  # structure (e.g. a list, see the check below) might be better; if both is not
-  # an option, perhaps disallow grouped thresholds for `incl_thres = TRUE`):
-  stopifnot(!any(thres_minus_eta == 0))
-  ### Assigning NA might be an option:
-  thres_minus_eta[which(thres_minus_eta == 0, arr.ind = TRUE)] <- NA
-  ###
   bprep <- prepare_predictions(fit)
   thres <- bprep$thres$thres
   eta <- posterior_linpred(fit)
   gr_unq <- unique(family(fit)$thres$group)
   gr_vec <- fit$data$gr
+  nthres_max <- max(
+    by(family(fit)$thres, family(fit)$thres$group, function(x) max(x$thres))
+  )
   thres_minus_eta_ch <- lapply(setNames(nm = gr_unq), function(gr) {
     thres_gr_nms <- grepl(paste0("^b_Intercept\\[", gr, ","), colnames(thres))
     thres_gr <- thres[, thres_gr_nms]
@@ -982,17 +977,25 @@ test_that("ordinal model with grouped thresholds works correctly", {
       thres_minus_eta_ch_gr,
       dim = c(nrow(thres_gr), ncol(eta_gr), ncol(thres_gr))
     )
+    if (ncol(thres_gr) < nthres_max) {
+      dim_NA <- c(
+        dim(thres_minus_eta_ch_gr)[-3],
+        nthres_max - dim(thres_minus_eta_ch_gr)[3]
+      )
+      thres_minus_eta_ch_gr <- abind::abind(thres_minus_eta_ch_gr,
+                                            array(dim = dim_NA))
+    }
     dimnames(thres_minus_eta_ch_gr) <- list(
       NULL,
       NULL,
-      as.character(seq_len(ncol(thres_gr)))
+      as.character(seq_len(nthres_max))
     )
     return(thres_minus_eta_ch_gr)
   })
-  ### TODO: Decide for an output format and then make the following
-  ### expect_identical() call work:
-  # expect_identical(thres_minus_eta, thres_minus_eta_ch)
-  ### 
+  new_arrnms <- dimnames(thres_minus_eta_ch[[1]])
+  thres_minus_eta_ch <- abind::abind(thres_minus_eta_ch, along = 2)
+  dimnames(thres_minus_eta_ch) <- new_arrnms
+  expect_identical(thres_minus_eta, thres_minus_eta_ch)
 })
 
 test_that("Fixing parameters to constants works correctly", {