Merge dev-current (1.1.0) into master branch

Merge branch 'dev-current'

# Conflicts:
#	DESCRIPTION
#	NEWS.md
#	R/parse_args.R
#	R/sysdata.rda
#	README.Rmd
#	README.md

.Rbuildignore

@@ -10,10 +10,11 @@
 ^TODO.txt$
 ^README.md$
 ^README.Rmd$
-^tests$
+^tests*$
 ^COPYING$
 ^inst/WORDLIST$
 vignettes/*.R$
 vignettes/*.html$
 ^doc$
 ^misc$
+^tests$

.gitignore

@@ -13,3 +13,5 @@ inst/doc
 inst/includes/win_includes
 inst/includes/linux_includes
 /Meta/
+/doc/
+/lua/

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: summarytools
 Type: Package
 Title: Tools to Quickly and Neatly Summarize Data
-Version: 1.0.2
+Version: 1.1.0
 Authors@R: person("Dominic", "Comtois", email = "[email protected]", 
   role = c("aut", "cre"))
 Author: Dominic Comtois [aut, cre]
@@ -38,12 +38,13 @@ Suggests:
   knitr,
   magrittr,
   rmarkdown,
-  rstudioapi
+  rstudioapi,
+  backports
 Depends: R (>= 2.10)
 VignetteBuilder: knitr
 LazyData: true
 License: GPL-2
 URL: https://github.com/dcomtois/summarytools
 BugReports: https://github.com/dcomtois/summarytools/issues
 Encoding: UTF-8
-RoxygenNote: 7.1.2
+RoxygenNote: 7.3.2

NAMESPACE

@@ -1,10 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(descr,default)
+S3method(descr,grouped_df)
 S3method(print,list)
 S3method(print,stby)
 S3method(print,summarytools)
-S3method(stby,data.frame)
-S3method(stby,default)
+S3method(tb,by)
+S3method(tb,default)
+S3method(tb,list)
+S3method(tb,stby)
+S3method(tb,summarytools)
 export("label<-")
 export(cleartmp)
 export(ctable)
@@ -13,6 +18,7 @@ export(descr)
 export(dfSummary)
 export(freq)
 export(label)
+export(labls)
 export(st_css)
 export(st_options)
 export(stby)
@@ -24,6 +30,7 @@ export(view)
 export(what.is)
 import(htmltools)
 importFrom(base64enc,base64encode)
+importFrom(checkmate,anyNaN)
 importFrom(checkmate,check_file_exists)
 importFrom(checkmate,check_path_for_output)
 importFrom(checkmate,test_character)
@@ -35,15 +42,15 @@ importFrom(checkmate,test_number)
 importFrom(checkmate,test_path_for_output)
 importFrom(checkmate,test_string)
 importFrom(dplyr,"%>%")
-importFrom(dplyr,as_tibble)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,bind_rows)
 importFrom(dplyr,group_keys)
 importFrom(dplyr,group_vars)
+importFrom(dplyr,n)
 importFrom(dplyr,n_distinct)
 importFrom(dplyr,select)
 importFrom(dplyr,starts_with)
-importFrom(dplyr,summarize_all)
+importFrom(dplyr,summarise_all)
 importFrom(grDevices,dev.list)
 importFrom(grDevices,dev.off)
 importFrom(grDevices,nclass.Sturges)

NEWS.md

@@ -1,5 +1,36 @@
-# summarytools 1.0.2 (2022-09-20)
- - This version contains many bug fixes and improvements
+# summarytools 1.1.0
+- Optimized metadata extraction
+- Improved support for dplyr::group_by()
+- `labls()` wrapper added for `label(x, all = TRUE)`
+- In `stby()`
+  + New parameter `useNA` adds a group for missing values in
+    grouping variable(s); set to `FALSE` to avoid the message displayed
+    when `NA`s are detected.
+- In `tb()`
+  + Fix for broken proportions in freq tables
+  + New parameters `fct.to.chr` and `recalculate` for freq tables
+ - In `dfSummary()`: 
+   + New parameter `class` allows switching off class reporting in *Variable*
+     column.
+ - In `freq()`: 
+   + New parameter `na.val` allows specifying a value (factor level) that
+     is to be considered `NA`. In turn, the value "(Missing)" is no longer
+     considered missing by default; using `na.val = "(Missing)"`
+     will yield the same results.
+   + Fix for weights not being applied correctly in by-group processing.
+ - In `descr()`: 
+   + "n" (total number of observations, also displayed in heading) added to
+     available statistics.
+   + `stats` parameter more flexible: keywords (*all*, *fivenum*, and 
+     *common*) can be used in conjunction with statistics, to add or
+     remove them. `stats= c("common", "n", "-pct.valid")` adds *N* to, and
+     excludes *Pct. Valid* from, *common* statistics.
+   + Fix for *N* in header showing 1st group's size rather than global size.
+   + Fix for weights not being applied correctly in by-group processing.
+
+# summarytools 1.0.2 (2022-07-10)
+ - Github-only release
+ - Various fixes and minor improvements
 
 # summarytools 1.0.1 (2022-05-19)
  - This version only includes minors fixes requested by CRAN.

R/args_validation.R

@@ -4,24 +4,13 @@
 #' @importFrom dplyr n_distinct
 #' @importFrom stats na.omit
 #' @keywords internal
-check_args <- function(mc, dotArgs) {
+check_args <- function(mc, dotArgs, caller) {
 
-  caller      <- sub(".+::","",as.character(sys.call(-1))[1])
   pf          <- parent.frame()
   errmsg      <- character()
-  caller_orig <- caller
 
-  if (caller == "FUN") {
+  if (mc[[1]] == "FUN" || mc$x == "dd[x, , drop = FALSE]") {
     pf$flag_by <- TRUE
-    # When stby() was called, deduce caller from formals
-    if ("cumul" %in% names(pf))
-      caller <- "freq"
-    else if ("transpose" %in% names(pf))
-      caller <- "descr"
-    else if ("chisq" %in% names(pf))
-      caller <- "ctable"
-    else if ("graph.col" %in% names(pf))
-      caller <- "dfSummary"
   } else {
     pf$flag_by <- FALSE
   }
@@ -114,6 +103,32 @@ check_args <- function(mc, dotArgs) {
       errmsg %+=% "'cumul' must be either TRUE or FALSE"
     }
 
+    if ("na.val" %in% names(mc) && !is.null(pf$na.val)) {
+        varname <- pf$varname %||% "x"
+      if (length(pf$na.val) > 1) {
+        errmsg %+=% "'na.val' can only contain one value"
+      }
+      if (!is.factor(pf$x)) {
+        if (isFALSE(st_options("freq.silent")))
+          message("'na.val' only applies to factors & will be ignored for ",
+                  varname)
+      }
+      if (!isTRUE(test_character(pf$na.val, any.missing = FALSE))) {
+        errmsg %+=% "'na.val' must be character"
+      }
+      if (is.factor(pf$x)) {
+        if (!pf$na.val %in% levels(pf$x)) {
+          if (isFALSE(st_options("freq.silent")))
+            message(paste0("'", pf$na.val, "' is not a level of ",
+                           varname, " and will be ignored"))
+          pf$na.val <- NULL
+        } else if (anyNA(pf$x)) {
+          errmsg %+=% paste(varname, "contains NA values; 'na.val' is only",
+                            "valid in the absence of actual NA values")
+        }
+      }
+    }
+
     if ("order" %in% names(mc)) {
       order <- switch(tolower(substr(sub("[+-]", "", pf$order), 1, 1)),
                       d = "default",
@@ -187,7 +202,7 @@ check_args <- function(mc, dotArgs) {
     if (!identical(pf$weights, NA)) {
       if (is.null(pf$weights)) {
         errmsg %+=% "weights vector not found"
-      } else if (caller_orig != "FUN" && 
+      } else if (isFALSE(pf$flag_by) && 
                  length(pf$weights) != nrow(as.data.frame(pf$x))) {
         errmsg %+=% "weights vector must have same length as 'x'"      
       }
@@ -288,18 +303,16 @@ check_args <- function(mc, dotArgs) {
         }
       } else {
         # order has length > 1 -- all elements must correspond to column names
-        if (length(ind <- which(!pf$order %in% colnames(pf$x.df))) > 0) {
+        if (length(ind <- which(!pf$order %in% colnames(pf$xx))) > 0) {
           errmsg %+=% paste("Following ordering element(s) not recognized:", 
                             paste(pf$order[ind], sep = ", "),
                             collapse = " ")
         }
       }
     }
 
-    if (!identical(pf$weights, NA)) {
-      if (is.null(pf$weights)) {
-        errmsg %+=% "weights vector not found"
-      } else if (caller_orig != "FUN" && (length(pf$weights) != nrow(pf$x.df))) {
+    if (!is.null(pf$weights)) {
+      if (isFALSE(pf$flag_by) && (length(pf$weights) != nrow(pf$xx))) {
         errmsg %+=% "weights vector must have same length as 'x'"      
       }
     }
@@ -449,14 +462,6 @@ check_args_print <- function(mc) {
      errmsg %+=% "'file' path is not valid - check that directory exists"
   }
 
-  # # Change method to browser when file name was (most likely) provided by user
-  # if (grepl("\\.html$", pf$file, ignore.case = TRUE, perl = TRUE) &&
-  #     !grepl(pattern = tempdir(), x = pf$file, fixed = TRUE) && 
-  #     pf$method == "pander") {
-  #   pf$method <- "browser"
-  #   message("Switching method to 'browser'")
-  # }
-  # 
   if (pf$method == "pander" && !is.na(pf$table.classes)) {
     errmsg %+=% "'table.classes' option does not apply to method 'pander'"
   }
@@ -613,22 +618,23 @@ check_args_st_options <- function(mc) {
     errmsg %+=% "'ctable.totals' must be either TRUE or FALSE"
   }
 
-  if ("descr_stats" %in% names(mc)) {
-    valid_stats <- c("mean", "sd", "min", "q1", "med", "q3","max", "mad", 
-                     "iqr", "cv", "skewness", "se.skewness", "kurtosis", 
-                     "n.valid", "pct.valid")
+  if ("descr.stats" %in% names(mc)) {
 
-    if (length(pf$descr_stats) == 1 && 
-        !(pf$descr_stats %in% c("fivevnum", "common")) &&
-        !(pf$descr_stats %in% valid_stats)) {
+    # Check for invalid items
+    stats <- tolower(pf$descr.stats)
+    invalid_stats <- setdiff(
+      stats, c(.st_env$descr.stats.valid$no_wgts,
+               paste0("-", .st_env$descr.stats.valid$no_wgts),
+               "all", "common", "fivenum"))
+
+    if (length(invalid_stats) > 0) {
       errmsg %+=%
-        paste("'descr_stats' value", dQuote(pf$descr_stats), "not recognized;",
-              "allowed values are: ", 
-              paste('"fivenum", "common", or a combination of :',
-                    paste0(dQuote(valid_stats), sep = ", ")))
+        paste("descr.stats: values", 
+              paste(dQuote(invalid_stats), collapse = ", "),
+              "not recognized; see ?descr")
     }
   }
-  
+
   if ("descr.transpose" %in% names(mc) &&
       !isTRUE(test_logical(pf$descr.transpose, len = 1, any.missing = FALSE))) {
     errmsg %+=% "'descr.transpose' must be either TRUE or FALSE"

R/ctable.R

@@ -126,11 +126,11 @@ ctable <- function(x,
                    ...) {
 
   # Check for group_by()
-  if (any(grepl("group_by(", deparse(sys.calls()[[1]]), fixed = TRUE))) {
-    stop("ctable() doesn't support group_by(); use stby() instead")
+  if (inherits(x, "grouped_df")) {
+     stop("ctable() does not support group_by(); use stby() instead")
   }
 
-  # Support for by()
+  # Adjustment for by() / syby()
   if (length(dim(x)) == 2) {
     x_tmp <- x[[1]]
     y <- x[[2]]
@@ -166,7 +166,7 @@ ctable <- function(x,
     }
   }
 
-  errmsg <- c(errmsg, check_args(match.call(), list(...)))
+  errmsg <- c(errmsg, check_args(match.call(), list(...), "ctable"))
 
   if (length(errmsg) > 0) {
     stop(paste(errmsg, collapse = "\n  "))
@@ -192,9 +192,8 @@ ctable <- function(x,
   # Get x & y metadata from parsing function
   if (isTRUE(flag_by)) {
     parse_info_x <- try(
-      parse_args(sys.calls(), sys.frames(), match.call(), 
-                 var = c("x", "y"), silent = "dnn" %in% names(match.call()),
-                 var_label = FALSE, caller = "ctable"),
+      parse_call(mc = match.call(), var = c("x", "y"), var_label = FALSE, 
+                 caller = "ctable"),
       silent = TRUE)
 
     if (inherits(parse_info_x, "try-error")) {
@@ -209,19 +208,17 @@ ctable <- function(x,
     }
   } else {
     parse_info_x <- try(
-      parse_args(sys.calls(), sys.frames(), match.call(), 
-                 var = "x", silent = "dnn" %in% names(match.call()),
-                 var_label = FALSE, caller = "ctable"),
+      parse_call(mc = match.call(), var = "x", var_label = FALSE,
+                 caller = "ctable"),
       silent = TRUE)
 
     if (inherits(parse_info_x, "try-error")) {
       parse_info_x <- list()
     }
 
     parse_info_y <- try(
-      parse_args(sys.calls(), sys.frames(), match.call(), 
-                 var = "y", silent = "dnn" %in% names(match.call()),
-                 var_label = FALSE, caller = "ctable"),
+      parse_call(mc = match.call(), var = "y", var_label = FALSE,
+                 caller = "ctable"),
       silent = TRUE)
 
     if (inherits(parse_info_y, "try-error")) {
@@ -346,7 +343,7 @@ ctable <- function(x,
 
   if (isTRUE(chisq)) {
     tmp.chisq <- chisq.test(freq_table_min)
-    tmp.chisq <- c(Chi.squared = round(tmp.chisq$statistic[[1]], 4), 
+    tmp.chisq <- c(Chi.squared = round(tmp.chisq$statistic[[1]], 2), 
                    tmp.chisq$parameter, 
                    p.value = round(tmp.chisq$p.value, 4))
     attr(output, "chisq") <- tmp.chisq
@@ -436,8 +433,7 @@ ctable <- function(x,
 
   # Prepare metadata to be stored as the data_info attribute
   data_info <-
-    list(Data.frame          = ifelse(exists("df_name", inherits = FALSE), 
-                                      df_name, NA),
+    list(Data.frame          = dfn,
          Data.frame.label    = ifelse(exists("df_label", inherits = FALSE),
                                       df_label, NA),
          Row.variable        = x_name,
@@ -459,6 +455,8 @@ ctable <- function(x,
                                                  replacement = "",
                                                  x = weights_string,
                                                  fixed = TRUE))),
+         by_var           = if ("by_group" %in% names(parse_info_x))
+                                   parse_info_x$by_var else NA,
          Group            = ifelse("by_group" %in% names(parse_info_x),
                                    parse_info_x$by_group, NA),
          by_first         = ifelse("by_group" %in% names(parse_info_x), 
@@ -477,9 +475,20 @@ ctable <- function(x,
                                        headings       = headings,
                                        display.labels = display.labels)
 
-  attr(output, "user_fmt") <- list(... = ...)
-
-  attr(output, "lang") <- st_options("lang")
+  # Keep ... arguments that could be relevant for pander of format
+  user_fmt <- list()
+  dotArgs <- list(...)
+  for (i in seq_along(dotArgs)) {
+    if (class(dotArgs[[i]]) %in% 
+        c("character", "numeric", "integer", "logical") &&
+        length(names(dotArgs[1])) == length(dotArgs[[i]]))
+      user_fmt <- append(user_fmt, dotArgs[i])
+  }
 
+  if (length(user_fmt) > 0)
+    attr(output, "user_fmt") <- user_fmt
+
+  attr(output, "lang") <- st_options("lang")
+
   return(output)
 }