Addressing CRAN comments.

CRAN-SUBMISSION

@@ -0,0 +1,3 @@
+Version: 0.9.1
+Date: 2024-01-17 17:42:28 UTC
+SHA: 56b947b2a9acf6e74f6eb69782700359ed799568

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: surveytable
 Title: Formatted Survey Estimates
-Version: 0.9.1
+Version: 0.9.2
 Authors@R: 
     person(given = "Alex"
         , family = "Strashny"
@@ -9,7 +9,12 @@ Authors@R:
         , comment = c(ORCID = "0000-0002-6408-7745")
         )
 Description: Short and understandable commands that generate tabulated, 
-    formatted, and rounded survey estimates.
+    formatted, and rounded survey estimates. Mostly a wrapper for the 
+    'survey' package (Lumley (2004) <doi:10.18637/jss.v009.i08> 
+    <https://CRAN.R-project.org/package=survey>) that implements the National 
+    Center for Health Statistics (NCHS) presentation standards 
+    (Parker et al. (2017) <https://www.cdc.gov/nchs/data/series/sr_02/sr02_175.pdf>,
+    Parker et al. (2023) <doi:10.15620/cdc:124368>).
 Date/Publication: 2023
 License: Apache License (>= 2)
 Encoding: UTF-8

NAMESPACE

@@ -1,12 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(print,surveytable_list)
+S3method(print,surveytable_table)
 export(set_count_1k)
 export(set_count_int)
 export(set_output)
 export(set_survey)
 export(show_options)
 export(show_output)
-export(show_survey)
 export(survey_subset)
 export(svyciprop_adjusted)
 export(tab)
@@ -41,5 +42,6 @@ importFrom(stats,coef)
 importFrom(stats,confint)
 importFrom(stats,pt)
 importFrom(stats,qt)
+importFrom(utils,capture.output)
 importFrom(utils,tail)
 importFrom(utils,write.table)

NEWS.md

@@ -1,3 +1,7 @@
+# surveytable 0.9.2
+
+* Addressed CRAN comments.
+
 # surveytable 0.9.1
 
 * Initial CRAN submission.

R/print.surveytable_table.R

@@ -0,0 +1,62 @@
+#' Print surveytable tables
+#'
+#' @param x an object of class `surveytable_table` or `surveytable_list`.
+#' @param ... ignored
+#'
+#' @return `x` invisibly.
+#' @export
+#'
+#' @examples
+#' set_survey(namcs2019sv)
+#' table1 = tab("AGER")
+#' print(table1)
+#' table_many = tab("MDDO", "SPECCAT", "MSA")
+#' print(table_many)
+print.surveytable_table = function(x, ...) {
+  df1 = x
+  class(df1) = "data.frame"
+
+  hh = df1 %>% hux %>% set_all_borders
+
+  if (!is.null(txt <- attr(df1, "title"))) {
+    if (isTRUE(nchar(txt) > getOption("width"))) {
+      txt = paste(strwrap(txt), collapse = "\n")
+    }
+    caption(hh) = txt
+  }
+
+  if (!is.null(nc <- attr(df1, "num"))) {
+    number_format(hh)[-1,nc] = fmt_pretty()
+  }
+  if (!is.null(txt <- attr(df1, "footer"))) {
+    hh %<>% add_footnote(txt)
+  }
+
+  # See inside guess_knitr_output_format
+  not_screen = (requireNamespace("knitr", quietly = TRUE)
+                && requireNamespace("rmarkdown", quietly = TRUE)
+                && guess_knitr_output_format() != "")
+
+  if (not_screen) {
+    hh %>% print_html
+  } else {
+    gow = getOption("width")
+    op_ = options(width = 10)
+    on.exit(options(op_))
+    hh %>% print_screen(colnames = FALSE, min_width = 0, max_width = max(gow * 1.5, 150, na.rm=TRUE))
+    cat("\n")
+  }
+
+  invisible(x)
+}
+
+#' @rdname print.surveytable_table
+#' @export
+print.surveytable_list = function(x, ...) {
+  if (length(x) > 0) {
+    for (ii in 1:length(x)) {
+      print.surveytable_table(x[[ii]])
+    }
+  }
+  invisible(x)
+}

R/set_count.R

@@ -10,7 +10,7 @@
 #' @export
 #'
 #' @examples
-#' set_survey("namcs2019sv")
+#' set_survey(namcs2019sv)
 #' set_count_int()
 #' total()
 #'

R/set_output.R

@@ -3,27 +3,23 @@
 #' `show_output()` shows the current defaults.
 #'
 #' @param csv     name of a CSV file or "" to turn off CSV output
-#' @param screen  print to the screen?
 #' @param max_levels a categorical variable can have at most this many levels. Used to avoid printing huge tables.
 #'
 #' @return (Nothing.)
 #' @family options
 #' @export
 #'
 #' @examples
-#' \dontrun{
-#' set_output(csv = "out.csv")
-#' show_output()
-#' }
+#' tmp_file = tempfile(fileext = ".csv")
+#' suppressMessages( set_output(csv = tmp_file) )
 #' set_output(csv = "") # Turn off CSV output
-set_output = function(csv = NULL, screen = NULL, max_levels = NULL) {
+set_output = function(csv = NULL, max_levels = NULL) {
   # If making changes, update .onLoad()
   if (!is.null(csv)) {
     assert_that(is.string(csv)
       , msg = "CSV file name must be a character string.")
     if (nzchar(csv)) {
       message(paste0("* Sending CSV output to: ", csv))
-      message(paste0("* Current folder is: ", getwd(), " See ?setwd to change folder."))
       if (file.exists(csv)) {
         message("* (File already exists. Output will be appended to the end of the file.)")
       }
@@ -34,16 +30,6 @@ set_output = function(csv = NULL, screen = NULL, max_levels = NULL) {
     options(surveytable.csv = csv)
   }
 
-  if (!is.null(screen)) {
-    assert_that(is.flag(screen), noNA(screen))
-    if (screen) {
-      message("* Sending output to the screen.")
-    } else {
-      message("* Output is not being sent to the screen.")
-    }
-    options(surveytable.screen = screen)
-  }
-
   if (!is.null(max_levels)) {
     assert_that(is.count(max_levels))
     message(paste0("* Setting maximum number of levels to: ", max_levels))
@@ -61,7 +47,6 @@ show_output = function() {
               , msg = "CSV file name must be a character string.")
   if (nzchar(csv)) {
     message(paste0("* Sending CSV output to: ", csv))
-    message(paste0("* Current folder is: ", getwd(), " See ?setwd to change folder."))
     if (file.exists(csv)) {
       message("* (File already exists. Output will be appended to the end of the file.)")
     }
@@ -70,14 +55,6 @@ show_output = function() {
     message("* CSV output has been turned off.")
   }
 
-  screen = getOption("surveytable.screen")
-  assert_that(is.flag(screen), noNA(screen))
-  if (screen) {
-    message("* Sending output to the screen.")
-  } else {
-    message("* Output is not being sent to the screen.")
-  }
-
   max_levels = getOption("surveytable.max_levels")
   assert_that(is.count(max_levels))
   message(paste0("* Maximum number of levels is: ", max_levels))

R/set_survey.R

@@ -3,45 +3,47 @@
 #' You need to specify a survey before the other functions, such as [tab()],
 #' will work.
 #'
-#' `show_survey()` shows the survey that you've specified.
-#'
 #' Optionally, the survey can have an attribute called `label`, which is the
 #' long name of the survey.
 #'
 #' Optionally, each variable in the survey can have an attribute called `label`,
 #' which is the variable's long name.
 #'
-#' @param survey_name the name of a survey object (`survey.design` or `svyrep.design`), in quotation marks
+#' @param design a survey object (`survey.design` or `svyrep.design`)
 #'
-#' @return (Nothing.)
-#' @family options
+#' @return Object with info about the survey.
 #' @export
 #'
 #' @examples
-#' set_survey("namcs2019sv")
-#' show_survey()
-set_survey = function(survey_name = "") {
+#' set_survey(namcs2019sv)
+set_survey = function(design) {
   # In case there's an error below and we don't set a new survey,
   # don't retain the previous survey either.
-  options(surveytable.survey = "")
+  env$survey = NULL
+  options(surveytable.survey_label = "")
+
+  if (is.string(design)) {
+    label_default = design
+    design %<>% get0
+  } else {
+    label_default = as.character(substitute(design))
+  }
 
-  assert_that(is.string(survey_name), nzchar(survey_name)
-              , msg = "survey_name must be a character string.")
-  design = get0(survey_name)
-  assert_that(!is.null(design)
-      , msg = paste0(survey_name, " does not exist. Did you forget to load it?"))
   assert_that(inherits(design, c("survey.design", "svyrep.design"))
-      , msg = paste0(survey_name, " must be a survey.design or svyrep.design. Is "
+      , msg = paste0(label_default, " must be a survey.design or svyrep.design. Is "
       , class(design)[1] ))
 
-  options(surveytable.survey = survey_name)
+  if(is.null( attr(design, "label") )) {
+    attr(design, "label") = label_default
+  }
+  assert_that(is.string(attr(design, "label")), nzchar(attr(design, "label"))
+              , msg = "Survey must have a label.")
 
   if(inherits(design, "svyrep.design") && !isTRUE(attr(design, "prob_set"))) {
     assert_that(!("prob" %in% names(design))
       , msg = "prob already exists")
     design$prob = 1 / design$pweights
     attr(design, "prob_set") = TRUE
-    assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir"))
   }
 
   # zero weights cause issues with tab():
@@ -50,63 +52,35 @@ set_survey = function(survey_name = "") {
   #
   # prob == 1 / weight ?
   if (any(design$prob == Inf)) {
+    message(paste0("* ", label_default, ": retaining positive weights only."))
     dl = attr(design, "label")
-    if(is.null(dl)) dl = survey_name
-    assert_that(is.string(dl), nzchar(dl))
     dl %<>% paste("(positive weights only)")
-
     design %<>% survey_subset(design$prob < Inf, label = dl)
-
-    message(paste0("* ", survey_name, ": retaining positive weights only."))
-    assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir"))
   }
   assert_that( all(design$prob > 0), all(design$prob < Inf) )
 
-  dl = attr(design, "label")
-  if(is.null(dl)) dl = survey_name
-  assert_that(is.string(dl), nzchar(dl))
-  options(surveytable.survey_label = dl)
-
-  out = list(`Survey name` = dl
-             , `Number of variables` = ncol(design$variables)
-             , `Number of observations` = nrow(design$variables))
-  class(out) = "simple.list"
-  print(out)
-  print(design)
-
+  options(surveytable.survey_label = attr(design, "label"))
+  env$survey = design
   message("* To adjust how counts are rounded, see ?set_count_int")
-  invisible(NULL)
-}
-
-#' @rdname set_survey
-#' @export
-show_survey = function() {
-  dl = getOption("surveytable.survey_label")
 
-  design = .load_survey()
-  out = list(`Survey name` = dl
+  out = list()
+  out = list(`Survey name` = getOption("surveytable.survey_label")
              , `Number of variables` = ncol(design$variables)
-             , `Number of observations` = nrow(design$variables))
+             , `Number of observations` = nrow(design$variables)
+             , `Info` = design %>% capture.output
+             )
   class(out) = "simple.list"
-  print(out)
-  print(design)
-
-  message("* To adjust how counts are rounded, see ?set_count_int")
-  invisible(NULL)
+  out
 }
 
 
 .load_survey = function() {
-  survey_name = getOption("surveytable.survey")
-  assert_that(is.string(survey_name), nzchar(survey_name)
-    , msg = "You need to specify a survey before the other functions will work. See ?set_survey")
-  design = get0(survey_name)
+  design = env$survey
   assert_that(!is.null(design)
-      , msg = paste0(survey_name, " does not exist. Did you forget to load it? See ?set_survey"))
+      , msg = "Survey has not been specified. See ?set_survey")
   assert_that(inherits(design, c("survey.design", "svyrep.design"))
-      , msg = paste0(survey_name, " must be a survey.design or svyrep.design. Is "
-      , class(design)[1] ))
-
+              , msg = paste0("Must be a survey.design or svyrep.design. Is "
+                             , class(design)[1] ))
   assert_that( all(design$prob > 0), all(design$prob < Inf) )
   design
 }

R/survey_subset.R

@@ -8,11 +8,9 @@
 #' @export
 #'
 #' @examples
-#' \dontrun{
-#' children = survey_subset(namcs2019sv, AGE < 18, "Children")
-#' set_survey("children")
+#' children = survey_subset(namcs2019sv, AGE < 18, "Children < 18")
+#' set_survey(children)
 #' tab("AGER")
-#' }
 survey_subset = function(design, subset, label) {
   assert_that(inherits(design, c("survey.design", "svyrep.design"))
     , msg = paste0("Must be a survey.design or svyrep.design. Is "

R/surveytable.R

@@ -3,7 +3,7 @@
 #' @import survey
 #' @importFrom huxtable hux set_all_borders caption<- number_format<- number_format fmt_pretty add_footnote guess_knitr_output_format print_html print_screen
 #' @importFrom stats as.formula confint qt coef pt
-#' @importFrom utils write.table tail
+#' @importFrom utils write.table tail capture.output
 #' @keywords internal
 "_PACKAGE"
 

R/svyciprop_adjusted.R

@@ -19,7 +19,7 @@
 #' @export
 #'
 #' @examples
-#' set_survey("namcs2019sv")
+#' set_survey(namcs2019sv)
 #' options(surveytable.adjust_svyciprop = TRUE)
 #' tab("AGER")
 #' options(surveytable.adjust_svyciprop = FALSE)