Fix as.matrix.projection() for 1 (clustered) draw

DESCRIPTION

@@ -26,7 +26,6 @@ Depends:
 Imports:
     methods,
     dplyr,
-    tidyselect,
     loo (>= 2.0.0),
     rstantools (>= 2.0.0),
     lme4,

NAMESPACE

@@ -1,6 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as.matrix,gamm4)
+S3method(as.matrix,glm)
+S3method(as.matrix,glmerMod)
+S3method(as.matrix,list)
+S3method(as.matrix,lm)
+S3method(as.matrix,lmerMod)
 S3method(as.matrix,projection)
+S3method(as.matrix,ridgelm)
+S3method(as.matrix,subfit)
+S3method(coef,subfit)
 S3method(cv_varsel,default)
 S3method(cv_varsel,refmodel)
 S3method(get_refmodel,default)
@@ -13,6 +22,10 @@ S3method(print,vsel)
 S3method(print,vselsummary)
 S3method(suggest_size,vsel)
 S3method(summary,vsel)
+S3method(t,glm)
+S3method(t,list)
+S3method(t,lm)
+S3method(t,ridgelm)
 S3method(varsel,default)
 S3method(varsel,refmodel)
 export("%>%")

NEWS.md

@@ -24,6 +24,7 @@
 * Fixed bugs for argument `nterms` of `proj_linpred()` and `proj_predict()`. (GitHub: #110)
 * Fixed an inconsistency for some intercept-only submodels. (GitHub: #119)
 * Minor documentation fixes.
+* Fix a bug for `as.matrix.projection()` in case of 1 (clustered) draw after projection. (GitHub: #130)
 * For submodels of class `"subfit"`, make the column names of `as.matrix.projection()`'s output matrix consistent with other classes of submodels. (GitHub: #132)
 
 ## projpred 2.0.5

R/gamm4.R

@@ -1,7 +1,3 @@
-`%:::%` <- function(pkg, fun) {
-  get(fun, envir = asNamespace(pkg), inherits = FALSE)
-}
-
 ## taken from gam4
 #' @noRd
 #' @importFrom methods as cbind2 is

R/methods.R

@@ -45,8 +45,9 @@
 #'   projection (as determined by argument \code{nclusters} of \link{project}).
 #' @param seed_ppd For \code{proj_predict} only: An optional seed for drawing
 #'   from the posterior predictive distribution. If a clustered projection was
-#'   performed, `seed_ppd` is also used for drawing from the set of clustered
-#'   posterior draws after projection (see argument \code{nclusters_resample}).
+#'   performed, \code{seed_ppd} is also used for drawing from the set of
+#'   clustered posterior draws after projection (see argument
+#'   \code{nclusters_resample}).
 #' @param ... Additional arguments passed to \link{project} if \code{object} is
 #'   not already an object returned by \link{project}.
 #'
@@ -790,6 +791,8 @@ replace_population_names <- function(population_effects) {
 }
 
 #' @method coef subfit
+#' @keywords internal
+#' @export
 coef.subfit <- function(object, ...) {
   return(with(object, c(
     "Intercept" = alpha,
@@ -798,27 +801,37 @@ coef.subfit <- function(object, ...) {
 }
 
 #' @method as.matrix lm
+#' @keywords internal
+#' @export
 as.matrix.lm <- function(x, ...) {
   return(coef(x) %>%
            replace_population_names())
 }
 
 #' @method as.matrix ridgelm
+#' @keywords internal
+#' @export
 as.matrix.ridgelm <- function(x, ...) {
   return(as.matrix.lm(x))
 }
 
 #' @method as.matrix subfit
+#' @keywords internal
+#' @export
 as.matrix.subfit <- function(x, ...) {
-  return(as.matrix.lm(x))
+  return(as.matrix.lm(x, ...))
 }
 
 #' @method as.matrix glm
+#' @keywords internal
+#' @export
 as.matrix.glm <- function(x, ...) {
-  return(as.matrix.lm(x))
+  return(as.matrix.lm(x, ...))
 }
 
 #' @method as.matrix lmerMod
+#' @keywords internal
+#' @export
 as.matrix.lmerMod <- function(x, ...) {
   population_effects <- lme4::fixef(x) %>%
     replace_population_names()
@@ -936,37 +949,57 @@ as.matrix.lmerMod <- function(x, ...) {
   return(c(population_effects, group_vc, group_ef))
 }
 
-#' @method as.matrix noquote
-as.matrix.noquote <- function(x, ...) {
-  return(coef(x))
+#' @method as.matrix glmerMod
+#' @keywords internal
+#' @export
+as.matrix.glmerMod <- function(x, ...) {
+  return(as.matrix.lmerMod(x, ...))
+}
+
+#' @method as.matrix gamm4
+#' @keywords internal
+#' @export
+as.matrix.gamm4 <- function(x, ...) {
+  return(as.matrix.lm(x, ...))
 }
 
 #' @method as.matrix list
+#' @keywords internal
+#' @export
 as.matrix.list <- function(x, ...) {
-  return(do.call(cbind, lapply(x, as.matrix.glm)))
+  return(do.call(cbind, lapply(x, as.matrix.glm, ...)))
 }
 
 #' @method t glm
+#' @keywords internal
+#' @export
 t.glm <- function(x, ...) {
-  return(t(as.matrix(x)))
+  return(t(as.matrix(x), ...))
 }
 
 #' @method t lm
+#' @keywords internal
+#' @export
 t.lm <- function(x, ...) {
-  return(t(as.matrix(x)))
+  return(t(as.matrix(x), ...))
 }
 
 #' @method t ridgelm
+#' @keywords internal
+#' @export
 t.ridgelm <- function(x, ...) {
-  return(t(as.matrix(x)))
+  return(t(as.matrix(x), ...))
 }
 
 #' @method t list
+#' @keywords internal
+#' @export
 t.list <- function(x, ...) {
-  return(t(as.matrix.list(x)))
+  return(t(as.matrix.list(x), ...))
 }
 
 #' @method as.matrix projection
+#' @keywords internal
 #' @export
 as.matrix.projection <- function(x, ...) {
   if (x$p_type) {
@@ -975,20 +1008,15 @@ as.matrix.projection <- function(x, ...) {
       "clustering and the clusters might have different weights."
     ))
   }
-  if (inherits(x$sub_fit, "list")) {
-    if ("lmerMod" %in% class(x$sub_fit[[1]]) ||
-        "glmerMod" %in% class(x$sub_fit[[1]])) {
-      res <- t(do.call(cbind, lapply(x$sub_fit, as.matrix.lmerMod)))
-    } else {
-      if (inherits(x$sub_fit[[1]], "subfit")) {
-        res <- t(do.call(cbind, lapply(x$sub_fit, as.matrix.subfit)))
-      } else {
-        res <- t(do.call(cbind, lapply(x$sub_fit, as.matrix.lm)))
-      }
-    }
-  } else {
-    res <- t(as.matrix.lm(x$sub_fit))
+  if (!inherits(x$sub_fit, "list")) {
+    x$sub_fit <- list(x$sub_fit)
+  }
+  if (!inherits(x$sub_fit[[1]], get_as.matrix_cls_projpred())) {
+    # Throw an error because in this case, we probably need a new
+    # as.matrix.<class_name>() method.
+    stop("This case should not occur. Please notify the package maintainer.")
   }
+  res <- t(do.call(cbind, lapply(x$sub_fit, as.matrix)))
   colnames(res) <- gsub("^1|^alpha|\\(Intercept\\)", "Intercept", colnames(res))
   if (x$family$family == "gaussian") res <- cbind(res, sigma = x$dis)
   return(res)

R/misc.R

@@ -557,7 +557,31 @@ deparse_combine <- function(x, max_char = NULL) {
 #' @export
 magrittr::`%>%`
 
+`%:::%` <- function(pkg, fun) {
+  # Note: `utils::getFromNamespace(fun, pkg)` could probably be used, too (but
+  # its documentation is unclear about the inheritance from parent
+  # environments).
+  get(fun, envir = asNamespace(pkg), inherits = FALSE)
+}
+
 # Function where() is not exported by package tidyselect, so redefine it here to
 # avoid a note in R CMD check which would occur for usage of
 # tidyselect:::where():
-where <- utils::getFromNamespace("where", "tidyselect")
+where <- `%:::%`("tidyselect", "where")
+
+get_as.matrix_cls_projpred <- function() {
+  ### Only works when projpred is loaded via devtools::load_all():
+  # as.matrix_meths_projpred <- methods("as.matrix")
+  # as.matrix_meths_projpred <- as.matrix_meths_projpred[
+  #   attr(as.matrix_meths_projpred, "info")$from == "projpred"
+  # ]
+  ###
+  as.matrix_meths_projpred <- grep(
+    "^as\\.matrix\\.",
+    ls(envir = asNamespace("projpred")),
+    value = TRUE
+  )
+  as.matrix_cls_projpred <- sub("^as\\.matrix\\.", "", as.matrix_meths_projpred)
+  return(as.matrix_cls_projpred)
+}
+