Merge pull request #148 from atorus-research/gh_issue_111

Replace ellipsis unpacking with list to `rlang::list2()`

NAMESPACE

@@ -194,7 +194,6 @@ importFrom(rlang,as_name)
 importFrom(rlang,call_args)
 importFrom(rlang,call_modify)
 importFrom(rlang,call_name)
-importFrom(rlang,call_standardise)
 importFrom(rlang,caller_env)
 importFrom(rlang,current_env)
 importFrom(rlang,enexpr)
@@ -220,6 +219,7 @@ importFrom(rlang,is_logical)
 importFrom(rlang,is_named)
 importFrom(rlang,is_quosure)
 importFrom(rlang,is_quosures)
+importFrom(rlang,list2)
 importFrom(rlang,quo)
 importFrom(rlang,quo_get_expr)
 importFrom(rlang,quo_is_call)

R/apply_formats.R

@@ -38,7 +38,7 @@ apply_formats <- function(format_string, ..., empty = c(.overall = "")) {
          call.=FALSE)
   }
 
-  pmap_chr(list(...), function(...) apply_fmts(...), fmt=format)
+  pmap_chr(list2(...), function(...) apply_fmts(...), fmt=format)
 }
 
 #' Application of individual format string
@@ -53,7 +53,7 @@ apply_formats <- function(format_string, ..., empty = c(.overall = "")) {
 #' @return An individually formatted string
 #' @noRd
 apply_fmts <- function(..., fmt) {
-  nums <- list(...)
+  nums <- list2(...)
   repl <- vector('list', length(fmt$settings))
   for (i in seq_along(fmt$settings)) {
     repl[[i]] <- num_fmt(nums[[i]], i, fmt=fmt)

R/count_bindings.R

@@ -457,7 +457,7 @@ set_result_order_var <- function(e, result_order_var) {
 #'   build()
 set_missing_count <- function(e, fmt = NULL, sort_value = NULL, denom_ignore = FALSE, ...) {
 
-  missings <- list(...)
+  missings <- list2(...)
   assert_that(length(missings) > 0, msg = "No missing values were specified.")
 
   if(!is.null(fmt)) assert_inherits_class(fmt, "f_str")
@@ -644,7 +644,7 @@ set_denoms_by.count_layer <- function(e, ...) {
 #'  build()
 #'
 keep_levels <- function(e, ...) {
-  dots <- list(...)
+  dots <- list2(...)
   assert_that(all(map_lgl(dots, is.character)),
               msg = "must pass character values to `keep_levels`")
 

R/desc.R

@@ -225,7 +225,7 @@ get_summaries <- function(e = caller_env()) {
 #' @noRd
 construct_desc_string <- function(..., .fmt_str=NULL) {
   # Unpack names into current namespace for ease
-  list2env(list(...), envir=environment())
+  list2env(list2(...), envir=environment())
 
   # Get the current format to be applied
   fmt <- .fmt_str[[row_label]]

R/format.R

@@ -360,7 +360,7 @@ count_f_str_check <- function(...) {
   }
 
   # Grab the named parameters
-  params <- list(...)
+  params <- list2(...)
 
   # Currently supported format names
   valid_names <- c("n_counts", "riskdiff")

R/layering.R

@@ -100,10 +100,10 @@ add_layers <- function(parent, ...) {
   # Parent exists
   assert_that(!missing(parent), msg = "`parent` parameter must be provided")
   # all objects are Tplyr layers
-  map(list(...), assert_is_layer)
+  map(list2(...), assert_is_layer)
 
   # Insert the layer into the parent object
-  parent$layers <- append(parent$layers, list(...))
+  parent$layers <- append(parent$layers, list2(...))
   parent
 }
 

R/meta-builders.R

@@ -47,7 +47,7 @@ build_desc_meta <- function(target, table_where, layer_where, treat_grps, ...) {
 
   # Don't want any of the named parameters here
   variables <- variables[which(names(variables)=='')]
-  values <- list(...)
+  values <- list2(...)
 
   # Get rid of text provided by variables
   inds <- which(map_lgl(unname(variables), ~ quo_class(.) == "name"))
@@ -85,7 +85,7 @@ build_count_meta <- function(layer, table_where, layer_where, treat_grps, summar
 
   # Don't want any of the named parameters here
   variables <- variables[which(names(variables)=='')]
-  values <- list(...)
+  values <- list2(...)
 
   # Get rid of text provided by variables
   inds <- which(map_lgl(unname(variables), ~ quo_class(.) == "name"))
@@ -220,7 +220,7 @@ build_shift_meta <- function(layer, table_where, layer_where, treat_grps, summar
 
   # Don't want any of the named parameters here
   variables <- variables[which(names(variables)=='')]
-  values <- list(...)
+  values <- list2(...)
 
   # Get rid of text provided by variables
   inds <- which(map_lgl(unname(variables), ~ quo_class(.) == "name"))

R/pop_data.R

@@ -81,13 +81,13 @@ build_header_n <- function(table) {
 
 add_treat_grps <- function(table, ...) {
 
-  assert_that(is_named(list(...)), msg="Treatment group arguments must have names")
+  assert_that(is_named(list2(...)), msg="Treatment group arguments must have names")
 
   assert_that(inherits(table, "tplyr_table"),
                    msg = "Treatment groups can only be added to `tplyr_table` objects")
 
   # Check parameters
-  fargs <- list(...)
+  fargs <- list2(...)
 
     # Bind the specified treatment groups to the table
   env_bind(table, treat_grps = append(treat_grps(table), fargs))

R/riskdiff.R

@@ -115,7 +115,7 @@
 add_risk_diff <- function(layer, ..., args=list(), distinct=TRUE) {
 
   # grab the ellipsis args into a list
-  comps <- list(...)
+  comps <- list2(...)
 
   # Must be character, must have 2 elements
   assert_that(all(map_lgl(comps, is.character)), all(map_lgl(comps, ~ length(.x) == 2)),
@@ -242,7 +242,7 @@ riskdiff <- function(diff_group, n_comp, n_ref, total_comp, total_ref, args=list
     high = NA
   )
 
-  out <- append(list(...), out)
+  out <- append(list2(...), out)
   # Rename
 
   # Totals in the 2 way must be positive
@@ -265,10 +265,10 @@ riskdiff <- function(diff_group, n_comp, n_ref, total_comp, total_ref, args=list
 
 construct_riskdiff_string <- function(..., .fmt_str=NULL) {
   # Unpack names into current namespace for ease
-  list2env(list(...), envir=environment())
+  list2env(list2(...), envir=environment())
 
   # Return empty when necessary
-  if (any(is.na(list(...)))) {
+  if (any(is.na(list2(...)))) {
     return(.fmt_str$empty)
   }
 

R/set_format_strings.R

@@ -130,7 +130,7 @@ set_format_strings.desc_layer <- function(e, ..., cap=getOption('tplyr.precision
 
 
   # Pick off the ellipsis
-  format_strings <- list(...)
+  format_strings <- list2(...)
 
 
   # Get the list of variable names that need to be transposed
@@ -187,7 +187,7 @@ set_format_strings.count_layer <- function(e, ...) {
 
 set_format_strings.shift_layer <- function(e, ...) {
 
-  dots <- list(...)
+  dots <- list2(...)
 
   assert_that(all(dots$vars %in% c("n", "pct")),
               msg = "formats in shift layers can only be n")

R/sort.R

@@ -686,7 +686,7 @@ get_data_order_byvarn <- function(formatted_data, by_varn_df, by_var, by_column_
 add_data_order_nested <- function(group_data, final_col, numeric_data, ...) {
 
   # Pull out dots
-  list2env(list(...), envir = environment())
+  list2env(list2(...), envir = environment())
 
   # Here are the names of the formatted data row labels. We usually only work with the last
   row_label_vec <- vars_select(names(group_data), starts_with("row_label"))

R/table_bindings.R

@@ -319,7 +319,7 @@ get_desc_layer_formats <- function(obj) {
 #' @rdname table_format_defaults
 set_desc_layer_formats <- function(obj, ...) {
   # Bind the formats into the table
-  env_bind(obj, desc_layer_formats = list(...))
+  env_bind(obj, desc_layer_formats = list2(...))
   obj
 }
 
@@ -337,8 +337,8 @@ get_count_layer_formats <- function(obj) {
 set_count_layer_formats <- function(obj, ...) {
   # Bind the formats into the table
 
-  if (length(list(...)) > 0) params <- count_f_str_check(...)
-  else params <- list(...)
+  if (length(list2(...)) > 0) params <- count_f_str_check(...)
+  else params <- list2(...)
 
   env_bind(obj, count_layer_formats = params)
   obj
@@ -355,6 +355,6 @@ get_shift_layer_formats <- function(obj) {
 #' @rdname table_format_defaults
 set_shift_layer_formats <- function(obj, ...) {
   # Bind the formats into the table
-  env_bind(obj, shift_layer_formats = list(...))
+  env_bind(obj, shift_layer_formats = list2(...))
   obj
 }

R/zzz.R

@@ -1,5 +1,5 @@
 #' @importFrom rlang env enquo enquos caller_env abort inform is_quosure quo_get_expr quo_is_null env_get env_bind env_has quo_is_missing quos enexprs
-#' @importFrom rlang call_modify call_standardise call_name call_args is_call current_env quo_name trace_back is_function
+#' @importFrom rlang call_modify call_name call_args is_call current_env quo_name trace_back is_function list2
 #' @importFrom rlang expr exprs enexprs enexpr is_named env_parent env_label is_logical is_empty is_quosures quo_is_symbol sym syms := as_name
 #' @importFrom rlang quos quo env_names env_bind_active as_label eval_tidy warn quo_is_call
 #' @importFrom stringr str_split str_extract_all regex str_detect str_replace_all str_replace str_locate_all fixed str_count str_trim str_wrap

tests/testthat/test-format.R

@@ -256,3 +256,25 @@ test_that("Format string setting and autoprecision are detected appropriately",
   expect_equal(fmt26$settings, s26)
 
 })
+
+test_that("Ellipsis unpacking of external variables functions effectively - (#111)", {
+
+  # Define a list of f_str's
+  num_formats <- list(
+    "N"         = f_str("xx", n),
+    "Mean (SD)" = f_str("xx.x (xx.xx)", mean, sd),
+    "Median"    = f_str("xx.x", median),
+    "Q1"        = f_str("xx", q1),
+    "Q3"        = f_str("xx", q3),
+    "Min"       = f_str("xx", min),
+    "Max"       = f_str("xx", max)
+  )
+
+  # `add_layers()` example, create the tplyr_table
+  t <- tplyr_table(iris, Species)
+
+  l <- group_desc(t, Petal.Length) %>%
+    set_format_strings(!!!num_formats)
+
+  expect_identical(num_formats, l$format_strings)
+})