tests/testthat/test_proj_pred.R

In paasim/glmproj: Projection Predictive Feature Selection

# proj_linpred() ----------------------------------------------------------

context("proj_linpred()")

## object -----------------------------------------------------------------

test_that("pl: `object` of class `projection` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    if (!has_const_wdr_prj(prjs[[tstsetup]])) {
      wdr_crr <- prjs[[tstsetup]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    pl_tester(pls[[tstsetup]],
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    if (run_snaps) {
      if (testthat_ed_max2) local_edition(3)
      width_orig <- options(width = 145)
      expect_snapshot({
        print(tstsetup)
        print(rlang::hash(pls[[tstsetup]]))
      })
      options(width_orig)
      if (testthat_ed_max2) local_edition(2)
    }
  }
})

test_that(paste(
  "pl: `object` of (informal) class `proj_list` (based on varsel()) works"
), {
  skip_if_not(run_vs)
  for (tstsetup in names(prjs_vs)) {
    tstsetup_vs <- args_prj_vs[[tstsetup]]$tstsetup_vsel
    nterms_crr <- args_prj_vs[[tstsetup]]$nterms
    if (is.null(nterms_crr)) {
      nterms_crr <- suggest_size(vss[[tstsetup_vs]], warnings = FALSE)
    }
    if (args_prj_vs[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj_vs[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    ndr_ncl <- ndr_ncl_dtls(args_prj_vs[[tstsetup]])
    if (!has_const_wdr_prj(prjs_vs[[tstsetup]])) {
      if (length(nterms_crr) > 1) {
        wdr_crr <- drop(unique(do.call(rbind, lapply(prjs_vs[[tstsetup]], "[[",
                                                     "wdraws_prj"))))
      } else {
        wdr_crr <- prjs_vs[[tstsetup]][["wdraws_prj"]]
      }
    } else {
      wdr_crr <- NULL
    }
    pl_tester(pls_vs[[tstsetup]],
              len_expected = length(nterms_crr),
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = replicate(length(nterms_crr),
                                               ncats_nlats_expected_crr,
                                               simplify = FALSE),
              info_str = tstsetup)
    if (run_snaps) {
      if (testthat_ed_max2) local_edition(3)
      width_orig <- options(width = 145)
      expect_snapshot({
        print(tstsetup)
        print(rlang::hash(pls_vs[[tstsetup]]))
      })
      options(width_orig)
      if (testthat_ed_max2) local_edition(2)
    }
  }
})

test_that(paste(
  "pl: `object` of (informal) class `proj_list` (based on cv_varsel()) works"
), {
  skip_if_not(run_cvvs)
  for (tstsetup in names(prjs_cvvs)) {
    tstsetup_cvvs <- args_prj_cvvs[[tstsetup]]$tstsetup_vsel
    nterms_crr <- args_prj_cvvs[[tstsetup]]$nterms
    if (is.null(nterms_crr)) {
      nterms_crr <- suggest_size(cvvss[[tstsetup_cvvs]], warnings = FALSE)
    }
    if (args_prj_cvvs[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj_cvvs[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    ndr_ncl <- ndr_ncl_dtls(args_prj_cvvs[[tstsetup]])
    if (!has_const_wdr_prj(prjs_cvvs[[tstsetup]])) {
      if (length(nterms_crr) > 1) {
        wdr_crr <- drop(unique(do.call(rbind, lapply(prjs_cvvs[[tstsetup]],
                                                     "[[", "wdraws_prj"))))
      } else {
        wdr_crr <- prjs_cvvs[[tstsetup]][["wdraws_prj"]]
      }
    } else {
      wdr_crr <- NULL
    }
    pl_tester(pls_cvvs[[tstsetup]],
              len_expected = length(nterms_crr),
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = replicate(length(nterms_crr),
                                               ncats_nlats_expected_crr,
                                               simplify = FALSE),
              info_str = tstsetup)
    if (run_snaps) {
      if (testthat_ed_max2) local_edition(3)
      width_orig <- options(width = 145)
      expect_snapshot({
        print(tstsetup)
        print(rlang::hash(pls_cvvs[[tstsetup]]))
      })
      options(width_orig)
      if (testthat_ed_max2) local_edition(2)
    }
  }
})

test_that(paste(
  "`object` of (informal) class `proj_list` (created manually) works"
), {
  skip_if_not(run_prj)
  tstsetups <- grep(
    "rstanarm\\.glm\\.gauss\\.stdformul\\..*\\.trad\\..*\\.clust$",
    names(prjs), value = TRUE
  )
  stopifnot(length(tstsetups) > 1)
  pl <- proj_linpred(prjs[tstsetups], allow_nonconst_wdraws_prj = TRUE,
                     .seed = seed2_tst)
  wdr_crr <- unique(do.call(rbind, lapply(prjs[tstsetups], "[[", "wdraws_prj")))
  stopifnot(nrow(wdr_crr) == 1)
  wdr_crr <- drop(wdr_crr)
  pl_tester(pl,
            len_expected = length(tstsetups),
            wdraws_prj_expected = wdr_crr,
            ncats_nlats_expected = lapply(tstsetups, function(tstsetup) {
              if (args_prj[[tstsetup]]$prj_nm == "augdat" &&
                  args_prj[[tstsetup]]$fam_nm == "brnll") {
                return(1L)
              } else {
                return(integer())
              }
            }),
            info_str = paste(tstsetups, collapse = ","))
})

test_that(paste(
  "`object` of class `refmodel` and passing arguments to project() works"
), {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.brnll\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  for (tstsetup in tstsetups) {
    args_prj_i <- args_prj[[tstsetup]]
    pl_from_refmod <- do.call(proj_linpred, c(
      list(object = refmods[[args_prj_i$tstsetup_ref]],
           allow_nonconst_wdraws_prj = TRUE, .seed = seed2_tst),
      excl_nonargs(args_prj_i)
    ))
    pl_from_prj <- pls[[tstsetup]]
    expect_equal(pl_from_refmod, pl_from_prj, info = tstsetup)
  }
})

test_that(paste(
  "`object` of class `stanreg` or `brmsfit` and passing arguments to",
  "project() works"
), {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.brnll\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  for (tstsetup in tstsetups) {
    args_prj_i <- args_prj[[tstsetup]]
    pl_from_fit <- do.call(proj_linpred, c(
      list(object = fits[[args_prj_i$tstsetup_fit]],
           allow_nonconst_wdraws_prj = TRUE, .seed = seed2_tst),
      excl_nonargs(args_prj_i),
      excl_nonargs(args_ref[[args_prj_i$tstsetup_ref]])
    ))
    pl_from_prj <- pls[[tstsetup]]
    expect_equal(pl_from_fit, pl_from_prj, info = tstsetup)
  }
})

test_that(paste(
  "`object` of class `vsel` (created by varsel()) and passing arguments",
  "to project() works"
), {
  skip_if_not(run_vs)
  tstsetups <- grep("\\.brnll\\..*\\.subvec", names(prjs_vs), value = TRUE)
  if (any(grepl("\\.L1\\.", tstsetups))) {
    tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
  }
  stopifnot(length(tstsetups) > 0)
  for (tstsetup in tstsetups) {
    args_prj_vs_i <- args_prj_vs[[tstsetup]]
    pl_from_vsel <- do.call(proj_linpred, c(
      list(object = vss[[args_prj_vs_i$tstsetup_vsel]],
           allow_nonconst_wdraws_prj = TRUE, .seed = seed2_tst),
      excl_nonargs(args_prj_vs_i)
    ))
    pl_from_prj <- pls_vs[[tstsetup]]
    expect_equal(pl_from_vsel, pl_from_prj, info = tstsetup)
  }
})

test_that(paste(
  "`object` of class `vsel` (created by cv_varsel()) and passing arguments",
  "to project() works"
), {
  skip_if_not(run_cvvs)
  tstsetups <- grep("\\.brnll\\..*\\.default_cvmeth\\..*\\.subvec",
                    names(prjs_cvvs), value = TRUE)
  if (any(grepl("\\.L1\\.", tstsetups))) {
    tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
  }
  if (length(tstsetups) == 0) {
    tstsetups <- grep("\\.glm\\.gauss.*\\.default_cvmeth\\..*\\.subvec",
                      names(prjs_cvvs), value = TRUE)
    if (any(grepl("\\.L1\\.", tstsetups))) {
      tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
    }
    tstsetups <- head(tstsetups, 1)
  }
  stopifnot(length(tstsetups) > 0)
  for (tstsetup in tstsetups) {
    args_prj_cvvs_i <- args_prj_cvvs[[tstsetup]]
    pl_from_vsel <- do.call(proj_linpred, c(
      list(object = cvvss[[args_prj_cvvs_i$tstsetup_vsel]],
           allow_nonconst_wdraws_prj = TRUE, .seed = seed2_tst),
      excl_nonargs(args_prj_cvvs_i)
    ))
    pl_from_prj <- pls_cvvs[[tstsetup]]
    expect_equal(pl_from_vsel, pl_from_prj, info = tstsetup)
  }
})

test_that("`object` not of class `vsel` and missing `predictor_terms` fails", {
  expect_error(
    proj_linpred(1, .seed = seed2_tst),
    paste("^Please provide an `object` of class `vsel` or use argument",
          "`predictor_terms`\\.$")
  )
  if (length(fits)) {
    expect_error(
      proj_linpred(fits[[1]], .seed = seed2_tst),
      paste("^Please provide an `object` of class `vsel` or use argument",
            "`predictor_terms`\\.$")
    )
    expect_error(
      proj_linpred(refmods[[1]], .seed = seed2_tst),
      paste("^Please provide an `object` of class `vsel` or use argument",
            "`predictor_terms`\\.$")
    )
  }
  if (run_prj) {
    expect_error(
      proj_linpred(c(prjs, list(dat)), .seed = seed2_tst),
      paste("Please provide an `object` of class `vsel` or use argument",
            "`predictor_terms`\\.")
    )
  }
})

## newdata and integrated -------------------------------------------------

test_that("invalid `newdata` fails", {
  skip_if_not(run_prj)
  expect_error(
    proj_linpred(prjs, newdata = dat[, 1], .seed = seed2_tst),
    "must be a data\\.frame or a matrix"
  )
  stopifnot(length(prd_trms_x) > 1)
  prj_crr <- prjs[[head(grep("\\.glm\\.gauss.*\\.prd_trms_x", names(prjs)), 1)]]
  expect_error(
    proj_linpred(prj_crr,
                 newdata = dat[, head(prd_trms_x, -1), drop = FALSE],
                 weightsnew = prj_crr$refmodel$wobs,
                 offsetnew = prj_crr$refmodel$offset,
                 .seed = seed2_tst),
    "^object '.*' not found$"
  )
})

test_that("`newdata` and `integrated` work (even in edge cases)", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    if (!has_const_wdr_prj(prjs[[tstsetup]])) {
      wdr_crr <- prjs[[tstsetup]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    dat_crr <- get_dat(tstsetup)
    for (nobsv_crr in nobsv_tst) {
      if (args_prj[[tstsetup]]$mod_nm == "gamm") {
        # TODO (GAMMs): Fix this.
        next
      }
      if (args_prj[[tstsetup]]$prj_nm == "augdat") {
        ncats_nlats_expected_crr <- length(
          refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
        ) - 1L
      } else {
        ncats_nlats_expected_crr <- integer()
      }
      if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
        wobs_crr <- head(prjs[[tstsetup]]$refmodel$wobs, nobsv_crr)
      } else {
        wobs_crr <- NULL
      }
      if (grepl("\\.with_offs", tstsetup)) {
        offs_crr <- head(prjs[[tstsetup]]$refmodel$offset, nobsv_crr)
      } else {
        offs_crr <- NULL
      }
      expect_warning(
        pl_false <- proj_linpred(
          prjs[[tstsetup]],
          newdata = head(dat_crr, nobsv_crr),
          weightsnew = wobs_crr,
          offsetnew = offs_crr,
          allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
          .seed = seed2_tst
        ),
        get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                           offsetnew = offs_crr),
        info = tstsetup
      )
      pl_tester(pl_false,
                nprjdraws_expected = ndr_ncl$nprjdraws,
                wdraws_prj_expected = wdr_crr,
                nobsv_expected = nobsv_crr,
                ncats_nlats_expected = list(ncats_nlats_expected_crr),
                info_str = paste(tstsetup, nobsv_crr, sep = "__"))
      expect_warning(
        pl_true <- proj_linpred(prjs[[tstsetup]],
                                newdata = head(dat_crr, nobsv_crr),
                                weightsnew = wobs_crr,
                                offsetnew = offs_crr,
                                integrated = TRUE,
                                .seed = seed2_tst),
        get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                           offsetnew = offs_crr),
        info = tstsetup
      )
      pl_tester(pl_true,
                nprjdraws_expected = 1L,
                nobsv_expected = nobsv_crr,
                ncats_nlats_expected = list(ncats_nlats_expected_crr),
                info_str = paste(tstsetup, nobsv_crr, "integrated", sep = "__"))
      pred_false <- pl_false$pred
      if (args_prj[[tstsetup]]$prj_nm == "augdat") {
        pred_false <- t(arr2augmat(pred_false, margin_draws = 1))
      }
      pred_true <- pl_true$pred
      if (args_prj[[tstsetup]]$prj_nm == "augdat") {
        pred_true <- t(arr2augmat(pred_true, margin_draws = 1))
      }
      expect_equal(prjs[[!!tstsetup]]$wdraws_prj %*% pred_false, pred_true,
                   info = nobsv_crr)
    }
  }
})

test_that("`newdata` set to the original dataset doesn't change results", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    dat_crr <- get_dat(tstsetup)
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- wobs_tst
    } else {
      wobs_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- offs_tst
    } else {
      offs_crr <- NULL
    }
    # With `transform = FALSE`:
    expect_warning(
      pl_newdata <- proj_linpred(
        prjs[[tstsetup]], newdata = dat_crr, weightsnew = wobs_crr,
        offsetnew = offs_crr,
        allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1, .seed = seed2_tst
      ),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = offs_crr),
      info = tstsetup
    )
    pl_orig <- pls[[tstsetup]]
    expect_equal(pl_newdata, pl_orig, info = tstsetup)
    # With `transform = TRUE`:
    expect_warning(
      pl_newdata_t <- proj_linpred(
        prjs[[tstsetup]], newdata = dat_crr, weightsnew = wobs_crr,
        offsetnew = offs_crr,
        allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1, transform = TRUE,
        .seed = seed2_tst
      ),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = offs_crr),
      info = tstsetup
    )
    pl_orig_t <- proj_linpred(
      prjs[[tstsetup]], transform = TRUE,
      allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1, .seed = seed2_tst
    )
    expect_equal(pl_newdata_t, pl_orig_t, info = tstsetup)
  }
})

test_that(paste(
  "omitting the response in `newdata` (not possible for ``brmsfit``-based",
  "reference models) causes output element `lpd` to be `NULL` but doesn't",
  "change results otherwise"
), {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    if (args_prj[[tstsetup]]$pkg_nm == "brms") {
      next
    }
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    if (!has_const_wdr_prj(prjs[[tstsetup]])) {
      wdr_crr <- prjs[[tstsetup]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    resp_nm <- extract_terms_response(
      prjs[[tstsetup]]$refmodel$formula
    )$response
    if (prjs[[tstsetup]]$refmodel$family$for_latent) {
      resp_nm <- sub("^\\.", "", resp_nm)
    }
    stopifnot(!exists(resp_nm))
    dat_crr <- get_dat(tstsetup)
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- wobs_tst
    } else {
      wobs_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- offs_tst
    } else {
      offs_crr <- NULL
    }
    pl_noresp <- proj_linpred(
      prjs[[tstsetup]],
      newdata = dat_crr[, setdiff(names(dat_crr), resp_nm)],
      weightsnew = wobs_crr,
      offsetnew = offs_crr,
      allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
      .seed = seed2_tst
    )
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    pl_tester(pl_noresp,
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              lpd_null_expected = TRUE,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    pl_orig <- pls[[tstsetup]]
    expect_equal(pl_noresp$pred, pl_orig$pred, info = tstsetup)
  }
})

## weightsnew -------------------------------------------------------------

test_that("`weightsnew` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    if (!has_const_wdr_prj(prjs[[tstsetup]])) {
      wdr_crr <- prjs[[tstsetup]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- offs_tst
    } else {
      offs_crr <- NULL
    }
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    pl_orig <- pls[[tstsetup]]
    expect_warning(
      pl_ones <- proj_linpred(
        prjs[[tstsetup]],
        newdata = get_dat(tstsetup, dat_wobs_ones,
                          wobs_brms = 1),
        weightsnew = ~ wobs_col_ones,
        offsetnew = offs_crr,
        allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
        .seed = seed2_tst
      ),
      get_warn_wrhs_orhs(tstsetup, weightsnew = ~ wobs_col_ones,
                         offsetnew = offs_crr),
      info = tstsetup
    )
    pl_tester(pl_ones,
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
      expect_warning(
        pl <- proj_linpred(prjs[[tstsetup]],
                           newdata = get_dat(tstsetup, dat,
                                             wobs_brms = dat$wobs_col),
                           weightsnew = ~ wobs_col,
                           offsetnew = offs_crr,
                           allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                           .seed = seed2_tst),
        get_warn_wrhs_orhs(tstsetup, weightsnew = ~ wobs_col,
                           offsetnew = offs_crr),
        info = tstsetup
      )
      pl_tester(pl,
                nprjdraws_expected = ndr_ncl$nprjdraws,
                wdraws_prj_expected = wdr_crr,
                ncats_nlats_expected = list(ncats_nlats_expected_crr),
                info_str = tstsetup)
      expect_warning(
        plw <- proj_linpred(prjs[[tstsetup]],
                            newdata = get_dat(
                              tstsetup,
                              dat_wobs_new,
                              wobs_brms = dat_wobs_new$wobs_col_new
                            ),
                            weightsnew = ~ wobs_col_new,
                            offsetnew = offs_crr,
                            allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                            .seed = seed2_tst),
        get_warn_wrhs_orhs(tstsetup, weightsnew = ~ wobs_col_new,
                           offsetnew = offs_crr),
        info = tstsetup
      )
      pl_tester(plw,
                nprjdraws_expected = ndr_ncl$nprjdraws,
                wdraws_prj_expected = wdr_crr,
                ncats_nlats_expected = list(ncats_nlats_expected_crr),
                info_str = tstsetup)
    }
    expect_equal(pl_ones$pred, pl_orig$pred, info = tstsetup)
    if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
      expect_equal(pl$pred, pl_orig$pred, info = tstsetup)
      expect_equal(plw$pred, pl_orig$pred, info = tstsetup)
    }
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      expect_false(isTRUE(all.equal(pl_ones$lpd, pl_orig$lpd)), info = tstsetup)
      if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
        expect_equal(pl$lpd, pl_orig$lpd, info = tstsetup)
        expect_false(isTRUE(all.equal(plw$lpd, pl_ones$lpd)), info = tstsetup)
        expect_false(isTRUE(all.equal(plw$lpd, pl$lpd)), info = tstsetup)
      }
    } else {
      expect_equal(pl_ones$lpd, pl_orig$lpd, info = tstsetup)
      if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
        if (args_prj[[tstsetup]]$pkg_nm == "rstanarm") {
          expect_false(isTRUE(all.equal(pl$lpd, pl_orig$lpd)), info = tstsetup)
          expect_false(isTRUE(all.equal(plw$lpd, pl_orig$lpd)), info = tstsetup)
          expect_false(isTRUE(all.equal(plw$lpd, pl$lpd)), info = tstsetup)
        } else if (args_prj[[tstsetup]]$pkg_nm == "brms") {
          expect_equal(pl$lpd, pl_orig$lpd, info = tstsetup)
          expect_equal(plw$lpd, pl_orig$lpd, info = tstsetup)
        }
      }
    }
  }
})

## offsetnew --------------------------------------------------------------

test_that("`offsetnew` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    if (!has_const_wdr_prj(prjs[[tstsetup]])) {
      wdr_crr <- prjs[[tstsetup]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- wobs_tst
    } else {
      wobs_crr <- NULL
    }
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    pl_orig <- pls[[tstsetup]]
    add_offs_crr <- args_prj[[tstsetup]]$prj_nm == "latent" &&
      args_prj[[tstsetup]]$pkg_nm == "rstanarm" &&
      grepl("\\.with_offs\\.", tstsetup)
    expect_warning(
      pl_zeros <- proj_linpred(
        prjs[[tstsetup]],
        newdata = get_dat(tstsetup, dat_offs_zeros,
                          offs_ylat = 0,
                          add_offs_dummy = add_offs_crr,
                          offs_brms = 0),
        weightsnew = wobs_crr,
        offsetnew = ~ offs_col_zeros,
        allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
        .seed = seed2_tst
      ),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = ~ offs_col_zeros),
      info = tstsetup
    )
    pl_tester(pl_zeros,
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    expect_warning(
      pl <- proj_linpred(prjs[[tstsetup]],
                         newdata = get_dat(tstsetup, dat),
                         weightsnew = wobs_crr,
                         offsetnew = ~ offs_col,
                         allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                         .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = ~ offs_col),
      info = tstsetup
    )
    pl_tester(pl,
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    expect_warning(
      plo <- proj_linpred(prjs[[tstsetup]],
                          newdata = get_dat(
                            tstsetup, dat_offs_new,
                            offs_ylat = dat_offs_new$offs_col_new,
                            add_offs_dummy = add_offs_crr,
                            offs_brms = dat_offs_new$offs_col_new
                          ),
                          weightsnew = wobs_crr,
                          offsetnew = ~ offs_col_new,
                          allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                          .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = ~ offs_col_new),
      info = tstsetup
    )
    pl_tester(plo,
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    pred_pl <- pl$pred
    pred_pl_orig <- pl_orig$pred
    pred_plo <- plo$pred
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      pred_pl <- t(arr2augmat(pred_pl, margin_draws = 1))
      pred_pl_orig <- t(arr2augmat(pred_pl_orig, margin_draws = 1))
      pred_plo <- t(arr2augmat(pred_plo, margin_draws = 1))
    }
    if (grepl("\\.with_offs", tstsetup)) {
      expect_equal(pl, pl_orig, info = tstsetup)
      expect_false(isTRUE(all.equal(pl_zeros, pl)), info = tstsetup)
      expect_false(isTRUE(all.equal(plo, pl)), info = tstsetup)
      if (args_prj[[tstsetup]]$prj_nm != "latent") {
        expect_false(isTRUE(all.equal(pl_zeros$pred, pl$pred)), info = tstsetup)
        expect_false(isTRUE(all.equal(plo$pred, pl$pred)), info = tstsetup)
        expect_false(isTRUE(all.equal(pl_zeros$lpd, pl$lpd)), info = tstsetup)
        expect_false(isTRUE(all.equal(plo$lpd, pl$lpd)), info = tstsetup)
      } else {
        # Latent projection is an exception because the reference model's
        # latent predictions (i.e., the artificial latent response `ynew`
        # recomputed inside of proj_linpred_aux()) are shifted by the same
        # offsets as the submodel's predictions (i.e., the mean values for the
        # latent Gaussian distributions), so the log predictive values are
        # unchanged:
        expect_false(isTRUE(all.equal(pl_zeros$pred, pl$pred)), info = tstsetup)
        expect_false(isTRUE(all.equal(plo$pred, pl$pred)), info = tstsetup)
        expect_equal(pl_zeros$lpd, pl$lpd, info = tstsetup)
        expect_equal(plo$lpd, pl$lpd, info = tstsetup)
      }
    } else {
      expect_equal(pl_zeros, pl_orig, info = tstsetup)
      if (args_prj[[tstsetup]]$pkg_nm == "rstanarm") {
        expect_false(isTRUE(all.equal(plo, pl)), info = tstsetup)
        if (args_prj[[tstsetup]]$fam_nm %in% c("brnll", "binom")) {
          # To avoid failing tests due to numerical inaccuracies for extreme
          # values:
          is_extreme <- which(abs(pred_pl_orig) > f_binom$linkfun(1 - 1e-12),
                              arr.ind = TRUE)
          pred_pl_orig[is_extreme] <- NA
          pred_pl[is_extreme] <- NA
          pred_plo[is_extreme] <- NA
        }
        pred_pl_no_offs <- t(pred_pl)
        if (args_prj[[tstsetup]]$prj_nm == "augdat" &&
            get_fam_long(args_prj[[tstsetup]]$fam_nm) %in% fams_neg_linpred()) {
          pred_pl_no_offs <- pred_pl_no_offs + dat$offs_col
        } else {
          pred_pl_no_offs <- pred_pl_no_offs - dat$offs_col
        }
        expect_equal(pred_pl_no_offs, t(pred_pl_orig), info = tstsetup)
        pred_plo_no_offs <- t(pred_plo)
        if (args_prj[[tstsetup]]$prj_nm == "augdat" &&
            get_fam_long(args_prj[[tstsetup]]$fam_nm) %in% fams_neg_linpred()) {
          pred_plo_no_offs <- pred_plo_no_offs + dat_offs_new$offs_col_new
        } else {
          pred_plo_no_offs <- pred_plo_no_offs - dat_offs_new$offs_col_new
        }
        expect_equal(pred_plo_no_offs, t(pred_pl_orig), info = tstsetup)
        expect_false(isTRUE(all.equal(pl$lpd, pl_orig$lpd)), info = tstsetup)
        expect_false(isTRUE(all.equal(plo$lpd, pl_orig$lpd)), info = tstsetup)
        expect_false(isTRUE(all.equal(plo$lpd, pl$lpd)), info = tstsetup)
      } else if (args_prj[[tstsetup]]$pkg_nm == "brms") {
        expect_equal(pl, pl_orig, info = tstsetup)
        expect_equal(plo, pl_orig, info = tstsetup)
      }
    }
  }
})

## transform --------------------------------------------------------------

test_that("`transform` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    if (!has_const_wdr_prj(prjs[[tstsetup]])) {
      wdr_crr <- prjs[[tstsetup]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    if (!is.null(refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats)) {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
      )
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    pl_false <- pls[[tstsetup]]
    pl_true <- proj_linpred(prjs[[tstsetup]], transform = TRUE,
                            allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                            .seed = seed2_tst)
    pl_tester(pl_true,
              nprjdraws_expected = ndr_ncl$nprjdraws,
              wdraws_prj_expected = wdr_crr,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
    pred_false <- pl_false$pred
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      pred_false <- arr2augmat(pred_false, margin_draws = 1)
    } else {
      pred_false <- t(pred_false)
    }
    pred_true <- pl_true$pred
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      pred_true <- arr2augmat(pred_true, margin_draws = 1)
    } else if (args_prj[[tstsetup]]$prj_nm != "latent") {
      pred_true <- t(pred_true)
    }
    if (args_prj[[tstsetup]]$prj_nm != "latent") {
      pred_false2true <- prjs[[tstsetup]]$refmodel$family$linkinv(pred_false)
    } else {
      if (exists(".Random.seed", envir = .GlobalEnv)) {
        rng_old <- get(".Random.seed", envir = .GlobalEnv)
      }
      set.seed(args_prj[[tstsetup]]$seed)
      clust_ref <- get_refdist(prjs[[tstsetup]]$refmodel,
                               ndraws = args_prj[[tstsetup]]$ndraws,
                               nclusters = args_prj[[tstsetup]]$nclusters)
      pred_false2true <- structure(
        prjs[[tstsetup]]$refmodel$family$latent_ilink(
          t(pred_false), cl_ref = clust_ref$cl
        ),
        wdraws_prj = wdr_crr
      )
    }
    expect_equal(pred_false2true, pred_true, info = tstsetup)
    if (exists("rng_old")) assign(".Random.seed", rng_old, envir = .GlobalEnv)
  }
})

## regul ------------------------------------------------------------------

test_that("`regul` works", {
  skip_if_not(run_prj)
  regul_tst <- c(1e-6, 1e-1, 1e2)
  stopifnot(identical(regul_tst, sort(regul_tst)))
  tstsetups <- grep("\\.glm\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  tstsetups <- grep(fam_nms_aug_regex, tstsetups, value = TRUE, invert = TRUE)
  for (tstsetup in tstsetups) {
    args_prj_i <- args_prj[[tstsetup]]
    if (args_prj_i$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj_i$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    norms <- sapply(regul_tst, function(regul_crr) {
      pl <- do.call(proj_linpred, c(
        list(object = refmods[[args_prj_i$tstsetup_ref]],
             integrated = TRUE,
             .seed = seed2_tst,
             regul = regul_crr),
        excl_nonargs(args_prj_i)
      ))
      pl_tester(pl,
                nprjdraws_expected = 1L,
                ncats_nlats_expected = list(ncats_nlats_expected_crr),
                info_str = tstsetup)
      return(sum(pl$pred^2))
    })
    for (j in head(seq_along(regul_tst), -1)) {
      expect_true(all(norms[!!j] >= norms[!!(j + 1)]), info = tstsetup)
    }
  }
})

## filter_nterms ----------------------------------------------------------

test_that("`filter_nterms` works (for an `object` of class `projection`)", {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.brnll\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  for (tstsetup in tstsetups) {
    nterms_avail_crr <- length(args_prj[[tstsetup]]$predictor_terms)
    nterms_unavail_crr <- c(0L, nterms_avail_crr + 130L)
    stopifnot(!nterms_avail_crr %in% nterms_unavail_crr)
    for (filter_nterms_crr in nterms_unavail_crr) {
      expect_error(proj_linpred(prjs[[tstsetup]],
                                filter_nterms = filter_nterms_crr,
                                allow_nonconst_wdraws_prj = TRUE,
                                .seed = seed2_tst),
                   "Invalid `filter_nterms`\\.",
                   info = paste(tstsetup, filter_nterms_crr, sep = "__"))
    }
    pl <- proj_linpred(prjs[[tstsetup]],
                       filter_nterms = nterms_avail_crr,
                       allow_nonconst_wdraws_prj = TRUE,
                       .seed = seed2_tst)
    pl_orig <- pls[[tstsetup]]
    expect_equal(pl, pl_orig, info = tstsetup)
  }
})

test_that(paste(
  "`filter_nterms` works (for an `object` of (informal) class `proj_list`)"
), {
  skip_if_not(run_vs)
  tstsetups <- grep("\\.glm\\..*\\.full$", names(prjs_vs), value = TRUE)
  if (any(grepl("\\.L1\\.", tstsetups))) {
    tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
  }
  for (tstsetup in tstsetups) {
    ndr_ncl <- ndr_ncl_dtls(args_prj_vs[[tstsetup]])
    if (!has_const_wdr_prj(prjs_vs[[tstsetup]])) {
      wdr_crr <- prjs_vs[[tstsetup]][[1]][["wdraws_prj"]]
    } else {
      wdr_crr <- NULL
    }
    if (args_prj_vs[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj_vs[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    # Unavailable number(s) of terms:
    for (filter_nterms_crr in nterms_unavail) {
      expect_error(
        proj_linpred(prjs_vs[[tstsetup]],
                     filter_nterms = filter_nterms_crr,
                     allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                     .seed = seed2_tst),
        "Invalid `filter_nterms`\\.",
        info = paste(tstsetup,
                     paste(filter_nterms_crr, collapse = ","),
                     sep = "__")
      )
    }
    # Available number(s) of terms:
    nterms_avail_filter <- c(
      nterms_avail,
      list(partvec = c(nterms_max_tst %/% 2L, nterms_max_tst + 130L))
    )
    for (filter_nterms_crr in nterms_avail_filter) {
      pl_crr <- proj_linpred(prjs_vs[[tstsetup]],
                             filter_nterms = filter_nterms_crr,
                             allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
                             .seed = seed2_tst)
      if (is.null(filter_nterms_crr)) filter_nterms_crr <- 0:nterms_max_tst
      nhits_nterms <- sum(filter_nterms_crr <= nterms_max_tst)
      pl_tester(pl_crr,
                len_expected = nhits_nterms,
                wdraws_prj_expected = wdr_crr,
                ncats_nlats_expected = replicate(nhits_nterms,
                                                 ncats_nlats_expected_crr,
                                                 simplify = FALSE),
                info_str = paste(tstsetup,
                                 paste(filter_nterms_crr, collapse = ","),
                                 sep = "__"))
      if (identical(filter_nterms_crr, 0:nterms_max_tst)) {
        # The special case of all possible numbers of terms:
        pl_orig <- pls_vs[[tstsetup]]
        expect_equal(pl_crr, pl_orig, info = tstsetup)
      }
    }
  }
})

## Single observation, single draw ----------------------------------------

test_that(paste(
  "a single observation and a single draw work (which implicitly tests",
  "this edge case for family$ll_fun(), too)"
), {
  skip_if_not(run_prj)
  for (tstsetup in grep("\\.clust$", names(prjs), value = TRUE)) {
    if (args_prj[[tstsetup]]$mod_nm == "gamm") {
      # TODO (GAMMs): Fix this.
      next
    }
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- head(wobs_tst, 1)
    } else {
      wobs_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- head(offs_tst, 1)
    } else {
      offs_crr <- NULL
    }
    if (args_prj[[tstsetup]]$prj_nm == "augdat") {
      ncats_nlats_expected_crr <- length(
        refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
      ) - 1L
    } else {
      ncats_nlats_expected_crr <- integer()
    }
    pl_args <- list(refmods[[args_prj[[tstsetup]]$tstsetup_ref]],
                    newdata = head(get_dat(tstsetup), 1),
                    weightsnew = wobs_crr,
                    offsetnew = offs_crr,
                    .seed = seed2_tst,
                    predictor_terms = args_prj[[tstsetup]]$predictor_terms,
                    nclusters = 1L,
                    seed = seed_tst)
    if (args_prj[[tstsetup]]$fam_nm == "categ" &&
        any(grepl("\\|", args_prj[[tstsetup]]$predictor_terms))) {
      pl_args <- c(pl_args, list(avoid.increase = TRUE))
    }
    # Use suppressWarnings() because test_that() somehow redirects stderr() and
    # so throws warnings that projpred wants to capture internally:
    pl1 <- suppressWarnings(do.call(proj_linpred, pl_args))
    pl_tester(pl1,
              nprjdraws_expected = 1L,
              nobsv_expected = 1L,
              ncats_nlats_expected = list(ncats_nlats_expected_crr),
              info_str = tstsetup)
  }
})

## Projected draws with different weights ---------------------------------

test_that("`allow_nonconst_wdraws_prj = FALSE` causes an error", {
  skip_if_not(run_prj)
  for (tstsetup in grep("\\.clust", names(prjs), value = TRUE)) {
    if (grepl("\\.clust1", tstsetup)) {
      err_expected <- NA
    } else {
      err_expected <- "different .* weights"
    }
    expect_error(proj_linpred(prjs[[tstsetup]], .seed = seed2_tst),
                 err_expected, info = tstsetup)
  }
})

test_that(paste(
  "`return_draws_matrix` causes a conversion of the output type,",
  "with different weights of the projected draws causing the application of",
  "posterior::weight_draws()"
), {
  skip_if_not(run_prj)
  skip_if_not_installed("posterior")
  for (tstsetup in names(prjs)) {
    ndr_ncl <- ndr_ncl_dtls(args_prj[[tstsetup]])
    for (transf_crr in c(FALSE, TRUE)) {
      for (intgr_crr in c(FALSE, TRUE)) {
        if (!transf_crr && !intgr_crr) {
          pl_orig <- pls[[tstsetup]]
        } else {
          pl_orig <- proj_linpred(
            prjs[[tstsetup]], transform = transf_crr, integrated = intgr_crr,
            allow_nonconst_wdraws_prj = ndr_ncl$clust_used_gt1,
            .seed = seed2_tst
          )
        }
        pl_dr <- proj_linpred(
          prjs[[tstsetup]], transform = transf_crr, integrated = intgr_crr,
          return_draws_matrix = TRUE, .seed = seed2_tst
        )
        if (args_prj[[tstsetup]]$prj_nm == "augdat" ||
            (args_prj[[tstsetup]]$prj_nm == "latent" && !is.null(
              refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
            ) && transf_crr)) {
          pl_orig_pred <- do.call(rbind, apply(pl_orig$pred, 1, as.vector,
                                               simplify = FALSE))
        } else {
          pl_orig_pred <- pl_orig$pred
        }
        pl_dr_repl <- list(
          pred = posterior::as_draws_matrix(pl_orig_pred),
          lpd = posterior::as_draws_matrix(pl_orig$lpd)
        )
        if (!has_const_wdr_prj(prjs[[tstsetup]]) && !intgr_crr) {
          pl_dr_repl$pred <- posterior::weight_draws(
            pl_dr_repl$pred, weights = prjs[[tstsetup]][["wdraws_prj"]]
          )
          pl_dr_repl$lpd <- posterior::weight_draws(
            pl_dr_repl$lpd, weights = prjs[[tstsetup]][["wdraws_prj"]]
          )
        }
        expect_equal(pl_dr, pl_dr_repl,
                     info = paste(tstsetup, transf_crr, intgr_crr, sep = "__"))
      }
    }
  }
})

# proj_predict() ----------------------------------------------------------

context("proj_predict()")

## seed -------------------------------------------------------------------

test_that("`.seed` works (and restores the RNG state afterwards)", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    pp_orig <- pps[[tstsetup]]
    rand_orig <- runif(1) # Just to advance `.Random.seed[2]`.
    .Random.seed_new1 <- .Random.seed
    pp_new <- proj_predict(prjs[[tstsetup]], .seed = seed2_tst + 1L)
    .Random.seed_new2 <- .Random.seed
    rand_new <- runif(1) # Just to advance `.Random.seed[2]`.
    .Random.seed_repr1 <- .Random.seed
    pp_repr <- proj_predict(prjs[[tstsetup]], .seed = seed2_tst)
    .Random.seed_repr2 <- .Random.seed
    rand_repr <- runif(1) # Just to advance `.Random.seed[2]`.
    .Random.seed_null1 <- .Random.seed

    expect_equal(pp_orig, pp_repr, info = tstsetup)
    if (!args_prj[[tstsetup]]$fam_nm %in% c("brnll")) {
      # The Bernoulli family is excluded because two possible response values
      # are too few to reliably check non-equality:
      expect_false(isTRUE(all.equal(pp_orig, pp_new)), info = tstsetup)
    }

    expect_equal(.Random.seed_new2, .Random.seed_new1, info = tstsetup)
    expect_equal(.Random.seed_repr2, .Random.seed_repr1, info = tstsetup)

    expect_false(isTRUE(all.equal(rand_new, rand_orig)), info = tstsetup)
    expect_false(isTRUE(all.equal(rand_repr, rand_orig)), info = tstsetup)
    expect_false(isTRUE(all.equal(rand_repr, rand_new)), info = tstsetup)
  }
})

## object -----------------------------------------------------------------

test_that("pp: `object` of class `projection` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    pp_tester(pps[[tstsetup]],
              nprjdraws_out_expected = ndr_pp_out(args_prj[[tstsetup]],
                                                  prj_out = prjs[[tstsetup]]),
              cats_expected =
                list(refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats),
              info_str = tstsetup)
    if (run_snaps) {
      if (testthat_ed_max2) local_edition(3)
      width_orig <- options(width = 145)
      expect_snapshot({
        print(tstsetup)
        print(rlang::hash(pps[[tstsetup]]))
      })
      options(width_orig)
      if (testthat_ed_max2) local_edition(2)
    }
  }
})

test_that(paste(
  "pp: `object` of (informal) class `proj_list` (based on varsel()) works"
), {
  skip_if_not(run_vs)
  for (tstsetup in names(prjs_vs)) {
    tstsetup_vs <- args_prj_vs[[tstsetup]]$tstsetup_vsel
    nterms_crr <- args_prj_vs[[tstsetup]]$nterms
    if (is.null(nterms_crr)) {
      nterms_crr <- suggest_size(vss[[tstsetup_vs]], warnings = FALSE)
    }
    pp_tester(pps_vs[[tstsetup]],
              len_expected = length(nterms_crr),
              nprjdraws_out_expected = ndr_pp_out(
                args_prj_vs[[tstsetup]], prj_out = prjs_vs[[tstsetup]]
              ),
              cats_expected = replicate(
                length(nterms_crr),
                refmods[[args_prj_vs[[tstsetup]]$tstsetup_ref]]$family$cats,
                simplify = FALSE
              ),
              info_str = tstsetup)
    if (run_snaps) {
      if (testthat_ed_max2) local_edition(3)
      width_orig <- options(width = 145)
      expect_snapshot({
        print(tstsetup)
        print(rlang::hash(pps_vs[[tstsetup]]))
      })
      options(width_orig)
      if (testthat_ed_max2) local_edition(2)
    }
  }
})

test_that(paste(
  "pp: `object` of (informal) class `proj_list` (based on cv_varsel()) works"
), {
  skip_if_not(run_cvvs)
  for (tstsetup in names(prjs_cvvs)) {
    tstsetup_cvvs <- args_prj_cvvs[[tstsetup]]$tstsetup_vsel
    nterms_crr <- args_prj_cvvs[[tstsetup]]$nterms
    if (is.null(nterms_crr)) {
      nterms_crr <- suggest_size(cvvss[[tstsetup_cvvs]], warnings = FALSE)
    }
    pp_tester(pps_cvvs[[tstsetup]],
              len_expected = length(nterms_crr),
              nprjdraws_out_expected = ndr_pp_out(
                args_prj_cvvs[[tstsetup]], prj_out = prjs_cvvs[[tstsetup]]
              ),
              cats_expected = replicate(
                length(nterms_crr),
                refmods[[args_prj_cvvs[[tstsetup]]$tstsetup_ref]]$family$cats,
                simplify = FALSE
              ),
              info_str = tstsetup)
    if (run_snaps) {
      if (testthat_ed_max2) local_edition(3)
      width_orig <- options(width = 145)
      expect_snapshot({
        print(tstsetup)
        print(rlang::hash(pps_cvvs[[tstsetup]]))
      })
      options(width_orig)
      if (testthat_ed_max2) local_edition(2)
    }
  }
})

test_that(paste(
  "`object` of (informal) class `proj_list` (created manually) works"
), {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.trad\\..*\\.clust$", names(prjs), value = TRUE)
  stopifnot(length(tstsetups) > 1)
  pp <- proj_predict(prjs[tstsetups], .seed = seed2_tst)
  pp_tester(pp,
            len_expected = length(tstsetups),
            cats_expected = lapply(
              refmods[sapply(args_prj[tstsetups], "[[", "tstsetup_ref")],
              function(refmod_crr) {
                refmod_crr$family$cats
              }
            ),
            info_str = paste(tstsetups, collapse = ","))
})

test_that(paste(
  "`object` of class `refmodel` and passing arguments to project() works"
), {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.brnll\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  for (tstsetup in tstsetups) {
    args_prj_i <- args_prj[[tstsetup]]
    pp_from_refmod <- do.call(proj_predict, c(
      list(object = refmods[[args_prj_i$tstsetup_ref]],
           .seed = seed2_tst),
      excl_nonargs(args_prj_i)
    ))
    pp_from_prj <- pps[[tstsetup]]
    expect_equal(pp_from_refmod, pp_from_prj, info = tstsetup)
  }
})

test_that(paste(
  "`object` of class `stanreg` or `brmsfit` and passing arguments to",
  "project() works"
), {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.brnll\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  for (tstsetup in tstsetups) {
    args_prj_i <- args_prj[[tstsetup]]
    pp_from_fit <- do.call(proj_predict, c(
      list(object = fits[[args_prj_i$tstsetup_fit]],
           .seed = seed2_tst),
      excl_nonargs(args_ref[[args_prj_i$tstsetup_ref]]),
      excl_nonargs(args_prj_i)
    ))
    pp_from_prj <- pps[[tstsetup]]
    expect_equal(pp_from_fit, pp_from_prj, info = tstsetup)
  }
})

test_that(paste(
  "`object` of class `vsel` (created by varsel()) and passing arguments",
  "to project() works"
), {
  skip_if_not(run_vs)
  tstsetups <- grep("\\.brnll\\..*\\.subvec", names(prjs_vs), value = TRUE)
  if (any(grepl("\\.L1\\.", tstsetups))) {
    tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
  }
  stopifnot(length(tstsetups) > 0)
  for (tstsetup in tstsetups) {
    args_prj_vs_i <- args_prj_vs[[tstsetup]]
    pp_from_vsel <- do.call(proj_predict, c(
      list(object = vss[[args_prj_vs_i$tstsetup_vsel]],
           .seed = seed2_tst),
      excl_nonargs(args_prj_vs_i)
    ))
    pp_from_prj <- pps_vs[[tstsetup]]
    expect_equal(pp_from_vsel, pp_from_prj, info = tstsetup)
  }
})

test_that(paste(
  "`object` of class `vsel` (created by cv_varsel()) and passing arguments",
  "to project() works"
), {
  skip_if_not(run_cvvs)
  tstsetups <- grep("\\.brnll\\..*\\.default_cvmeth\\..*\\.subvec",
                    names(prjs_cvvs), value = TRUE)
  if (any(grepl("\\.L1\\.", tstsetups))) {
    tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
  }
  if (length(tstsetups) == 0) {
    tstsetups <- grep("\\.glm\\.gauss.*\\.default_cvmeth\\..*\\.subvec",
                      names(prjs_cvvs), value = TRUE)
    if (any(grepl("\\.L1\\.", tstsetups))) {
      tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
    }
    tstsetups <- head(tstsetups, 1)
  }
  stopifnot(length(tstsetups) > 0)
  for (tstsetup in tstsetups) {
    args_prj_cvvs_i <- args_prj_cvvs[[tstsetup]]
    pp_from_vsel <- do.call(proj_predict, c(
      list(object = cvvss[[args_prj_cvvs_i$tstsetup_vsel]],
           .seed = seed2_tst),
      excl_nonargs(args_prj_cvvs_i)
    ))
    pp_from_prj <- pps_cvvs[[tstsetup]]
    expect_equal(pp_from_vsel, pp_from_prj, info = tstsetup)
  }
})

test_that("`object` not of class `vsel` and missing `predictor_terms` fails", {
  expect_error(
    proj_predict(1, .seed = seed2_tst),
    paste("^Please provide an `object` of class `vsel` or use argument",
          "`predictor_terms`\\.$")
  )
  if (length(fits)) {
    expect_error(
      proj_predict(fits[[1]], .seed = seed2_tst),
      paste("^Please provide an `object` of class `vsel` or use argument",
            "`predictor_terms`\\.$")
    )
    expect_error(
      proj_predict(refmods[[1]], .seed = seed2_tst),
      paste("^Please provide an `object` of class `vsel` or use argument",
            "`predictor_terms`\\.$")
    )
  }
  if (run_prj) {
    expect_error(
      proj_predict(c(prjs, list(dat)), .seed = seed2_tst),
      paste("Please provide an `object` of class `vsel` or use argument",
            "`predictor_terms`\\.")
    )
  }
})

## newdata and nresample_clusters -----------------------------------------

test_that("invalid `newdata` fails", {
  skip_if_not(run_prj)
  expect_error(
    proj_predict(prjs, newdata = dat[, 1], .seed = seed2_tst),
    "must be a data\\.frame or a matrix"
  )
  stopifnot(length(prd_trms_x) > 1)
  prj_crr <- prjs[[head(grep("\\.glm\\.gauss.*\\.prd_trms_x", names(prjs)), 1)]]
  expect_error(
    proj_predict(prjs[[head(grep("\\.glm\\.gauss.*\\.prd_trms_x", names(prjs)),
                            1)]],
                 newdata = dat[, head(prd_trms_x, -1), drop = FALSE],
                 weightsnew = prj_crr$refmodel$wobs,
                 offsetnew = prj_crr$refmodel$offset,
                 .seed = seed2_tst,
                 predictor_terms = prd_trms_x),
    "^object '.*' not found$"
  )
})

test_that("`newdata` and `nresample_clusters` work (even in edge cases)", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    for (nobsv_crr in nobsv_tst) {
      if (args_prj[[tstsetup]]$mod_nm == "gamm") {
        # TODO (GAMMs): Fix this.
        next
      }
      if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
        wobs_crr <- head(prjs[[tstsetup]]$refmodel$wobs, nobsv_crr)
      } else {
        wobs_crr <- NULL
      }
      if (grepl("\\.with_offs", tstsetup)) {
        offs_crr <- head(prjs[[tstsetup]]$refmodel$offset, nobsv_crr)
      } else {
        offs_crr <- NULL
      }
      for (nresample_clusters_crr in nresample_clusters_tst) {
        expect_warning(
          pp <- proj_predict(prjs[[tstsetup]],
                             newdata = head(dat, nobsv_crr),
                             weightsnew = wobs_crr,
                             offsetnew = offs_crr,
                             nresample_clusters = nresample_clusters_crr,
                             .seed = seed2_tst),
          get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                             offsetnew = offs_crr),
          info = tstsetup
        )
        pp_tester(pp,
                  nprjdraws_out_expected = ndr_pp_out(
                    args_prj[[tstsetup]], prj_out = prjs[[tstsetup]],
                    nresample_clusters_crr = nresample_clusters_crr
                  ),
                  nobsv_expected = nobsv_crr,
                  cats_expected = list(
                    refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
                  ),
                  info_str = paste(tstsetup, nobsv_crr, nresample_clusters_crr,
                                   sep = "__"))
      }
    }
  }
})

test_that("`newdata` set to the original dataset doesn't change results", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- wobs_tst
    } else {
      wobs_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- offs_tst
    } else {
      offs_crr <- NULL
    }
    expect_warning(
      pp_newdata <- proj_predict(prjs[[tstsetup]],
                                 newdata = dat,
                                 weightsnew = wobs_crr,
                                 offsetnew = offs_crr,
                                 .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = offs_crr),
      info = tstsetup
    )
    pp_orig <- pps[[tstsetup]]
    expect_equal(pp_newdata, pp_orig, info = tstsetup)
  }
})

test_that(paste(
  "omitting the response in `newdata` (not possible for ``brmsfit``-based",
  "reference models) doesn't change results"
), {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    if (args_prj[[tstsetup]]$pkg_nm == "brms") {
      next
    }
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- wobs_tst
    } else {
      wobs_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- offs_tst
    } else {
      offs_crr <- NULL
    }
    resp_nm <- extract_terms_response(
      prjs[[tstsetup]]$refmodel$formula
    )$response
    stopifnot(!exists(resp_nm))
    pp_noresp <- proj_predict(prjs[[tstsetup]],
                              newdata = dat[, setdiff(names(dat), resp_nm)],
                              weightsnew = wobs_crr,
                              offsetnew = offs_crr,
                              .seed = seed2_tst)
    pp_orig <- pps[[tstsetup]]
    expect_equal(pp_noresp, pp_orig, info = tstsetup)
  }
})

## weightsnew -------------------------------------------------------------

test_that("`weightsnew` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    nprjdraws_out_crr <- ndr_pp_out(args_prj[[tstsetup]],
                                    prj_out = prjs[[tstsetup]])
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- offs_tst
    } else {
      offs_crr <- NULL
    }
    pp_orig <- pps[[tstsetup]]
    expect_warning(
      pp_ones <- proj_predict(prjs[[tstsetup]],
                              newdata = get_dat(tstsetup, dat_wobs_ones,
                                                wobs_brms = 1),
                              weightsnew = ~ wobs_col_ones,
                              offsetnew = offs_crr,
                              .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = ~ wobs_col_ones,
                         offsetnew = offs_crr),
      info = tstsetup
    )
    pp_tester(pp_ones,
              nprjdraws_out_expected = nprjdraws_out_crr,
              cats_expected = list(
                refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
              ),
              info_str = tstsetup)
    if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
      expect_warning(
        pp <- proj_predict(prjs[[tstsetup]],
                           newdata = get_dat(tstsetup, dat,
                                             wobs_brms = dat$wobs_col),
                           weightsnew = ~ wobs_col,
                           offsetnew = offs_crr,
                           .seed = seed2_tst),
        get_warn_wrhs_orhs(tstsetup, weightsnew = ~ wobs_col,
                           offsetnew = offs_crr),
        info = tstsetup
      )
      pp_tester(pp,
                nprjdraws_out_expected = nprjdraws_out_crr,
                cats_expected = list(
                  refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
                ),
                info_str = tstsetup)
      expect_warning(
        ppw <- proj_predict(prjs[[tstsetup]],
                            newdata = get_dat(
                              tstsetup,
                              dat_wobs_new,
                              wobs_brms = dat_wobs_new$wobs_col_new
                            ),
                            weightsnew = ~ wobs_col_new,
                            offsetnew = offs_crr,
                            .seed = seed2_tst),
        get_warn_wrhs_orhs(tstsetup, weightsnew = ~ wobs_col_new,
                           offsetnew = offs_crr),
        info = tstsetup
      )
      pp_tester(ppw,
                nprjdraws_out_expected = nprjdraws_out_crr,
                cats_expected = list(
                  refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
                ),
                info_str = tstsetup)
    }
    # Weights are only relevant for the binomial() family:
    if (!args_prj[[tstsetup]]$fam_nm %in% c("brnll", "binom")) {
      expect_equal(pp_ones, pp_orig, info = tstsetup)
      if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
        expect_equal(pp, pp_orig, info = tstsetup)
        expect_equal(ppw, pp_orig, info = tstsetup)
      }
    } else if (args_prj[[tstsetup]]$fam_nm == "brnll") {
      expect_equal(pp_ones, pp_orig, info = tstsetup)
      if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
        if (args_prj[[tstsetup]]$pkg_nm == "rstanarm") {
          expect_false(isTRUE(all.equal(pp, pp_orig)), info = tstsetup)
          expect_false(isTRUE(all.equal(ppw, pp_orig)), info = tstsetup)
          expect_false(isTRUE(all.equal(ppw, pp)), info = tstsetup)
        } else if (args_prj[[tstsetup]]$pkg_nm == "brms") {
          expect_equal(pp, pp_orig, info = tstsetup)
          expect_equal(ppw, pp_orig, info = tstsetup)
        }
      }
    } else if (args_prj[[tstsetup]]$fam_nm == "binom") {
      expect_false(isTRUE(all.equal(pp_ones, pp_orig)), info = tstsetup)
      if (!args_prj[[tstsetup]]$prj_nm %in% c("latent", "augdat")) {
        expect_equal(pp, pp_orig, info = tstsetup)
        expect_false(isTRUE(all.equal(ppw, pp_orig)), info = tstsetup)
        expect_false(isTRUE(all.equal(ppw, pp_ones)), info = tstsetup)
      }
    }
  }
})

## offsetnew --------------------------------------------------------------

test_that("`offsetnew` works", {
  skip_if_not(run_prj)
  for (tstsetup in names(prjs)) {
    nprjdraws_out_crr <- ndr_pp_out(args_prj[[tstsetup]],
                                    prj_out = prjs[[tstsetup]])
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- wobs_tst
    } else {
      wobs_crr <- NULL
    }
    pp_orig <- pps[[tstsetup]]
    add_offs_crr <- args_prj[[tstsetup]]$prj_nm == "latent" &&
      args_prj[[tstsetup]]$pkg_nm == "rstanarm" &&
      grepl("\\.with_offs\\.", tstsetup)
    expect_warning(
      pp_zeros <- proj_predict(prjs[[tstsetup]],
                               newdata = get_dat(tstsetup, dat_offs_zeros,
                                                 add_offs_dummy = add_offs_crr,
                                                 offs_brms = 0),
                               weightsnew = wobs_crr,
                               offsetnew = ~ offs_col_zeros,
                               .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = ~ offs_col_zeros),
      info = tstsetup
    )
    pp_tester(pp_zeros,
              nprjdraws_out_expected = nprjdraws_out_crr,
              cats_expected = list(
                refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
              ),
              info_str = tstsetup)
    expect_warning(
      pp <- proj_predict(prjs[[tstsetup]],
                         newdata = dat,
                         weightsnew = wobs_crr,
                         offsetnew = ~ offs_col,
                         .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = ~ offs_col),
      info = tstsetup
    )
    pp_tester(pp,
              nprjdraws_out_expected = nprjdraws_out_crr,
              cats_expected = list(
                refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
              ),
              info_str = tstsetup)
    expect_warning(
      ppo <- proj_predict(prjs[[tstsetup]],
                          newdata = get_dat(
                            tstsetup, dat_offs_new,
                            offs_ylat = dat_offs_new$offs_col_new,
                            add_offs_dummy = add_offs_crr,
                            offs_brms = dat_offs_new$offs_col_new
                          ),
                          weightsnew = wobs_crr,
                          offsetnew = ~ offs_col_new,
                          .seed = seed2_tst),
      get_warn_wrhs_orhs(tstsetup, weightsnew = wobs_crr,
                         offsetnew = ~ offs_col_new),
      info = tstsetup
    )
    pp_tester(ppo,
              nprjdraws_out_expected = nprjdraws_out_crr,
              cats_expected = list(
                refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
              ),
              info_str = tstsetup)
    if (grepl("\\.with_offs", tstsetup)) {
      expect_equal(pp, pp_orig, info = tstsetup)
      expect_false(isTRUE(all.equal(pp_zeros, pp_orig)), info = tstsetup)
      expect_false(isTRUE(all.equal(ppo, pp_orig)), info = tstsetup)
      # For the gaussian() family, we can perform an easy check (because of
      # the identity link):
      if (args_prj[[tstsetup]]$fam_nm == "gauss") {
        expect_equal(t(pp) - dat$offs_col, t(pp_zeros), info = tstsetup)
        expect_equal(t(ppo) - dat_offs_new$offs_col_new, t(pp_zeros),
                     info = tstsetup)
      }
    } else {
      if (args_prj[[tstsetup]]$pkg_nm == "rstanarm") {
        expect_equal(pp_zeros, pp_orig, info = tstsetup)
        expect_false(isTRUE(all.equal(pp, pp_orig)), info = tstsetup)
        # For the gaussian() family, we can perform an easy check (because of
        # the identity link):
        if (args_prj[[tstsetup]]$fam_nm == "gauss") {
          expect_equal(t(pp) - dat$offs_col, t(pp_orig), info = tstsetup)
          expect_equal(t(ppo) - dat_offs_new$offs_col_new, t(pp_orig),
                       info = tstsetup)
        } else {
          expect_false(isTRUE(all.equal(ppo, pp_orig)), info = tstsetup)
          expect_false(isTRUE(all.equal(ppo, pp)), info = tstsetup)
        }
      } else if (args_prj[[tstsetup]]$pkg_nm == "brms") {
        expect_equal(pp, pp_orig, info = tstsetup)
      }
    }
  }
})

## filter_nterms ----------------------------------------------------------

test_that("`filter_nterms` works (for an `object` of class `projection`)", {
  skip_if_not(run_prj)
  tstsetups <- grep("\\.brnll\\..*\\.prd_trms_x\\.clust$", names(prjs),
                    value = TRUE)
  for (tstsetup in tstsetups) {
    nterms_avail_crr <- length(args_prj[[tstsetup]]$predictor_terms)
    nterms_unavail_crr <- c(0L, nterms_avail_crr + 130L)
    stopifnot(!nterms_avail_crr %in% nterms_unavail_crr)
    for (filter_nterms_crr in nterms_unavail_crr) {
      expect_error(proj_predict(prjs[[tstsetup]],
                                filter_nterms = filter_nterms_crr,
                                .seed = seed2_tst),
                   "Invalid `filter_nterms`\\.",
                   info = paste(tstsetup, filter_nterms_crr, sep = "__"))
    }
    pp <- proj_predict(prjs[[tstsetup]],
                       filter_nterms = nterms_avail_crr,
                       .seed = seed2_tst)
    pp_orig <- pps[[tstsetup]]
    expect_equal(pp, pp_orig, info = tstsetup)
  }
})

test_that(paste(
  "`filter_nterms` works (for an `object` of (informal) class `proj_list`)"
), {
  skip_if_not(run_vs)
  tstsetups <- grep("\\.glm\\..*\\.full$", names(prjs_vs), value = TRUE)
  if (any(grepl("\\.L1\\.", tstsetups))) {
    tstsetups <- grep("\\.L1\\.", tstsetups, value = TRUE)
  }
  for (tstsetup in tstsetups) {
    # Unavailable number(s) of terms:
    for (filter_nterms_crr in nterms_unavail) {
      expect_error(proj_predict(prjs_vs[[tstsetup]],
                                filter_nterms = filter_nterms_crr,
                                .seed = seed2_tst),
                   "Invalid `filter_nterms`\\.",
                   info = paste(tstsetup,
                                paste(filter_nterms_crr, collapse = ","),
                                sep = "__"))
    }
    # Available number(s) of terms:
    nterms_avail_filter <- c(
      nterms_avail,
      list(partvec = c(nterms_max_tst %/% 2L, nterms_max_tst + 130L))
    )
    for (filter_nterms_crr in nterms_avail_filter) {
      pp_crr <- proj_predict(prjs_vs[[tstsetup]],
                             filter_nterms = filter_nterms_crr,
                             .seed = seed2_tst)
      if (is.null(filter_nterms_crr)) filter_nterms_crr <- 0:nterms_max_tst
      nhits_nterms <- sum(filter_nterms_crr <= nterms_max_tst)
      pp_tester(pp_crr,
                len_expected = nhits_nterms,
                cats_expected = replicate(
                  nhits_nterms,
                  refmods[[args_prj_vs[[tstsetup]]$tstsetup_ref]]$family$cats,
                  simplify = FALSE
                ),
                info_str = paste(tstsetup,
                                 paste(filter_nterms_crr, collapse = ","),
                                 sep = "__"))
      if (identical(filter_nterms_crr, 0:nterms_max_tst)) {
        # The special case of all possible numbers of terms:
        pp_orig <- pps_vs[[tstsetup]]
        expect_equal(pp_crr, pp_orig, info = tstsetup)
      }
    }
  }
})

## Single observation, single draw ----------------------------------------

test_that(paste(
  "a single observation and a single draw work (which implicitly tests",
  "this edge case for family$ppd(), too)"
), {
  skip_if_not(run_prj)
  for (tstsetup in grep("\\.clust$", names(prjs), value = TRUE)) {
    if (args_prj[[tstsetup]]$mod_nm == "gamm") {
      # TODO (GAMMs): Fix this.
      next
    }
    if (grepl("\\.with_wobs|\\.binom", tstsetup)) {
      wobs_crr <- head(wobs_tst, 1)
    } else {
      wobs_crr <- NULL
    }
    if (grepl("\\.with_offs", tstsetup)) {
      offs_crr <- head(offs_tst, 1)
    } else {
      offs_crr <- NULL
    }
    pp_args <- list(refmods[[args_prj[[tstsetup]]$tstsetup_ref]],
                    newdata = head(get_dat(tstsetup), 1),
                    weightsnew = wobs_crr,
                    offsetnew = offs_crr,
                    nresample_clusters = 1L,
                    .seed = seed2_tst,
                    predictor_terms = args_prj[[tstsetup]]$predictor_terms,
                    nclusters = 1L,
                    seed = seed_tst)
    if (args_prj[[tstsetup]]$fam_nm == "categ" &&
        any(grepl("\\|", args_prj[[tstsetup]]$predictor_terms))) {
      pp_args <- c(pp_args, list(avoid.increase = TRUE))
    }
    # Use suppressWarnings() because test_that() somehow redirects stderr() and
    # so throws warnings that projpred wants to capture internally:
    pp1 <- suppressWarnings(do.call(proj_predict, pp_args))
    pp_tester(pp1,
              nprjdraws_out_expected = 1L,
              nobsv_expected = 1L,
              cats_expected = list(
                refmods[[args_prj[[tstsetup]]$tstsetup_ref]]$family$cats
              ),
              info_str = tstsetup)
  }
})

## Projected draws with different weights ---------------------------------

test_that("`return_draws_matrix` causes a conversion of the output type", {
  skip_if_not(run_prj)
  skip_if_not_installed("posterior")
  for (tstsetup in names(prjs)) {
    for (r_oscale_crr in c(FALSE, TRUE)) {
      if (!r_oscale_crr && args_prj[[tstsetup]]$prj_nm != "latent") next
      if (r_oscale_crr) {
        pp_orig <- pps[[tstsetup]]
      } else {
        pp_orig <- proj_predict(
          prjs[[tstsetup]], resp_oscale = r_oscale_crr, .seed = seed2_tst
        )
      }
      pp_dr <- proj_predict(
        prjs[[tstsetup]], resp_oscale = r_oscale_crr,
        return_draws_matrix = TRUE, .seed = seed2_tst
      )
      pp_dr_repl <- posterior::as_draws_matrix(pp_orig)
      expect_equal(pp_dr, pp_dr_repl,
                   info = paste(tstsetup, r_oscale_crr, sep = "__"))
    }
  }
})