refactor glance() methods (closes #823)

tidymodels · Jun 3, 2020 · 0992155 · 0992155
1 parent a563187
commit 0992155
Show file tree

Hide file tree

Showing 45 changed files with 257 additions and 184 deletions.
diff --git a/R/aer-tidiers.R b/R/aer-tidiers.R
@@ -124,35 +124,36 @@ augment.ivreg <- function(x, data = model.frame(x), newdata = NULL, ...) {
 #' @seealso [glance()], [AER::ivreg()]
 #' @family ivreg tidiers
 glance.ivreg <- function(x, diagnostics = FALSE, ...) {
-  s <- summary(x, diagnostics = FALSE)
 
-  ret <- with(
-    s,
-    tibble(
-      r.squared = r.squared,
-      adj.r.squared = adj.r.squared,
-      sigma = sigma,
-      statistic = waldtest[1],
-      p.value = waldtest[2],
-      df = df[1]
-    )
+  s <- summary(x, diagnostics = FALSE)
+
+  ret <- as_glance_tibble(
+    r.squared = s$r.squared,
+    adj.r.squared = s$adj.r.squared,
+    sigma = s$sigma,
+    statistic = s$waldtest[1],
+    p.value = s$waldtest[2],
+    df = s$df[1],
+    df.residual = df.residual(x),
+    nobs = stats::nobs(x),
+    na_types = "rrrrriii"
   )
-  ret$df.residual <- df.residual(x)
-  ret$nobs <- stats::nobs(x)
 
   if (diagnostics) {
-    ret <- with(
-      summary(x, diagnostics = TRUE),
-      tibble(
-        statistic.Sargan = diagnostics["Sargan", "statistic"],
-        p.value.Sargan = diagnostics["Sargan", "p-value"],
-        statistic.Wu.Hausman = diagnostics["Wu-Hausman", "statistic"],
-        p.value.Wu.Hausman = diagnostics["Wu-Hausman", "p-value"]
-      )
+    s_ <- summary(x, diagnostics = TRUE)
+
+    diags <- as_glance_tibble(
+      statistic.Sargan = s_$diagnostics["Sargan", "statistic"],
+      p.value.Sargan = s_$diagnostics["Sargan", "p-value"],
+      statistic.Wu.Hausman = s_$diagnostics["Wu-Hausman", "statistic"],
+      p.value.Wu.Hausman = s_$diagnostics["Wu-Hausman", "p-value"],
+      na_types = "rrrr"
     )
+
+    return(bind_cols(ret, diags))
   }
 
-  as_tibble(ret, rownames = NULL)
+  ret
 }
 
 #' @include null-and-default-tidiers.R

diff --git a/R/betareg-tidiers.R b/R/betareg-tidiers.R
@@ -98,13 +98,14 @@ augment.betareg <- function(x, data = model.frame(x), newdata = NULL,
 #' @export
 glance.betareg <- function(x, ...) {
   s <- summary(x)
-  tibble(
+  as_glance_tibble(
     pseudo.r.squared = s$pseudo.r.squared,
     df.null = s$df.null,
     logLik = as.numeric(stats::logLik(x)),
     AIC = stats::AIC(x),
     BIC = stats::BIC(x),
     df.residual = stats::df.residual(x),
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "rirrrii"
   )
 }
diff --git a/R/biglm-tidiers.R b/R/biglm-tidiers.R
@@ -76,11 +76,12 @@ tidy.biglm <- function(x, conf.int = FALSE, conf.level = .95,
 #' @seealso [glance()], [biglm::biglm()], [biglm::bigglm()]
 glance.biglm <- function(x, ...) {
   s <- summary(x)
-  tibble(
+  as_glance_tibble(
     r.squared = s$rsq,
     AIC = stats::AIC(x),
     deviance = stats::deviance(x),
     df.residual = x$df.resid,
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "rrrii"
   )
 }
diff --git a/R/bingroup-tidiers.R b/R/bingroup-tidiers.R
@@ -94,10 +94,14 @@ tidy.binDesign <- function(x, ...) {
 #' @family bingroup tidiers
 #' @seealso [glance()], [binGroup::binDesign()]
 glance.binDesign <- function(x, ...) {
-  with(unclass(x), tibble(
-    power = powerout,
-    n = nout,
-    power.reached,
-    maxit = maxit
-  ))
+
+  ux <- unclass(x)
+
+  as_glance_tibble(
+    power = ux$powerout,
+    n = ux$nout,
+    power.reached = ux$power.reached,
+    maxit = ux$maxit,
+    na_types = "riri"
+  )
 }
diff --git a/R/drc-tidiers.R b/R/drc-tidiers.R
@@ -61,11 +61,12 @@ tidy.drc <- function(x, conf.int = FALSE, conf.level = 0.95, ...) {
 #' @export
 #' @family drc tidiers
 glance.drc <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     AIC = stats::AIC(x),
     BIC = stats::BIC(x),
     logLik = stats::logLik(x),
-    df.residual = x$df.residual
+    df.residual = x$df.residual,
+    na_types = "rrri"
   )
 }
 

diff --git a/R/ergm-tidiers.R b/R/ergm-tidiers.R
@@ -105,15 +105,15 @@ tidy.ergm <- function(x, conf.int = FALSE, conf.level = 0.95,
 #' @param mcmc Logical indicating whether or not to report MCMC interval,
 #'   burn-in and sample size used to estimate the model. Defaults to `FALSE`.
 #'
-#' @return `glance.ergm` returns a one-row data.frame with the columns
+#' @return `glance.ergm` returns a one-row tibble with the columns
 #'   \item{independence}{Whether the model assumed dyadic independence}
 #'   \item{iterations}{The number of MCMLE iterations performed before convergence}
 #'   \item{logLik}{If applicable, the log-likelihood associated with the model}
 #'   \item{AIC}{The Akaike Information Criterion}
 #'   \item{BIC}{The Bayesian Information Criterion}
 #'
 #' If `deviance = TRUE`, and if the model supports it, the
-#' data frame will also contain the columns
+#' tibble will also contain the columns
 #'   \item{null.deviance}{The null deviance of the model}
 #'   \item{df.null}{The degrees of freedom of the null deviance}
 #'   \item{residual.deviance}{The residual deviance of the model}
@@ -125,10 +125,11 @@ tidy.ergm <- function(x, conf.int = FALSE, conf.level = 0.95,
 glance.ergm <- function(x, deviance = FALSE, mcmc = FALSE, ...) {
   s <- summary(x, ...) # produces lots of messages
 
-  ret <- tibble(
+  ret <- as_glance_tibble(
     independence = s$independence,
     iterations = x$iterations,
-    logLik = as.numeric(logLik(x))
+    logLik = as.numeric(logLik(x)),
+    na_types = "lir"
   )
 
   if (deviance & !is.null(ret$logLik)) {

diff --git a/R/gam-tidiers.R b/R/gam-tidiers.R
@@ -53,15 +53,18 @@ tidy.Gam <- function(x, ...) {
 #' @export
 #' @seealso [glance()], [gam::gam()]
 glance.Gam <- function(x, ...) {
+
   s <- summary(x)
-  ret <- tibble(
+
+  as_glance_tibble(
     df = s$df[1],
     logLik = as.numeric(stats::logLik(x)),
     AIC = stats::AIC(x),
     BIC = stats::BIC(x),
     deviance = stats::deviance(x),
     df.residual = stats::df.residual(x),
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "irrrrii"
   )
-  ret
+
 }
diff --git a/R/geepack-tidiers.R b/R/geepack-tidiers.R
@@ -116,11 +116,12 @@ confint.geeglm <- function(object, parm, level = 0.95, ...) {
 #' @family geepack tidiers
 glance.geeglm <- function(x, ...) {
   s <- summary(x)
-  tibble(
+  as_glance_tibble(
     df.residual = x$df.residual,
     n.clusters = length(s$clusz),
     max.cluster.size = max(s$clusz),
     alpha = x$geese$alpha,
-    gamma = x$geese$gamma
+    gamma = x$geese$gamma,
+    na_types = "iiirr"
   )
 }
diff --git a/R/glmnet-cv-glmnet-tidiers.R b/R/glmnet-cv-glmnet-tidiers.R
@@ -96,9 +96,10 @@ tidy.cv.glmnet <- function(x, ...) {
 #' @seealso [glance()], [glmnet::cv.glmnet()]
 #' @family glmnet tidiers
 glance.cv.glmnet <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     lambda.min = x$lambda.min,
     lambda.1se = x$lambda.1se,
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "rri"
   )
 }
diff --git a/R/glmnet-glmnet-tidiers.R b/R/glmnet-glmnet-tidiers.R
@@ -111,9 +111,10 @@ tidy.glmnet <- function(x, return_zeros = FALSE, ...) {
 #' @family glmnet tidiers
 #' @seealso [glance()], [glmnet::glmnet()]
 glance.glmnet <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     nulldev = x$nulldev,
     npasses = x$npasses,
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "rii"
   )
 }
diff --git a/R/gmm-tidiers.R b/R/gmm-tidiers.R
@@ -118,11 +118,13 @@ glance.gmm <- function(x, ...) {
 
   # TODO: why do we suppress warnings here?
   st <- suppressWarnings(as.numeric(s$stest$test))
-  tibble(
+
+  as_glance_tibble(
     df = x$df,
     statistic = st[1],
     p.value = st[2],
     df.residual = stats::df.residual(x),
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "irrii"
   )
 }
diff --git a/R/lfe-tidiers.R b/R/lfe-tidiers.R
@@ -175,18 +175,18 @@ glance.felm <- function(x, ...) {
       call. = FALSE
     )
   }
-  ret <- with(
-    summary(x),
-    tibble(
-      r.squared = r2,
-      adj.r.squared = r2adj,
-      sigma = rse,
-      statistic = fstat,
-      p.value = pval,
-      df = df[1],
-      df.residual = rdf,
-      nobs = stats::nobs(x)
-    )
+
+  s <- summary(x)
+
+  as_glance_tibble(
+    r.squared = s$r2,
+    adj.r.squared = s$r2adj,
+    sigma = s$rse,
+    statistic = s$fstat,
+    p.value = unname(s$pval),
+    df = s$df[1],
+    df.residual = s$rdf,
+    nobs = stats::nobs(x),
+    na_types = "rrrrriii"
   )
-  ret
 }
diff --git a/R/list-optim-tidiers.R b/R/list-optim-tidiers.R
@@ -53,10 +53,11 @@ tidy_optim <- function(x, ...) {
 #' @family list tidiers
 #' @seealso [glance()], [optim()]
 glance_optim <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     value = x$value,
-    function.count = x$counts["function"],
-    gradient.count = x$counts["gradient"],
-    convergence = x$convergence
+    function.count = unname(x$counts["function"]),
+    gradient.count = unname(x$counts["gradient"]),
+    convergence = x$convergence,
+    na_types = "riii"
   )
 }
diff --git a/R/lmodel2-tidiers.R b/R/lmodel2-tidiers.R
@@ -102,11 +102,12 @@ tidy.lmodel2 <- function(x, ...) {
 #' @family lmodel2 tidiers
 #'
 glance.lmodel2 <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     r.squared = x$rsquare,
     theta = x$theta,
     p.value = x$P.param,
     H = x$H,
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "rrrri"
   )
 }
diff --git a/R/mass-fitdistr-tidiers.R b/R/mass-fitdistr-tidiers.R
@@ -40,11 +40,12 @@ tidy.fitdistr <- function(x, ...) {
 #' @family fitdistr tidiers
 #' @seealso [tidy()], [MASS::fitdistr()]
 glance.fitdistr <- function(x, ...) {
-  ret <- tibble(
+  as_glance_tibble(
     logLik = stats::logLik(x),
     AIC = stats::AIC(x),
     BIC = stats::BIC(x),
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "rrri"
   )
-  ret
+
 }
diff --git a/R/mass-polr-tidiers.R b/R/mass-polr-tidiers.R
@@ -94,14 +94,15 @@ tidy.polr <- function(x, conf.int = FALSE, conf.level = 0.95,
 #' @seealso [tidy], [MASS::polr()]
 #' @family ordinal tidiers
 glance.polr <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     edf = x$edf,
     logLik = as.numeric(stats::logLik(x)),
     AIC = stats::AIC(x),
     BIC = stats::BIC(x),
     deviance = stats::deviance(x),
     df.residual = stats::df.residual(x),
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "irrrrii"
   )
 }
 

diff --git a/R/mass-ridgelm-tidiers.R b/R/mass-ridgelm-tidiers.R
@@ -85,9 +85,10 @@ tidy.ridgelm <- function(x, ...) {
 #' @family ridgelm tidiers
 #' @seealso [glance()], [MASS::select.ridgelm()], [MASS::lm.ridge()]
 glance.ridgelm <- function(x, ...) {
-  tibble(
+  as_glance_tibble(
     kHKB = x$kHKB,
     kLW = x$kLW,
-    lambdaGCV = x$lambda[which.min(x$GCV)]
+    lambdaGCV = x$lambda[which.min(x$GCV)],
+    na_types = "rrr"
   )
 }
diff --git a/R/mclust-tidiers.R b/R/mclust-tidiers.R
@@ -120,17 +120,14 @@ augment.Mclust <- function(x, data = NULL, ...) {
 #'
 #' @export
 glance.Mclust <- function(x, ...) {
-  ret <- with(
-    x,
-    tibble(
-      model = modelName,
-      G,
-      BIC = bic,
-      logLik = loglik,
-      df,
-      hypvol
-    )
+  as_glance_tibble(
+    model = unname(x$modelName),
+    G = unname(x$G),
+    BIC = unname(x$bic),
+    logLik = unname(x$loglik),
+    df = unname(x$df),
+    hypvol = unname(x$hypvol),
+    nobs = stats::nobs(x),
+    na_types = "cirriri"
   )
-  ret$nobs <- stats::nobs(x)
-  ret
 }
diff --git a/R/mgcv-tidiers.R b/R/mgcv-tidiers.R
@@ -90,14 +90,14 @@ tidy.gam <- function(x, parametric = FALSE, conf.int = FALSE,
 #' @family mgcv tidiers
 #' @seealso [glance()], [mgcv::gam()], [glance.Gam()]
 glance.gam <- function(x, ...) {
-  ret <- tibble(
+  as_glance_tibble(
     df = sum(x$edf),
     logLik = as.numeric(stats::logLik(x)),
     AIC = stats::AIC(x),
     BIC = stats::BIC(x),
     deviance = stats::deviance(x),
     df.residual = stats::df.residual(x),
-    nobs = stats::nobs(x)
+    nobs = stats::nobs(x),
+    na_types = "irrrrii"
   )
-  ret
 }