Merge remote-tracking branch 'origin/dev-current'

Author: dcomtois

DESCRIPTION

@@ -34,13 +34,14 @@ Imports:
 Suggests:
   forcats,
   formatR,
+  haven,
   kableExtra,
   knitr,
   magrittr,
   rmarkdown,
   rstudioapi,
   backports
-Depends: R (>= 2.10)
+Depends: R (>= 3.5)
 VignetteBuilder: knitr
 LazyData: true
 License: GPL-2

NAMESPACE

@@ -28,6 +28,7 @@ export(unlabel)
 export(use_custom_lang)
 export(view)
 export(what.is)
+export(zap_attr)
 import(htmltools)
 importFrom(base64enc,base64encode)
 importFrom(checkmate,anyNaN)

NEWS.md

@@ -1,24 +1,24 @@
-# summarytools 1.1.0
-- Optimized metadata extraction
-- Improved support for dplyr::group_by()
-- `llabel()` wrapper added for `label(x, all = TRUE)`
+# summarytools 1.1.0 (2025-02-12)
 - 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
+  + New parameters `fct.to.chr` and `recalculate` for `freq()` tables
   + Parameter `na.rm` deprecated
  - 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
+ - In `freq()`, `ctable()` and `dfSummary()`: 
+   + 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.
+     considered missing by default (using `na.val = "(Missing)"`
+     will yield the same results).
    + Fix for weights not being applied correctly in by-group processing.
+   + **Labelled vectors** ("labelled" / "haven_labelled") are treated like
+     factors in `freq()`, and in `dfSummary()` when all values have a label.
+     Future versions will extend support to `ctable()`. 
  - In `descr()`: 
    + "n" (total number of observations, also displayed in heading) added to
      available statistics.
@@ -28,6 +28,8 @@
      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.
+- `define_keywords()` now uses RStudio's api for dialogs.
+- `llabel()` wrapper added for `label(x, all = TRUE)`
 
 # summarytools 1.0.2 (2022-07-10)
  - Github-only release

R/args_validation.R

@@ -168,9 +168,15 @@ check_args <- function(mc, dotArgs, caller) {
       if (!isTRUE(test_character(pf$na.val, any.missing = FALSE, len = 1))) {
         errmsg %+=% "invalid na.val value; must be character of length 1"
       }
-      if (anyNA(pf$x) ||
-          (is.factor(pf$x) && !pf$na.val %in% levels(pf$x)) ||
-          (is.character(pf$x) && !pf$na.val %in% pf$x)) {
+      
+      # If na.val is specified and one of two conditions is TRUE, we set it
+      # back to its default (NULL) value:
+      # - There are <NA> values in the vector/factor or
+      # - na.val is not in a factor's levels
+      if ((nas_found <- anyNA(pf$x)) ||
+          (is.factor(pf$x) && !pf$na.val %in% levels(pf$x))) {
+        if (nas_found && !isTRUE(st_options("freq.silent")))
+          message("NA values detected - na.val will be ignored")
         pf$na.val <- NULL
       }
     }
@@ -265,13 +271,11 @@ check_args <- function(mc, dotArgs, caller) {
         errmsg %+=% "invalid na.val value; must be character of length 1"
       }
       if (anyNA(pf$x) ||
-          (is.factor(pf$x) && !pf$na.val %in% levels(pf$x)) ||
-          (is.character(pf$x) && !pf$na.val %in% pf$x)) {
+          (is.factor(pf$x) && !pf$na.val %in% levels(pf$x))) {
           pf$na.val.x <- NULL
       }
       if (anyNA(pf$y) ||
-          (is.factor(pf$y) && !pf$na.val %in% levels(pf$y)) ||
-          (is.character(pf$y) && !pf$na.val %in% pf$y)) {
+          (is.factor(pf$y) && !pf$na.val %in% levels(pf$y))) {
         pf$na.val.y <- NULL
       }
     }

R/ctable.R

@@ -261,18 +261,18 @@ ctable <- function(x,
   # Replace values == na.val by NA in factors & char vars
   if (!is.null(na.val.x)) {
     if (is.factor(x)) {
-      x[which(x == na.val.x)] <- NA
-      levels(x)[which(levels(x) == na.val.x)] <- NA
+      x[x == na.val.x] <- NA
+      levels(x)[levels(x) == na.val.x] <- NA
     } else if (is.character(x)) {
-      x[which(x == na.val.x)] <- NA
+      x[x == na.val.x] <- NA
     }
   }
   if (!is.null(na.val.y)) {
     if (is.factor(y)) {
-      y[which(x == na.val.y)] <- NA
-      levels(x)[which(levels(y) == na.val.y)] <- NA
+      y[y == na.val.y] <- NA
+      levels(y)[levels(y) == na.val.y] <- NA
     } else if (is.character(y)) {
-      y[which(y == na.val.y)] <- NA
+      y[y == na.val.y] <- NA
     }
   }
 
@@ -366,9 +366,9 @@ ctable <- function(x,
         colnames(prop_table)[is.na(colnames(prop_table))] <- "<NA>"
       }
     } else {
-      colnames(freq_table)[is.na(colnames(freq_table))] <- "<NA>"
+      colnames(freq_table)[is.na(colnames(freq_table))] <- na.val.y
       if (prop != "n") {
-        colnames(prop_table)[is.na(colnames(prop_table))] <- "<NA>"
+        colnames(prop_table)[is.na(colnames(prop_table))] <- na.val.y
       }
     }
   }

R/define_keywords.R

@@ -217,53 +217,52 @@ define_keywords <- function(..., ask = TRUE, file = NA) {
           dialog_error <- FALSE
           if (isTRUE(resp)) {
             while (!filename_ok) {
-              dir_name <- rstudioapi::selectDirectory(
-                caption = "Choose directory for custom language file"
+              filename <- rstudioapi::selectFile(
+                caption = "Save custom language file",
+                label = "Save",#Enter file name, including extension (.csv)",
+                path = getwd(),
+                filter = "CSV file (*.csv)",
+                existing = FALSE
               )
-              if (is.null(dir_name)) {
-                # dialog cancelled
+              if (is.null(filename)) {
+                # dialog cancelled -- validate cancel action
                 filename <- ""
                 filename_ok <- TRUE
-                message("Custom language file not saved")
               } else {
-                filename <- rstudioapi::showPrompt(
-                  title = "Custom language file",
-                  message = "Enter file name, including extension (.csv)",
-                  default = "custom_lang.csv"
-                )
-                if (is.null(filename)) {
-                  # dialog cancelled -- validate cancel action
-                  filename <- ""
-                  filename_ok <- !rstudioapi::showQuestion(
-                    title = "Custom language file",
-                    message = "Invalid file name.",
+                # make sure csv / txt extension is there
+                if (!grepl("\\.(csv|txt)$", filename)) {
+                  rv <- rstudioapi::showQuestion(
+                    title = "Save custom language file",
+                    message = "Invalid file extension (must be .csv)",
+                    ok = "Retry"
+                  )
+                  if (rv == "cancel") {
+                    filename <- ""
+                    filename_ok <- TRUE
+                  } else {
+                    filename_ok <- FALSE
+                    next
+                  }
+                }
+                filename <- normalizePath(filename, mustWork = FALSE)
+                if (!isTRUE(check_path_for_output(filename, 
+                                                  overwrite = TRUE))) {
+                  rv <- rstudioapi::showQuestion(
+                    title = "Custom language file", 
+                    message = "Invalid file name or location",
                     ok = "Retry",
                     cancel = "Cancel"
                   )
-                } else {
-                  filename <- normalizePath(
-                    paste(dir_name, filename, sep = .Platform$file.sep),
-                    mustWork = FALSE
-                  )
-                  if (!isTRUE(check_path_for_output(filename, 
-                                                    overwrite = TRUE))) {
-                    rv <- rstudioapi::showQuestion(
-                      title = "Custom language file", 
-                      message = "Invalid file name or location",
-                      ok = "Retry",
-                      cancel = "Cancel"
-                    )
-                    if (!rv) {
-                      # cancel confirmed
-                      filename <- ""
-                      filename_ok <- TRUE
-                    }
-                  } else {
-                    # Filename is valid
+                  if (!rv) {
+                    # cancel confirmed
+                    filename <- ""
                     filename_ok <- TRUE
                   }
-                } 
-              }
+                } else {
+                  # Filename is valid
+                  filename_ok <- TRUE
+                }
+              } 
             } # while
           } # save yes
         }

R/descr.R

@@ -352,9 +352,12 @@ descr.default <- function(x,
       output <- as.data.frame(t(results[ ,-1]))
       colnames(output) <- results$stat
     } else {
-      output <- xx %>% 
-        summarise_all(.funs = summar_funs, na.rm = na.rm) %>%
-        as.data.frame
+      # Suppress warnings for groups having 0 valid values
+      suppressWarnings({
+        output <- xx %>% 
+          summarise_all(.funs = summar_funs, na.rm = na.rm) %>%
+          as.data.frame
+      })
       rownames(output) <- parse_info$var_name %||% var_names
     }
 
@@ -371,12 +374,14 @@ descr.default <- function(x,
     }
 
     if ("pct.valid" %in% stats) {
-      output$pct.valid <- output$n.valid *100 / nrow(xx)
+      output$pct.valid <- output$n.valid * 100 / nrow(xx)
     }
 
     # Apply corrections where n.valid = 0
     zerows <- which(output$n.valid == 0)
-    output[zerows, setdiff(stats, "n.valid")] <- NA
+    if (length(zerows)) {
+      warning("no non-missing arguments to numerical functions")
+    }
 
   } else {
 
@@ -464,28 +469,33 @@ descr.default <- function(x,
       }
 
       # Calculate and insert stats into output dataframe
-      output[i, ] <-
-        c(ifelse("mean" %in% stats, variable.mean, NA),
-          ifelse("sd"   %in% stats, variable.sd, NA),
-          ifelse("min"  %in% stats, min(variable, na.rm = na.rm), NA),
-          ifelse("med"  %in% stats, weightedMedian(variable, weights_tmp, 
-                                                   refine = TRUE, 
-                                                   na.rm = na.rm), NA),
-          ifelse("max" %in% stats, max(variable, na.rm = na.rm), NA),
-          ifelse("mad" %in% stats, weightedMad(variable, weights_tmp, 
-                                                refine = TRUE, 
-                                                na.rm = na.rm), NA),
-          ifelse("cv"        %in% stats, variable.sd/variable.mean, NA),
-          ifelse("n.valid"   %in% stats, n_valid, NA),
-          ifelse("n"         %in% stats, n, NA),
-          ifelse("pct.valid" %in% stats, p_valid * 100, NA))
+      # (suppress repeated warnings when no non-missing data)
+      suppressWarnings({
+        output[i, ] <-
+          c(ifelse("mean" %in% stats, variable.mean, NA),
+            ifelse("sd"   %in% stats, variable.sd, NA),
+            ifelse("min"  %in% stats, min(variable, na.rm = na.rm), NA),
+            ifelse("med"  %in% stats, weightedMedian(variable, weights_tmp, 
+                                                     refine = TRUE, 
+                                                     na.rm = na.rm), NA),
+            ifelse("max" %in% stats, max(variable, na.rm = na.rm), NA),
+            ifelse("mad" %in% stats, weightedMad(variable, weights_tmp, 
+                                                  refine = TRUE, 
+                                                  na.rm = na.rm), NA),
+            ifelse("cv"        %in% stats, variable.sd/variable.mean, NA),
+            ifelse("n.valid"   %in% stats, n_valid, NA),
+            ifelse("n"         %in% stats, n, NA),
+            ifelse("pct.valid" %in% stats, p_valid * 100, NA))
+      })
     }
 
     rownames(output) <- var_names
 
     # Apply corrections where n.valid = 0
     zerows <- which(output$n.valid == 0)
-    output[zerows, setdiff(stats, "n.valid")] <- NA
+    if (length(zerows)) {
+      warning("no non-missing arguments to numerical functions")
+    }
   }
 
   # Prepare output data -------------------------------------------------------
@@ -594,8 +604,11 @@ descr.default <- function(x,
 
   attr(output, "lang") <- st_options("lang")
 
-  if (!is.null(ignored))
-    attr(output, "ignored") <- ignored
+  if (!is.null(ignored)) {
+    if (length(ignored <- setdiff(ignored, data_info$by_var))) {
+      attr(output, "ignored") <- ignored
+    }
+  }
 
   return(output)
 }