From 2c2eaa047bb650aecc938b258349654032d7eebc Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Sat, 22 Apr 2023 13:22:26 -0400 Subject: [PATCH 1/7] experimental tidier for glmm package --- R/glmm_tidiers.R | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 R/glmm_tidiers.R diff --git a/R/glmm_tidiers.R b/R/glmm_tidiers.R new file mode 100644 index 0000000..11b981e --- /dev/null +++ b/R/glmm_tidiers.R @@ -0,0 +1,26 @@ +##' @importFrom dplyr bind_rows tibble +##' @export +tidy.glmm <- function(x, effects = "fixed") { + 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") +} From f2a9b297abd7ff139d157cd81a58a36cb25325da Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Wed, 30 Aug 2023 14:13:25 -0400 Subject: [PATCH 2/7] fix lmList4 tidier bug --- R/lme4_tidiers.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/lme4_tidiers.R b/R/lme4_tidiers.R index 5e2ab51..93982e4 100644 --- a/R/lme4_tidiers.R +++ b/R/lme4_tidiers.R @@ -553,7 +553,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) From fbcac8222f827c1fc1eb251136169ac27f3407f5 Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Mon, 13 Nov 2023 22:32:41 -0700 Subject: [PATCH 3/7] fix exponentiate for brms --- R/brms_tidiers.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/brms_tidiers.R b/R/brms_tidiers.R index 3e9d07c..27b8fa3 100644 --- a/R/brms_tidiers.R +++ b/R/brms_tidiers.R @@ -280,7 +280,7 @@ tidy.brmsfit <- function(x, parameters = NA, if (exponentiate) { vv <- c("estimate", "conf.low", "conf.high") out <- (out - %>% mutate(across(contains(vv)), exp) + %>% mutate(across(contains(vv), exp)) %>% mutate(across(std.error, ~ . * estimate)) ) } From 4fea316540b631a4e5b2de3cf35236bb3fa6e00b Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Mon, 27 Nov 2023 11:01:40 -0500 Subject: [PATCH 4/7] too much at once (brms, fix check problems, rstanarm) --- DESCRIPTION | 2 +- NAMESPACE | 3 +++ R/brms_tidiers.R | 37 +++++++++++++++++++++++++++++++------ R/glmm_tidiers.R | 3 +++ R/rstanarm_tidiers.R | 2 +- man/rstanarm_tidiers.Rd | 2 +- tests/testthat/test-brms.R | 2 ++ 7 files changed, 42 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c3342df..9ccce94 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -80,4 +80,4 @@ License: GPL-3 Encoding: UTF-8 Additional_repositories: http://bbolker.github.io/drat VignetteBuilder: knitr -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 diff --git a/NAMESPACE b/NAMESPACE index 48431cc..79737c7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,6 +29,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) @@ -62,6 +63,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) @@ -92,6 +94,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) diff --git a/R/brms_tidiers.R b/R/brms_tidiers.R index 27b8fa3..37cb04c 100644 --- a/R/brms_tidiers.R +++ b/R/brms_tidiers.R @@ -110,7 +110,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") @@ -226,8 +229,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, "_(.+?)\\[(.+?),(.+?)\\]") @@ -242,10 +265,12 @@ tidy.brmsfit <- function(x, parameters = NA, out <- dplyr::bind_rows(res_list, .id = "effect") 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 diff --git a/R/glmm_tidiers.R b/R/glmm_tidiers.R index 11b981e..cfb5264 100644 --- a/R/glmm_tidiers.R +++ b/R/glmm_tidiers.R @@ -1,6 +1,9 @@ ##' @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() diff --git a/R/rstanarm_tidiers.R b/R/rstanarm_tidiers.R index 42706af..81fb472 100644 --- a/R/rstanarm_tidiers.R +++ b/R/rstanarm_tidiers.R @@ -76,7 +76,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"), diff --git a/man/rstanarm_tidiers.Rd b/man/rstanarm_tidiers.Rd index 44e4804..667fd47 100644 --- a/man/rstanarm_tidiers.Rd +++ b/man/rstanarm_tidiers.Rd @@ -8,7 +8,7 @@ \usage{ \method{tidy}{stanreg}( x, - effects = "fixed", + effects = c("fixed", "ran_pars"), conf.int = FALSE, conf.level = 0.9, conf.method = c("quantile", "HPDinterval"), diff --git a/tests/testthat/test-brms.R b/tests/testthat/test-brms.R index e1c259b..894eea3 100644 --- a/tests/testthat/test-brms.R +++ b/tests/testthat/test-brms.R @@ -17,4 +17,6 @@ if (require(brms, quietly = TRUE) && require(rstanarm, quietly=TRUE)) { ## GH #101 gg <- glance(brms_noran) expect_equal(names(gg),c("algorithm","pss","nobs","sigma")) + + expect_error(suppressWarnings(tidy(brms_multi, effects = "junk"))) } From d021b4413b93ae78672d44f2a117ad3be6189da2 Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Mon, 27 Nov 2023 11:04:59 -0500 Subject: [PATCH 5/7] update GH actions --- .github/workflows/R-CMD-check.yaml | 55 +++++++----------------------- 1 file changed, 13 insertions(+), 42 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index a0bd874..91807ba 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -24,7 +24,7 @@ jobs: fail-fast: false matrix: config: - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} + - {os: ubuntu-latest, r: 'devel'} ## - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} ## - {os: windows-latest, r: 'release'} ## - {os: macOS-latest, r: 'release'} @@ -36,56 +36,27 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v3 - - uses: r-lib/actions/setup-r@v1 + - uses: r-lib/actions/setup-r-dependencies@v2 with: - r-version: ${{ matrix.config.r }} - - - uses: r-lib/actions/setup-pandoc@v1 - - - name: Query dependencies - run: | - install.packages('remotes') - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} + extra-packages: any::rcmdcheck + needs: check - - name: Cache R packages - if: runner.os != 'Windows' - uses: actions/cache@v2 + - uses: r-lib/actions/setup-r@v2 with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- + r-version: ${{ matrix.config.r }} - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - sudo apt-get install libcurl4-openssl-dev + - uses: r-lib/actions/setup-pandoc@v2 - name: Install texlive etc. run: sudo apt-get install texlive texlive-science texlive-latex-extra texlive-bibtex-extra - - name: Install dependencies - run: | - remotes::install_deps(dependencies = TRUE) - remotes::install_cran("rcmdcheck") - shell: Rscript {0} - - - name: Check + - uses: r-lib/actions/check-r-package@v2 env: _R_CHECK_CRAN_INCOMING_REMOTE_: false - run: rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main + _R_CHECK_FORCE_SUGGESTS_: false + NOT_CRAN: true with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check + build_args: 'c("--compact-vignettes=both")' + upload-snapshots: true From 117a586acc0c6348c293c0216f8a0724cb3efa91 Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Fri, 1 Dec 2023 20:14:10 -0500 Subject: [PATCH 6/7] include_mapped to include_nonest; NEWS --- R/glmmTMB_tidiers.R | 5 ++++- inst/NEWS.Rd | 16 ++++++++++++++-- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/R/glmmTMB_tidiers.R b/R/glmmTMB_tidiers.R index b8bbdcd..c10cdb5 100644 --- a/R/glmmTMB_tidiers.R +++ b/R/glmmTMB_tidiers.R @@ -105,7 +105,10 @@ tidy.glmmTMB <- function(x, effects = c("ran_pars", "fixed"), safe_confint <- function(...) { args <- list(...) - if (packageVersion("glmmTMB") >= "1.1.4") { + pkgver <- packageVersion("glmmTMB") + if (pkgver >= "1.1.8") { + args <- c(args, list(include_nonest = TRUE)) + } else if (pkgver >= "1.1.4") { args <- c(args, list(include_mapped = TRUE)) } do.call(confint, args) diff --git a/inst/NEWS.Rd b/inst/NEWS.Rd index d3e6911..bad0817 100644 --- a/inst/NEWS.Rd +++ b/inst/NEWS.Rd @@ -8,10 +8,22 @@ \subsection{USER-VISIBLE CHANGES}{ \itemize{ \item \code{as.data.frame.ranef.lme} now processes the - \code{optional} argument (see \code{?as.data.frame}), so that - \code{data.frame(ranef_object)} works + \code{optional} argument (see \code{?as.data.frame}), so that + \code{data.frame(ranef_object)} works + \item add \code{"ran_pars"} to default effects for \code{rstanarm} + tidiers + \item add experimental tidier for \code{glmm} package } } % user-visible changes + \subsection{BUG FIXES}{ + \itemize{ + \item \code{glmmTMB} tidier updated for argument name + change (\code{include_mapped} to \code{include_nonest}) + in \code{confint.glmmTMB} in version 1.1.8 + \item fix \code{exponentiate} bug for \code{brms} tidiers + \item fix \code{lmList4} tidier bug + } + } \section{CHANGES IN VERSION 0.2.9.4 (2022-03-28)}{ From 1bf59b6de0f9f744d6758bc93f529f1cf9220a70 Mon Sep 17 00:00:00 2001 From: Ben Bolker Date: Fri, 5 Apr 2024 17:06:40 -0400 Subject: [PATCH 7/7] experimental start for ordinal augment --- DESCRIPTION | 1 + R/ordinal_tidiers.R | 49 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+) create mode 100644 R/ordinal_tidiers.R diff --git a/DESCRIPTION b/DESCRIPTION index 9ccce94..7f5180c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -66,6 +66,7 @@ Suggests: MCMCglmm, mediation, mgcv, + ordinal, pander, pbkrtest, rstan, diff --git a/R/ordinal_tidiers.R b/R/ordinal_tidiers.R new file mode 100644 index 0000000..5158d35 --- /dev/null +++ b/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)) + +}