Merge pull request #117 from nutterb/devel

Devel

.Rbuildignore

@@ -9,4 +9,4 @@
 ^xtable_vs_pixiedust.html$
 ^xtable_vs_pixiedust.Rmd$
 ^\inst\save_sprinkles_rda.R$
-^\revdep\*
+^revdep$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: pixiedust
 Title: Tables so Beautifully Fine-Tuned You Will Believe It's Magic
-Version: 0.8.3
+Version: 0.8.4
 Authors@R: c(person("Benjamin", "Nutter", email = "[email protected]", role = c("aut", "cre")),
              person("David", "Kretch", role = c("ctb")))
 Description: The introduction of the 'broom' package has made converting model

NAMESPACE

@@ -79,6 +79,7 @@ export("%<>%")
 export("%>%")
 export(dust)
 export(fixed_header_css)
+export(gaze)
 export(get_dust_part)
 export(get_pixie_count)
 export(increment_pixie_count)

NEWS

@@ -1,3 +1,8 @@
+### 0.8.4 (2018-06-29)
+
+* Added `gaze` function to produce model summaries side-by-side (#80)
+* Small adjustments to work with upcoming version of `broom`.
+
 ### 0.8.3 (2018-03-22)
 
 * Repaired recycling in several sprinkles.  Sprinkles that permit more than 

R/gaze.R

@@ -0,0 +1,174 @@
+#' @name gaze
+#' @title Mimic Stargazer Output to Display Multiple Models
+#' 
+#' @description Tidy multiple models and display coefficients and 
+#'   test statistics in a side-by-side format.
+#'   
+#' @param ... models to be tidied.  Arguments may be named or unnamed.
+#'   For named arguments, the model will be identfied by the argument 
+#'   name; for unnamed arguments, the object name will be the identifier.
+#' @param include_glance \code{logical(1)} Determines if \code{glance} (fit)
+#'   statistics are displayed under the models.
+#' @param glance_vars \code{character}. A vector of statistics returned by
+#'   \code{glance} that are to be displayed for each model. Defaults are 
+#'   subject to change in future versions.
+#' @param digits \code{numeric(1)} The number of digits used for rounding.
+#' 
+#' @details This function is still in development.  Significant stars 
+#'   will be added in a future version. Note that function defaults may 
+#'   be subject to change.
+#' 
+#' @section Functional Requirements:
+#' \enumerate{
+#'   \item Return a data frame object
+#'   \item Cast an error if \code{include_glance} is not \code{logical(1)}
+#'   \item Cast an error if \code{glance_vars} is not a \code{character} 
+#'     vector.
+#'   \item Cast an error if \code{digits} is not \code{"integerish(1)"}.
+#' }
+#'
+#' @examples 
+#' fit1 <- lm(mpg ~ qsec + am + wt + gear + factor(vs), data = mtcars)
+#' fit2 <- lm(mpg ~ am + wt + gear + factor(vs), data = mtcars)
+#' 
+#' gaze(fit1, fit2)
+#' gaze(with_qsec = fit1, 
+#'      without_qsec = fit2)
+#' gaze(fit1, fit2, include_glance = FALSE)
+#' gaze(fit1, fit2, glance_vars = c("AIC", "BIC"))
+#' 
+#' @export
+
+gaze <- function(..., include_glance = TRUE,
+                 glance_vars = c("adj.r.squared", "sigma", "AIC"),
+                 digits = 3){
+
+  coll <- checkmate::makeAssertCollection()
+
+  checkmate::assert_logical(x = include_glance,
+                            len = 1,
+                            add = coll)
+
+  checkmate::assert_character(x = glance_vars,
+                              add = coll)
+
+  checkmate::assert_integerish(x = digits,
+                               len = 1,
+                               add = 1)
+
+  checkmate::reportAssertions(coll)
+
+  fits <- list(...)
+  if (is.null(names(fits))) names(fits) <- character(length(fits))
+
+  # If a fit isn't named, use the object name
+  dots <- match.call(expand.dots = FALSE)$...
+  fit_names <- vapply(dots, deparse, character(1))
+  names(fits)[names(fits) == ""] <- fit_names[names(fits) == ""]
+
+  res <- prep_gaze_tidy(fits, names(fits), digits)
+  if (include_glance){
+    res <- rbind(res, 
+                 prep_gaze_glance(fits, names(fits), glance_vars, digits))
+  }
+  res
+}
+
+
+# UNEXPORTED METHODS ------------------------------------------------
+
+prep_gaze_tidy <- function(fits, fit_names, digits){
+  res <- 
+    mapply(
+      FUN = 
+        function(fit, name)
+        {
+          data.frame(model = name,
+                     broom::tidy(fit),
+                     stringsAsFactors = FALSE)
+        },
+      fit = fits,
+      name = fit_names,
+      SIMPLIFY = FALSE
+    ) 
+
+  res <- dplyr::bind_rows(res)
+
+  res <- res[c("model", "term", "estimate", "statistic")]
+  res[["term"]] <- factor(res[["term"]], 
+                          levels = unique(res[["term"]]))
+
+  res <-
+    stats::reshape(
+      data = res,
+      direction = "long",
+      varying = list(value = c("estimate", "statistic")),
+      v.names = "value",
+      timevar = "variable",
+      times = c("estimate", "statistic")
+    )
+
+  rownames(res) <- NULL
+
+  res[["value"]] <- round(res[["value"]], digits)
+  statistic_row <- res[["variable"]] == "statistic"
+  res[["value"]][statistic_row] <- 
+    sprintf("(%s)",
+            res[["value"]][statistic_row])
+
+  res <- 
+    stats::reshape(
+      data = res[!names(res) %in% "id"],
+      direction = "wide",
+      v.names = "value",
+      idvar = c("term", "variable"),
+      timevar = c("model"))
+
+  res <- res[order(res[["term"]], res[["variable"]]), ]
+  names(res) <- sub("^value\\.", "", names(res))
+  res[!names(res) %in% "variable"]
+}
+
+
+prep_gaze_glance <- function(fits, fit_names, glance_vars, digits){
+  res <- 
+    mapply(
+      FUN = 
+        function(fit, name)
+        {
+          data.frame(model = name,
+                     broom::glance(fit),
+                     stringsAsFactors = FALSE)
+        },
+      fit = fits,
+      name = fit_names,
+      SIMPLIFY = FALSE
+    ) 
+
+  res <- dplyr::bind_rows(res)
+  res <- res[c("model", glance_vars)]
+
+  res <- 
+    stats::reshape(
+      data = res,
+      direction = "long",
+      times = glance_vars,
+      varying = list(value = glance_vars)
+    )
+
+  names(res)[2:3] <- c("term", "value")
+  res[["value"]] <- round(res[["value"]], digits)
+
+
+  res <-
+    stats::reshape(
+      data = res[!names(res) %in% "id"],
+      direction = "wide",
+      v.names = "value",
+      idvar = c("term"),
+      timevar = c("model"))
+
+  names(res) <- sub("^value\\.", "", names(res))
+  rownames(res) <- NULL
+  res
+}

R/glance_foot.R

@@ -89,7 +89,9 @@ glance_foot <- function(fit, col_pairs, total_cols,
 
   checkmate::reportAssertions(coll)
 
-  g <- broom::tidy(t(g[glance_stats])) 
+  g <- data.frame(.rownames = names(g[glance_stats]),
+                  unrowname.x. = unname(unlist(g[glance_stats][1, ])),
+                  stringsAsFactors = FALSE)
   # return(g)
   if (nrow(g) %% col_pairs > 0){
     n_fill <- (col_pairs - nrow(g) %% col_pairs)

cran-comments.md

@@ -1,11 +1,16 @@
 ## Test environments
-* local Linux install (R-3.4.3; #135-Ubuntu SMP Fri Jan 19 11:48:36 UTC 2018)
-* remote Linux install (R-3.4.2; ubuntu 4.8.4-2ubuntu1~14.04.3)
+* local Linux install (R-3.4.4; #135-Ubuntu SMP Fri Jan 19 11:48:36 UTC 2018)
+* remote Linux install (R-3.5.0; Ubuntu 14.04.5 LTS, Travis CI)
+* local Windows install (R 3.5.0)
 * win-builder (release R 3.5.0)
-* win-builder (2018-05-05 r74699)
+* win-builder (2018-06-26 r74934)
 
 ## R CMD check results
-This update corrects one of the tests related to a change in how errors are reported from the `checkmate` package.
+This update adjusts for changes coming with a pending update to the `broom`
+package.
+
+There were no warnings, errors, or notes returned by CHECK on any of the 
+test environments.
 
 
 ## Downstream dependencies

tests/testthat/test-dust.R

@@ -47,7 +47,12 @@ test_that("dust runs when passed a data frame with tidy_df = FALSE",
 
 test_that("dust runs when passed a data frame with tidy_df = TRUE",
 {
-  expect_silent(dust(mtcars, tidy_df = TRUE))
+  # 25 Jun 2018 Changed to expect warning since broom is deprecating data frame
+  #             tidiers
+  if (utils::compareVersion(as.character(packageVersion("broom")), "0.4.4") == 1)
+    expect_warning(dust(mtcars, tidy_df = TRUE))
+  else
+    expect_silent(dust(mtcars, tidy_df = TRUE))
 })
 
 test_that("dust with keep_rownames = TRUE adds rownames to object",

tests/testthat/test-gaze.R

@@ -0,0 +1,69 @@
+context("gaze.R")
+
+fit1 <- lm(mpg ~ qsec + wt + factor(gear),
+           data = mtcars)
+
+fit2 <- lm(mpg ~ disp + qsec + wt + factor(gear),
+           data = mtcars)
+
+# Functional Requirement 1 ------------------------------------------
+
+test_that(
+  "Return a data frame object",
+  {
+    checkmate::expect_data_frame(
+      gaze(fit1, fit2)
+    )
+  }
+)
+
+# Functional Requirement 2 ------------------------------------------
+
+test_that(
+  "Cast an error if include_glance is not logical(1)",
+  {
+    expect_error(
+      gaze(fit1, fit2, include_gaze = "yes")
+    )
+  }
+)
+
+test_that(
+  "Cast an error if include_glance is not logical(1)",
+  {
+    expect_error(
+      gaze(fit1, fit2, include_gaze = c(TRUE, FALSE))
+    )
+  }
+)
+
+# Functional Requirement 3 ------------------------------------------
+
+test_that(
+  "Cast an error if glance_vars is not a character vector.",
+  {
+    expect_error(
+      gaze(fit1, fit2, glance_vars = list(1:3, letters))
+    )
+  }
+)
+
+# Functional Requirement 4 ------------------------------------------
+
+test_that(
+  "Cast an error if digits is not integerish(1)",
+  {
+    expect_error(
+      gaze(fit1, fit2, digits = "two")
+    )
+  }
+)
+
+test_that(
+  "Cast an error if digits is not integerish(1)",
+  {
+    expect_error(
+      gaze(fit1, fit2, digits = c(2, 3))
+    )
+  }
+)

tests/testthat/test-perform_function.R

@@ -8,7 +8,7 @@ test_that("Apply a calculation",
 
   x <- perform_function(x$body)
 
-  expect_equal(x[x$row == 2 & x$col %in% 2:3, "value"],
+  expect_equal(x$value[x$row == 2 & x$col %in% 2:3],
                c("-1.24", "-0.38"))
 })
 
@@ -20,6 +20,6 @@ test_that("Apply a string manipulation",
 
   x <- perform_function(x$body)
 
-  expect_equal(x[x$row %in% 5:6 & x$col == 1, "value"],
+  expect_equal(x$value[x$row %in% 5:6 & x$col == 1],
                c("Gears: 4", "Gears: 5"))
 })