diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 1499c2c..b28ce8a 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.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 - diff --git a/DESCRIPTION b/DESCRIPTION index 8bf08e6..68ff4a9 100644 --- a/DESCRIPTION +++ b/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 + diff --git a/NAMESPACE b/NAMESPACE index bd83983..e0cd1f7 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/brms_tidiers.R b/R/brms_tidiers.R index 8ac2071..3b33b9d 100644 --- a/R/brms_tidiers.R +++ b/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 diff --git a/R/glmmTMB_tidiers.R b/R/glmmTMB_tidiers.R index 4081ecf..d0fef82 100644 --- a/R/glmmTMB_tidiers.R +++ b/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)) { diff --git a/R/glmm_tidiers.R b/R/glmm_tidiers.R new file mode 100644 index 0000000..cfb5264 --- /dev/null +++ b/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") +} diff --git a/R/lme4_tidiers.R b/R/lme4_tidiers.R index 95e97d7..f432076 100644 --- a/R/lme4_tidiers.R +++ b/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) 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)) + +} diff --git a/R/rstanarm_tidiers.R b/R/rstanarm_tidiers.R index 8e6ce4b..8cb496d 100644 --- a/R/rstanarm_tidiers.R +++ b/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"), diff --git a/man/rstanarm_tidiers.Rd b/man/rstanarm_tidiers.Rd index ad7550c..47ab1ca 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 c698f15..00e0a79 100644 --- a/tests/testthat/test-brms.R +++ b/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"))) }