cleaner handling of grouped calling ungrouped plotting function

NAMESPACE

@@ -96,6 +96,7 @@ export(parcoord_style_np)
 export(plot_bg)
 export(pp_check)
 export(ppc_bars)
+export(ppc_bars_data)
 export(ppc_bars_grouped)
 export(ppc_boxplot)
 export(ppc_data)
@@ -164,6 +165,7 @@ import(stats)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,arrange)
 importFrom(dplyr,count)
+importFrom(dplyr,everything)
 importFrom(dplyr,group_by)
 importFrom(dplyr,inner_join)
 importFrom(dplyr,left_join)
@@ -174,6 +176,7 @@ importFrom(dplyr,pull)
 importFrom(dplyr,rename)
 importFrom(dplyr,select)
 importFrom(dplyr,summarise)
+importFrom(dplyr,summarise_at)
 importFrom(dplyr,top_n)
 importFrom(dplyr,ungroup)
 importFrom(dplyr,vars)

R/helpers-ppc.R

@@ -1,18 +1,27 @@
 #' Modify a call to a '_grouped' function to the same one without '_grouped'
-#' and prevent a future call to `check_ignored_args()` from warning about
-#' the `group` argument.
 #'
 #' @param call The original call (from `match.call()`).
-#' @return The new unevaluated call.
+#' @return The new unevaluated call, with additional argument
+#'   `called_from_internal=TRUE` which can be detected by the function to be
+#'   called.
 #' @noRd
 ungroup_call <- function(call) {
   fn <- gsub("_grouped", "", rlang::call_name(call))
   call[[1]] <- as.name(fn)
-  call$dont_check <- "group"
+  call$called_from_internal <- TRUE
   call$... <- NULL
   call
 }
 
+#' Check if the `...` to a function were supplied by it's `_grouped` version
+#'
+#' @param dots The `...` arguments already in a list (`list(...)`).
+#' @return `TRUE` or `FALSE`
+#' @noRd
+from_grouped <- function(dots) {
+  isTRUE(dots[["called_from_internal"]]) && !is.null(dots[["group"]])
+}
+
 
 # input validation and type checking ----------------------------------------
 

R/helpers-shared.R

@@ -30,10 +30,10 @@ suggested_package <- function(pkg, min_version = NULL) {
 #' @param ... The `...` arguments from the calling function.
 #' @param ok_args A character vector of argument names to ignore.
 #' @return Nothing, but a warning may be thrown.
+#' @noRd
 check_ignored_arguments <- function(..., ok_args = character()) {
   dots <- list(...)
   nms <- names(dots)
-  ok_args <- c(ok_args, "dont_check")
   if (length(dots)) {
     unrecognized <- if (!length(ok_args)) nms else setdiff(nms, ok_args)
     if (length(unrecognized)) {

R/ppc-distributions.R

@@ -295,11 +295,16 @@ ppc_freqpoly <-
            freq = TRUE,
            size = 0.5,
            alpha = 1) {
-    # don't warn about 'group' arg if called internally by ppc_freqpoly_grouped()
+
     dots <- list(...)
-    check_ignored_arguments(..., ok_args = dots[["dont_check"]])
+    if (!from_grouped(dots)) {
+      check_ignored_arguments(...)
+      group <- NULL
+    } else {
+      group <- dots[["group"]]
+    }
 
-    ppc_data(y, yrep, group = dots[["group"]]) %>%
+    ppc_data(y, yrep, group = group) %>%
       ggplot(mapping = set_hist_aes(
         freq,
         fill = ~ is_y_label,
@@ -322,8 +327,7 @@ ppc_freqpoly <-
       yaxis_title(FALSE) +
       yaxis_ticks(FALSE) +
       xaxis_title(FALSE) +
-      facet_text(FALSE) +
-      facet_bg(FALSE)
+      facet_text(FALSE)
   }
 
 #' @rdname PPC-distributions

R/ppc-intervals.R

@@ -121,16 +121,20 @@ ppc_intervals <-
            size = 1,
            fatten = 2.5) {
 
-    # don't warn about 'group' arg if called internally by ppc_intervals_grouped()
     dots <- list(...)
-    check_ignored_arguments(..., ok_args = dots[["dont_check"]])
+    if (!from_grouped(dots)) {
+      check_ignored_arguments(...)
+      group <- NULL
+    } else {
+      group <- dots[["group"]]
+    }
 
     data <-
       ppc_intervals_data(
         y = y,
         yrep = yrep,
         x = x,
-        group = dots[["group"]],
+        group = group,
         prob = prob,
         prob_outer = prob_outer
       )
@@ -206,16 +210,20 @@ ppc_ribbon <-
            alpha = 0.33,
            size = 0.25) {
 
-    # don't warn about 'group' arg if called internally by ppc_ribbon_grouped()
     dots <- list(...)
-    check_ignored_arguments(..., ok_args = dots[["dont_check"]])
+    if (!from_grouped(dots)) {
+      check_ignored_arguments(...)
+      group <- NULL
+    } else {
+      group <- dots[["group"]]
+    }
 
     data <-
       ppc_intervals_data(
         y = y,
         yrep = yrep,
         x = x,
-        group = dots[["group"]],
+        group = group,
         prob = prob,
         prob_outer = prob_outer
       )

R/ppd-distributions.R

@@ -190,11 +190,17 @@ ppd_freqpoly <-
            freq = TRUE,
            size = 0.5,
            alpha = 1) {
-    # don't warn about 'group' arg if called internally by ppd_freqpoly_grouped()
+
     dots <- list(...)
-    check_ignored_arguments(..., ok_args = dots[["dont_check"]])
+    if (!from_grouped(dots)) {
+      check_ignored_arguments(...)
+      group <- NULL
+    } else {
+      group <- dots[["group"]]
+    }
+
     ypred %>%
-      ppd_data(group = dots[["group"]]) %>%
+      ppd_data(group = group) %>%
       ggplot(mapping = set_hist_aes(
         freq,
         color = "ypred",
@@ -291,7 +297,7 @@ ppd_boxplot <-
 #' @param y User's `y` argument (if applicable), already validated.
 #' @param group User's `group` argument, already validated.
 #' @return A molten data frame of predictions, possible including `y`.
-#'
+#' @importFrom dplyr left_join select everything
 .ppd_data <- function(predictions, y = NULL, group = NULL) {
   if (!is.null(y)) {
     data <- melt_and_stack(y, predictions)
@@ -303,7 +309,7 @@ ppd_boxplot <-
     group_indices <- tibble::tibble(group, y_id = seq_along(group))
     data <- data %>%
       left_join(group_indices, by = "y_id") %>%
-      select(.data$group, dplyr::everything())
+      select(.data$group, everything())
   }
   data
 }
@@ -317,6 +323,7 @@ ppd_boxplot <-
 #'   with different defaults.
 #' @param ... All arguments other than `geom` and `position` to pass to
 #'   `stat_density()`. The defaults will be the same as for `stat_density()`.
+#' @return Object returned by `stat_density()`.
 #' @noRd
 overlay_ppd_densities <-
   function(...,

R/ppd-intervals.R

@@ -64,14 +64,18 @@ ppd_intervals <-
            size = 1,
            fatten = 2.5) {
 
-    # don't warn about 'group' arg if called internally by ppd_intervals_grouped()
     dots <- list(...)
-    check_ignored_arguments(..., ok_args = dots[["dont_check"]])
+    if (!from_grouped(dots)) {
+      check_ignored_arguments(...)
+      group <- NULL
+    } else {
+      group <- dots[["group"]]
+    }
 
     ypred %>%
       ppd_intervals_data(
         x = x,
-        group = dots[["group"]],
+        group = group,
         prob = prob,
         prob_outer = prob_outer
       ) %>%
@@ -133,14 +137,18 @@ ppd_ribbon <-
            alpha = 0.33,
            size = 0.25) {
 
-    # don't warn about 'group' arg if called internally by ppd_ribbon_grouped()
     dots <- list(...)
-    check_ignored_arguments(..., ok_args = dots[["dont_check"]])
+    if (!from_grouped(dots)) {
+      check_ignored_arguments(...)
+      group <- NULL
+    } else {
+      group <- dots[["group"]]
+    }
 
     ypred %>%
       ppd_intervals_data(
         x = x,
-        group = dots[["group"]],
+        group = group,
         prob = prob,
         prob_outer = prob_outer
       ) %>%
@@ -279,6 +287,7 @@ ppd_ribbon_data <- ppd_intervals_data
 #' Aesthetic mapping for interval and ribbon plots
 #'
 #' Always sets at least `x`, `ymin`, `ymax`.
+#'
 #' @param needs_y Whether to include `y = ~m` in the call to `aes_()`. Needed
 #'   for `geom_pointrange()`.
 #' @param ... Aguments to pass to `aes_()` other than `x`,`y`,`ymin`,`ymax`.
@@ -311,11 +320,13 @@ intervals_outer_aes <- function(needs_y = FALSE, ...) {
 
 #' Create the facet layer for grouped interval and ribbon plots
 #' @param facet_args User's `facet_args` argument.
+#' @param scales_default String to use for `scales` argument to `facet_wrap()`
+#'   if not specified by user. Defaults to `"free"`, unlike `facet_wrap()`.
 #' @return Object returned by `facet_wrap()`.
 #' @noRd
-intervals_group_facets <- function(facet_args) {
+intervals_group_facets <- function(facet_args, scales_default = "free") {
   facet_args[["facets"]] <- "group"
-  facet_args[["scales"]] <- facet_args[["scales"]] %||% "free"
+  facet_args[["scales"]] <- facet_args[["scales"]] %||% scales_default
   do.call("facet_wrap", facet_args)
 }