Merge branch 'master'

.github/workflows/R-CMD-check.yaml

@@ -25,7 +25,7 @@ jobs:
       matrix:
         config:
           - {os: ubuntu-latest, r: 'release'}
-##          - {os: ubuntu-latest, r: 'devel'}
+          - {os: ubuntu-latest, r: 'devel'}
 ##          - {os: windows-latest, r: 'release'}
 ##          - {os: macOS-latest, r: 'release'}
 
@@ -38,8 +38,13 @@ jobs:
     steps:
       - uses: actions/checkout@v3
 
-      - uses: r-lib/actions/setup-pandoc@v2
 
+      - uses: r-lib/actions/setup-pandoc@v2
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::rcmdcheck
+          needs: check
+          upgrade: 'TRUE'
       - uses: r-lib/actions/setup-r@v2
         with:
 # not sure why this isn't picked up from DESCRIPTION?
@@ -48,17 +53,15 @@ jobs:
           http-user-agent: ${{ matrix.config.http-user-agent }}
           use-public-rspm: true
 
-      - uses: r-lib/actions/setup-r-dependencies@v2
-        with:
-          extra-packages: any::rcmdcheck
-          needs: check
-          upgrade: 'TRUE'
-
       - name: Install texlive etc.
         if: runner.os == 'Linux'
         run: sudo apt-get install texlive texlive-science texlive-latex-extra texlive-bibtex-extra
 
       - uses: r-lib/actions/check-r-package@v2
+        env:
+          _R_CHECK_CRAN_INCOMING_REMOTE_: false
+          _R_CHECK_FORCE_SUGGESTS_: false
+          NOT_CRAN: true
         with:
+          build_args: 'c("--compact-vignettes=both")'
           upload-snapshots: true
-

DESCRIPTION

@@ -68,6 +68,7 @@ Suggests:
     MCMCglmm,
     mediation,
     mgcv,
+    ordinal,
     pander,
     pbkrtest,
     posterior,
@@ -84,3 +85,4 @@ Encoding: UTF-8
 Additional_repositories: http://bbolker.github.io/drat
 VignetteBuilder: knitr
 RoxygenNote: 7.3.1
+

NAMESPACE

@@ -31,6 +31,7 @@ S3method(tidy,allFit)
 S3method(tidy,brmsfit)
 S3method(tidy,gamlss)
 S3method(tidy,gamm4)
+S3method(tidy,glmm)
 S3method(tidy,glmmTMB)
 S3method(tidy,glmmadmb)
 S3method(tidy,gls)
@@ -65,6 +66,7 @@ importFrom(dplyr,across)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,mutate)
+importFrom(dplyr,tibble)
 importFrom(forcats,fct_inorder)
 importFrom(furrr,future_map_dfr)
 importFrom(methods,is)
@@ -95,6 +97,7 @@ importFrom(stats,quantile)
 importFrom(stats,sd)
 importFrom(stats,setNames)
 importFrom(stats,terms)
+importFrom(stats,vcov)
 importFrom(tibble,rownames_to_column)
 importFrom(tibble,tibble)
 importFrom(tidyr,complete)

R/brms_tidiers.R

@@ -118,7 +118,10 @@ tidy.brmsfit <- function(x, parameters = NA,
                          ...) {
 
   check_dots(...)
-
+  bad_effects <- setdiff(effects, c("fixed", "ran_pars", "ran_vals", "ran_coefs"))
+  if (length(bad_effects)>0) {
+      stop("unrecognized effects: ", paste(bad_effects, collapse = ", "))
+  }
   std.error <- NULL ## NSE/code check
   if (!requireNamespace("brms", quietly=TRUE)) {
       stop("can't tidy brms objects without brms installed")
@@ -235,8 +238,28 @@ tidy.brmsfit <- function(x, parameters = NA,
           term = sapply(ss2, termfun)
         )
     }
+
+    ## nice, but needs to be done outside averaging loop ...
+    ##   meltfun <- function(a) {
+
+    ##     dd <- as.data.frame(ftable(a)) |>  
+    ##         setNames(c("level", "var", "term", "value")) |>
+    ##         tidyr::pivot_wider(names_from = var, values_from = value) |>
+    ##         rename(estimate = "Estimate",
+    ##                std.error = "Est.Error",
+    ##                ## FIXME: not robust to changing levels
+    ##                conf.low = "Q2.5",
+    ##                conf.high = "Q97.5")
+    ##   }
+
+
+    ## ## purrr:::map_dfr(ranef(x), meltfun, .id = "group")
+
+    ## if ("ran_coefs" %in% effects) {
+    ##     res_list$ran_coefs <- purrr:::map_dfr(coef(x), meltfun, .id = "group")
+    ## }
     if ("ran_vals" %in% effects) {
-      rterms <- grep(mkRE(prefs$ran_vals), terms, value = TRUE)
+    rterms <- grep(mkRE(prefs$ran_vals), terms, value = TRUE)
 
       vals <- stringr::str_match_all(rterms, "_(.+?)\\[(.+?),(.+?)\\]")
 
@@ -259,10 +282,12 @@ tidy.brmsfit <- function(x, parameters = NA,
     }
     v <- if (fixed.only) seq(nrow(out)) else is.na(out$term)
     newterms <- stringr::str_remove(terms[v], mkRE(prefs[c("fixed")]))
-    if (fixed.only) {
-      out$term <- newterms
-    } else {
-      out$term[v] <- newterms
+    if (length(newterms)>0) { 
+      if (fixed.only) {
+        out$term <- newterms
+      } else {
+        out$term[v] <- newterms
+      }
     }
     if (is.multiresp) {
         out$response <- response

R/glmmTMB_tidiers.R

@@ -105,9 +105,12 @@ tidy.glmmTMB <- function(x, effects = c("ran_pars", "fixed"),
 
     safe_confint <- function(..., s_component = NULL) {
         args <- list(...)
-        if (packageVersion("glmmTMB") >= "1.1.4" && conf.method != "tmbroot") {
-            ## FIXME: check/make tmbroot handle nonest properly?
+        pkgver <- packageVersion("glmmTMB")
+        if (pkgver >= "1.1.8") {
             args <- c(args, list(include_nonest = TRUE))
+        } else if (pkgver >= "1.1.4" && conf.method != "tmbroot") {
+            ## FIXME: check/make tmbroot handle nonest properly?
+            args <- c(args, list(include_mapped = TRUE))
         }
         res <- do.call(confint, args)
         if (!is.null(s_component)) {

R/glmm_tidiers.R

@@ -0,0 +1,29 @@
+##' @importFrom dplyr bind_rows tibble
+##' @importFrom stats vcov
+##' @export
+tidy.glmm <- function(x, effects = "fixed") {
+
+    estimate <- std.error <- statistic <- p.value <- NULL ## avoid check warnings for NSE
+    fix_nm <- names(coef(x))
+    ran_nm <- x$varcomps.names
+    res <- list()
+    if ("fixed" %in% effects) {
+        res[["fixed"]] <-
+            tibble(
+                term = fix_nm,
+                estimate = coef(x),
+                std.error = sqrt(diag(vcov(x)))[fix_nm]) |>
+            mutate(statistic = estimate/std.error,
+                   p.value = 2*pnorm(-abs(statistic)))
+    }
+    if ("ran_pars" %in% effects) {
+        res[["fixed"]] <-
+            tibble(
+                term = ran_nm,
+                estimate = x$nu,
+                std.error = sqrt(diag(vcov(x)))[ran_nm]) |>
+            mutate(statistic = NA_real_,
+                   p.value = NA_real_)
+    }
+    bind_rows(res, .id = "effect")
+}

R/lme4_tidiers.R

@@ -554,7 +554,7 @@ tidy.lmList4 <- function(x, conf.int = FALSE,
                   dplyr::mutate(`terms` = dimnames(ss)$terms[i])
     }
     tmp <- dplyr::bind_rows(tmp)
-    tmp <- tmp[, unique(c("group", "terms"), sort(colnames(tmp)))]
+    tmp <- tmp[, unique(c("group", "terms", sort(colnames(tmp))))]
     tmp <- tmp[order(tmp$group, tmp$terms),]
     ret <- tibble::as_tibble(tmp)
 

R/ordinal_tidiers.R

@@ -0,0 +1,49 @@
+predict.clmm <- function(object, ...) {
+    ## hack clmm object so it looks sufficiently like a clm[m]2 object
+    ##  for the predict.clm2 method to work ...
+    object$location <- object$formula
+    if (object$link == "logit") object$link <- "logistic"
+    attr(object$location, "terms") <- object$terms
+    class(object) <- c("clm2")
+    predict(object, ...)
+}
+
+## predict values for every level in an ordinal response
+## copied/modified from 
+predict.all.clmm <- function(object, newdata, ...) {
+    respvar <- attr(object$terms, "response")
+    mf <- model.frame(object)
+    nlev <- length(levels(mf[[respvar]]))
+    if (!missing(newdata)) mf <- model.frame(object$formula, data = newdata)
+    ndat <- do.call(rbind,
+                    replicate(nlev, mf, simplify = FALSE))
+    ndat[[respvar]] <- ordered(rep(seq(nlev), each = nrow(mf)))
+    res <- matrix(predict(object, newdata = ndat), ncol=nlev)
+}
+
+#' name ordinal_tidiers
+#' 
+#' the \code{tidy} method for \code{clmm} objects (from the
+#' \code{ordinal} package) lives in the \code{broom} package.
+#'
+#' @importFrom tibble tibble
+#' @export
+augment.clmm <- function(...,
+                         data = stats::model.frame(x), newdata, ...) {
+
+    if (!missing(newdata)) data <- newdata
+
+}
+
+if (FALSE) {
+    library(ordinal)
+
+    fmm1 <- clmm(rating ~ temp + contact + (1|judge), data = wine)
+    fmm2 <- clmm2(rating ~ temp + contact, random = judge, data = wine)
+
+
+    mm <- predict.all.clmm(fmm1)
+    stopifnot(all.equal(predict(fmm1), predict(fmm2),
+                        tolerance  = 1e-6))
+
+}

R/rstanarm_tidiers.R

@@ -88,7 +88,7 @@ NULL
 #'
 #' @export
 tidy.stanreg <- function(x,
-                         effects = "fixed",
+                         effects = c("fixed", "ran_pars"),
                          conf.int = FALSE,
                          conf.level = 0.9,
                          conf.method=c("quantile","HPDinterval"),

tests/testthat/test-brms.R

@@ -15,6 +15,7 @@ if (require(brms, quietly = TRUE) && require(rstanarm, quietly=TRUE)) {
   gg <- glance(brms_noran)
   expect_equal(names(gg),c("algorithm","pss","nobs","sigma"))
 
+
   ## Check the descriptive columns of tidy summaries
   ### brms_RE
   expected <- tibble::tribble(
@@ -46,4 +47,6 @@ if (require(brms, quietly = TRUE) && require(rstanarm, quietly=TRUE)) {
   observed <- suppressWarnings(tidy(brms_brm_fit4))
   expect_equal(observed[, 1:4], expected)
 
+
+  expect_error(suppressWarnings(tidy(brms_multi, effects = "junk")))
 }