diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION new file mode 100644 index 0000000..a043a2e --- /dev/null +++ b/CRAN-SUBMISSION @@ -0,0 +1,3 @@ +Version: 0.9.1 +Date: 2024-01-17 17:42:28 UTC +SHA: 56b947b2a9acf6e74f6eb69782700359ed799568 diff --git a/DESCRIPTION b/DESCRIPTION index 89cb89c..c9eec16 100644 --- a/DESCRIPTION +++ b/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) + ) that implements the National + Center for Health Statistics (NCHS) presentation standards + (Parker et al. (2017) , + Parker et al. (2023) ). Date/Publication: 2023 License: Apache License (>= 2) Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index 2136bda..7c3272a 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index 8132466..4da213f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,7 @@ +# surveytable 0.9.2 + +* Addressed CRAN comments. + # surveytable 0.9.1 * Initial CRAN submission. diff --git a/R/print.surveytable_table.R b/R/print.surveytable_table.R new file mode 100644 index 0000000..11b540e --- /dev/null +++ b/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) +} diff --git a/R/set_count.R b/R/set_count.R index af23a77..72fcbac 100644 --- a/R/set_count.R +++ b/R/set_count.R @@ -10,7 +10,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' set_count_int() #' total() #' diff --git a/R/set_output.R b/R/set_output.R index 36be90a..b737d38 100644 --- a/R/set_output.R +++ b/R/set_output.R @@ -3,7 +3,6 @@ #' `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.) @@ -11,19 +10,16 @@ #' @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)) diff --git a/R/set_survey.R b/R/set_survey.R index bb36984..58547a4 100644 --- a/R/set_survey.R +++ b/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 } diff --git a/R/survey_subset.R b/R/survey_subset.R index a2a65cf..286d400 100644 --- a/R/survey_subset.R +++ b/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 " diff --git a/R/surveytable.R b/R/surveytable.R index be60b0a..f77d754 100644 --- a/R/surveytable.R +++ b/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" diff --git a/R/svyciprop_adjusted.R b/R/svyciprop_adjusted.R index c496c2e..4de88e1 100644 --- a/R/svyciprop_adjusted.R +++ b/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) diff --git a/R/tab.R b/R/tab.R index 636dec5..206ffec 100644 --- a/R/tab.R +++ b/R/tab.R @@ -23,7 +23,6 @@ #' @param alpha significance level for tests #' @param drop_na drop missing values (`NA`)? Categorical variables only. #' @param max_levels a categorical variable can have at most this many levels. Used to avoid printing huge tables. -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return A list of `data.frame` tables or a single `data.frame` table. @@ -31,7 +30,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' tab("AGER") #' tab("MDDO", "SPECCAT", "MSA") #' @@ -40,15 +39,10 @@ #' #' # Hypothesis testing with categorical variables #' tab("AGER", test = TRUE) -#' -#' # Integrate the output into other programming tasks -#' my_table = tab("AGER", screen = FALSE) -#' my_table = within(my_table, {RSE = `SE (000)` / `Number (000)`}) tab = function(... , test = FALSE, alpha = 0.05 , drop_na = getOption("surveytable.drop_na") , max_levels = getOption("surveytable.max_levels") - , screen = getOption("surveytable.screen") , csv = getOption("surveytable.csv") ) { ret = list() @@ -69,19 +63,17 @@ tab = function(... , vr = vr , drop_na = drop_na , max_levels = max_levels - , screen = screen , csv = csv) if (test) { ret[[paste0(vr, " - test")]] = .test_factor(design = design , vr = vr , drop_na = drop_na , alpha = alpha - , screen = screen, csv = csv) + , csv = csv) } } else if (is.numeric(design$variables[,vr])) { ret[[vr]] = .tab_numeric(design = design , vr = vr - , screen = screen , csv = csv) } else { warning(vr, ": must be logical, factor, or numeric. Is " @@ -90,11 +82,11 @@ tab = function(... } } - if (length(ret) == 1L) return(invisible(ret[[1]])) - invisible(ret) + class(ret) = "surveytable_list" + if (length(ret) == 1L) ret[[1]] else ret } -.tab_factor = function(design, vr, drop_na, max_levels, screen, csv) { +.tab_factor = function(design, vr, drop_na, max_levels, csv) { nm = names(design$variables) assert_that(vr %in% nm, msg = paste("Variable", vr, "not in the data.")) @@ -132,7 +124,7 @@ tab = function(... } attr(mp, "num") = 2:5 attr(mp, "title") = .getvarname(design, vr) - return(.write_out(mp, screen = screen, csv = csv)) + return(.write_out(mp, csv = csv)) } else if (nlv > max_levels) { # don't use assert_that # if multiple tables are being produced, want to go to the next table @@ -242,7 +234,7 @@ tab = function(... attr(mp, "num") = 2:5 attr(mp, "title") = .getvarname(design, vr) mp %<>% .add_flags( c(pro$has.flag, pco$has.flag, ppo$has.flag) ) - .write_out(mp, screen = screen, csv = csv) + .write_out(mp, csv = csv) } .add_flags = function(df1, has.flag) { diff --git a/R/tab_cross.R b/R/tab_cross.R index f7a0b3d..a517708 100644 --- a/R/tab_cross.R +++ b/R/tab_cross.R @@ -2,7 +2,6 @@ #' @export tab_cross = function(vr, vrby , max_levels = getOption("surveytable.max_levels") - , screen = getOption("surveytable.screen") , csv = getOption("surveytable.csv") ) { design = .load_survey() @@ -17,10 +16,9 @@ tab_cross = function(vr, vrby ret = .tab_factor(design = design, vr = newvr , drop_na = FALSE , max_levels = max_levels - , screen = screen , csv = csv) design$variables[,newvr] = NULL - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) - invisible(ret) + env$survey = design + ret } diff --git a/R/tab_rate.R b/R/tab_rate.R index 092e0cc..2da43fd 100644 --- a/R/tab_rate.R +++ b/R/tab_rate.R @@ -10,7 +10,6 @@ #' @param per calculate rate per this many items in the population #' @param drop_na drop missing values (`NA`)? #' @param max_levels a categorical variable can have at most this many levels. Used to avoid printing huge tables. -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return A list of `data.frame` tables or a single `data.frame` table. @@ -18,7 +17,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' # pop is a data frame #' tab_rate("MSA", uspop2019$MSA) #' @@ -28,7 +27,6 @@ tab_rate = function(vr, pop , per = getOption("surveytable.rate_per") , drop_na = getOption("surveytable.drop_na") , max_levels = getOption("surveytable.max_levels") - , screen = getOption("surveytable.screen") , csv = getOption("surveytable.csv") ) { @@ -64,7 +62,6 @@ tab_rate = function(vr, pop , vr = vr , drop_na = drop_na , max_levels = max_levels - , screen = FALSE , csv = "") if (pop_df) { @@ -97,5 +94,5 @@ tab_rate = function(vr, pop attr(m1, "num") = 2:5 attr(m1, "footer") = attr(tfo, "footer") - .write_out(m1, screen = screen, csv = csv) + .write_out(m1, csv = csv) } diff --git a/R/tab_subset.R b/R/tab_subset.R index e55c42f..e6ab5eb 100644 --- a/R/tab_subset.R +++ b/R/tab_subset.R @@ -23,7 +23,6 @@ #' @param alpha significance level for tests #' @param drop_na drop missing values (`NA`)? Categorical variables only. #' @param max_levels a categorical variable can have at most this many levels. Used to avoid printing huge tables. -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return @@ -35,7 +34,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' #' # For each SEX, tabulate AGER #' tab_subset("AGER", "SEX") @@ -43,17 +42,16 @@ #' # Same counts as tab_subset(), but different percentages. #' tab_cross("AGER", "SEX") #' -#' # Hypothesis testing -#' tab_subset("AGER", "SEX", test = TRUE) -#' #' # Numeric variables #' tab_subset("NUMMED", "AGER") +#' +#' # Hypothesis testing +#' tab_subset("NUMMED", "AGER", test = TRUE) tab_subset = function(vr, vrby, lvls = c() , test = FALSE, alpha = 0.05 # , test_pairs = "depends" , drop_na = getOption("surveytable.drop_na") , max_levels = getOption("surveytable.max_levels") - , screen = getOption("surveytable.screen") , csv = getOption("surveytable.csv") ) { assert_that(test %in% c(TRUE, FALSE) @@ -109,7 +107,6 @@ tab_subset = function(vr, vrby, lvls = c() , vr = vr , drop_na = drop_na , max_levels = max_levels - , screen = screen , csv = csv) } @@ -132,7 +129,7 @@ tab_subset = function(vr, vrby, lvls = c() ret[[ test_name ]] = .test_table(rT = rT , test_name = test_name, test_title = test_title, alpha = alpha - , screen = screen, csv = csv) + , csv = csv) ### for (ii in lvl0 ) { @@ -149,7 +146,7 @@ tab_subset = function(vr, vrby, lvls = c() , vr = vr , drop_na = drop_na , alpha = alpha - , screen = screen, csv = csv) + , csv = csv) } for (jj in levels(design$variables[,vr]) ) { @@ -166,7 +163,7 @@ tab_subset = function(vr, vrby, lvls = c() , vr = vrby , drop_na = drop_na , alpha = alpha - , screen = screen, csv = csv) + , csv = csv) } } } else if (is.numeric(design$variables[,vr])) { @@ -182,7 +179,7 @@ tab_subset = function(vr, vrby, lvls = c() attr(rA, "title") = paste0(.getvarname(design, vr) , " (for different levels of " , .getvarname(design, vrby), ")") - ret[["Means"]] = .write_out(rA, screen = screen, csv = csv) + ret[["Means"]] = .write_out(rA, csv = csv) if (test) { frm = as.formula(paste0("`", vr, "` ~ `", vrby, "`")) @@ -205,7 +202,7 @@ tab_subset = function(vr, vrby, lvls = c() ret[[ test_name ]] = .test_table(rT = rT , test_name = test_name, test_title = test_title, alpha = alpha - , screen = screen, csv = csv) + , csv = csv) # } # if (test && do_pairs) { nlvl = length(lvl0) @@ -234,13 +231,13 @@ tab_subset = function(vr, vrby, lvls = c() , .getvarname(design, vr) , " across all possible pairs of ", .getvarname(design, vrby)) ret[[ test_name ]] = .test_table(rT = rT - , test_name = test_name, test_title = test_title, alpha = alpha - , screen = screen, csv = csv) + , test_name = test_name, test_title = test_title + , alpha = alpha, csv = csv) } } else { stop("How did we get here?") } - if (length(ret) == 1L) return(invisible(ret[[1]])) - invisible(ret) + class(ret) = "surveytable_list" + if (length(ret) == 1L) ret[[1]] else ret } diff --git a/R/tab_subset_rate.R b/R/tab_subset_rate.R index 05418f7..17ba217 100644 --- a/R/tab_subset_rate.R +++ b/R/tab_subset_rate.R @@ -12,7 +12,6 @@ #' @param per calculate rate per this many items in the population #' @param drop_na drop missing values (`NA`)? #' @param max_levels a categorical variable can have at most this many levels. Used to avoid printing huge tables. -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return A list of `data.frame` tables or a single `data.frame` table. @@ -20,7 +19,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' tab_subset_rate("AGER", "SEX", uspop2019$`AGER x SEX`) tab_subset_rate = function(vr, vrby , pop @@ -28,7 +27,6 @@ tab_subset_rate = function(vr, vrby , per = getOption("surveytable.rate_per") , drop_na = getOption("surveytable.drop_na") , max_levels = getOption("surveytable.max_levels") - , screen = getOption("surveytable.screen") , csv = getOption("surveytable.csv") ) { design = .load_survey() @@ -83,7 +81,6 @@ tab_subset_rate = function(vr, vrby , vr = vr , drop_na = drop_na , max_levels = max_levels - , screen = FALSE , csv = "") pop1 = pop[which(pop$Subset == ii),] m1 = merge(tfo, pop1, by = "Level", all.x = TRUE, all.y = FALSE, sort = FALSE) @@ -109,9 +106,9 @@ tab_subset_rate = function(vr, vrby attr(m1, "num") = 2:5 attr(m1, "footer") = attr(tfo, "footer") - ret[[ii]] = .write_out(m1, screen = screen, csv = csv) + ret[[ii]] = .write_out(m1, csv = csv) } - if (length(ret) == 1L) return(invisible(ret[[1]])) - invisible(ret) + class(ret) = "surveytable_list" + if (length(ret) == 1L) ret[[1]] else ret } diff --git a/R/total.R b/R/total.R index 9a819c4..7ef0e7c 100644 --- a/R/total.R +++ b/R/total.R @@ -1,6 +1,5 @@ #' Total count #' -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return `data.frame` @@ -8,18 +7,17 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' total() -total = function(screen = getOption("surveytable.screen") - , csv = getOption("surveytable.csv") ) { +total = function(csv = getOption("surveytable.csv") ) { design = .load_survey() - mp = .total(design) - assert_that(ncol(mp) %in% c(4L, 5L)) - attr(mp, "num") = 1:4 - attr(mp, "title") = "Total" - .write_out(mp, screen = screen, csv = csv) -} + m1 = .total(design) + assert_that(ncol(m1) %in% c(4L, 5L)) + attr(m1, "num") = 1:4 + attr(m1, "title") = "Total" + .write_out(m1, csv = csv) +} .total = function(design) { design$variables$Total = 1 diff --git a/R/total_rate.R b/R/total_rate.R index 76f2245..d99918a 100644 --- a/R/total_rate.R +++ b/R/total_rate.R @@ -2,7 +2,6 @@ #' #' @param pop population #' @param per calculate rate per this many items in the population -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return `data.frame` @@ -10,11 +9,10 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' total_rate(uspop2019$total) total_rate = function(pop , per = getOption("surveytable.rate_per") - , screen = getOption("surveytable.screen") , csv = getOption("surveytable.csv") ) { assert_that(pop > 0, per >= 1) if ( !(per %in% 10^c(2:5)) ) { @@ -45,5 +43,5 @@ total_rate = function(pop attr(m1, "num") = 1:4 attr(m1, "footer") = attr(mp, "footer") - .write_out(m1, screen = screen, csv = csv) + .write_out(m1, csv = csv) } diff --git a/R/var_any.R b/R/var_any.R index 1fbb054..1a3dda8 100644 --- a/R/var_any.R +++ b/R/var_any.R @@ -11,7 +11,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' var_any("Imaging services" #' , c("ANYIMAGE", "BONEDENS", "CATSCAN", "ECHOCARD", "OTHULTRA" #' , "MAMMO", "MRI", "XRAY", "OTHIMAGE")) @@ -30,5 +30,5 @@ var_any = function(newvr, vrs) { , msg = paste0(vr, ": must be logical. Is ", class(design$variables[,vr])[1] )) design$variables[,newvr] = design$variables[,newvr] | design$variables[,vr] } - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) + env$survey = design } diff --git a/R/var_case.R b/R/var_case.R index 79e9a31..ee2f8ce 100644 --- a/R/var_case.R +++ b/R/var_case.R @@ -9,7 +9,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' var_case("Preventive care visits", "MAJOR", "Preventive care") #' tab("Preventive care visits") #' var_case("Surgery-related visits" @@ -33,5 +33,5 @@ var_case = function(newvr, vr, cases) { idx = which(design$variables[,vr] %in% cases) design$variables[idx, newvr] = TRUE - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) + env$survey = design } diff --git a/R/var_collapse.R b/R/var_collapse.R index 4883c5b..80b7786 100644 --- a/R/var_collapse.R +++ b/R/var_collapse.R @@ -11,7 +11,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' tab("PRIMCARE") #' var_collapse("PRIMCARE", "Unknown if PCP", c("Blank", "Unknown")) #' tab("PRIMCARE") @@ -27,5 +27,5 @@ var_collapse = function(vr, newlevel, oldlevels) { idx = which(levels(design$variables[,vr]) %in% oldlevels) levels(design$variables[,vr])[idx] = newlevel - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) + env$survey = design } diff --git a/R/var_copy.R b/R/var_copy.R index 20e0565..1576320 100644 --- a/R/var_copy.R +++ b/R/var_copy.R @@ -11,7 +11,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' var_copy("Age group", "AGER") #' var_collapse("Age group", "65+", c("65-74 years", "75 years and over")) #' var_collapse("Age group", "25-64", c("25-44 years", "45-64 years")) @@ -27,5 +27,5 @@ var_copy = function(newvr, vr) { design$variables[,newvr] = design$variables[,vr] # attr(design$variables[,newvr], "label") = .getvarname(design, vr) attr(design$variables[,newvr], "label") = NULL - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) + env$survey = design } diff --git a/R/var_cross.R b/R/var_cross.R index 43878b6..0615aa6 100644 --- a/R/var_cross.R +++ b/R/var_cross.R @@ -12,7 +12,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' var_cross("Age x Sex", "AGER", "SEX") #' tab("Age x Sex") var_cross = function(newvr, vr, vrby) { @@ -45,5 +45,5 @@ var_cross = function(newvr, vr, vrby) { "(", .getvarname(design, vr), ") x (" , .getvarname(design, vrby), ")") - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) + env$survey = design } diff --git a/R/var_cut.R b/R/var_cut.R index e0464de..f551b3c 100644 --- a/R/var_cut.R +++ b/R/var_cut.R @@ -12,7 +12,7 @@ #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' var_cut("Age group" #' , "AGE" #' , c(-Inf, 0, 4, 14, 64, Inf) @@ -31,5 +31,5 @@ var_cut = function(newvr, vr, breaks, labels) { design$variables[,newvr] = cut(x = design$variables[,vr] , breaks = breaks, labels = labels) # attr(design$variables[,newvr], "label") = paste(.getvarname(design, vr), "(categorized)") - assign(getOption("surveytable.survey"), design, envir = getOption("surveytable.survey_envir")) + env$survey = design } diff --git a/R/var_list.R b/R/var_list.R index 082a6a9..34c4ff1 100644 --- a/R/var_list.R +++ b/R/var_list.R @@ -2,19 +2,17 @@ #' #' @param sw starting characters in variable name (case insensitive) #' @param all print all variables? -#' @param screen print to the screen? #' @param csv name of a CSV file #' #' @return `data.frame` #' @export #' #' @examples -#' set_survey("namcs2019sv") +#' set_survey(namcs2019sv) #' var_list("age") -var_list = function(sw = "", all=FALSE - , screen = getOption("surveytable.screen") - , csv = getOption("surveytable.csv") -) { +var_list = function(sw = "" + , all = FALSE + , csv = getOption("surveytable.csv") ) { design = .load_survey() assert_that(nzchar(sw) | all , msg = "Either set the 'sw' argument to a non-empty string, or set all=TRUE") @@ -47,7 +45,8 @@ var_list = function(sw = "", all=FALSE } else { paste0("Variables beginning with '", sw, "'") } - .write_out(ret, screen = screen, csv = csv) + + .write_out(ret, csv = csv) } .getvarname = function(design, vr) { diff --git a/R/z_tab_numeric.R b/R/z_tab_numeric.R index b6fe0a5..897da8a 100644 --- a/R/z_tab_numeric.R +++ b/R/z_tab_numeric.R @@ -1,7 +1,7 @@ -.tab_numeric = function(design, vr, screen, csv) { +.tab_numeric = function(design, vr, csv) { ret = .tab_numeric_1(design, vr) attr(ret, "title") = .getvarname(design, vr) - .write_out(ret, screen = screen, csv = csv) + .write_out(ret, csv = csv) } .tab_numeric_1 = function(design, vr) { diff --git a/R/z_test_factor.R b/R/z_test_factor.R index b257297..56ac951 100644 --- a/R/z_test_factor.R +++ b/R/z_test_factor.R @@ -1,4 +1,4 @@ -.test_factor = function(design, vr, drop_na, alpha, screen, csv) { +.test_factor = function(design, vr, drop_na, alpha, csv) { assert_that(alpha > 0, alpha < 0.5) if ( !(alpha %in% c(0.05, 0.01, 0.001)) ) { warning("Value of alpha is not typical: ", alpha) @@ -53,5 +53,5 @@ , .getvarname(design, vr) ) .test_table(rT = rT , test_name = test_name, test_title = test_title, alpha = alpha - , screen = screen, csv = csv) + , csv = csv) } diff --git a/R/z_test_table.R b/R/z_test_table.R index b432f29..1d70d43 100644 --- a/R/z_test_table.R +++ b/R/z_test_table.R @@ -1,4 +1,4 @@ -.test_table = function(rT, test_name, test_title, alpha, screen, csv) { +.test_table = function(rT, test_name, test_title, alpha, csv) { assert_that("p-value" %in% names(rT)) rT$Flag = "" @@ -10,5 +10,5 @@ attr(rT, "title") = test_title attr(rT, "footer") = paste0(test_name, ". *: p-value <= ", alpha) - .write_out(rT, screen = screen, csv = csv) + .write_out(rT, csv = csv) } diff --git a/R/z_write_out.R b/R/z_write_out.R index 93a27f1..0f09d35 100644 --- a/R/z_write_out.R +++ b/R/z_write_out.R @@ -1,39 +1,9 @@ -.write_out = function(df1, screen, csv) { - if (!is.null(txt <- attr(df1, "title"))) { - txt %<>% paste0(" {", getOption("surveytable.survey_label"), "}") - attr(df1, "title") = txt - } +.write_out = function(df1, csv) { + assert_that(is.data.frame(df1)) - if (screen) { - 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") - options(width = 10) - hh %>% print_screen(colnames = FALSE, min_width = 0, max_width = max(gow * 1.5, 150, na.rm=TRUE)) - options(width = gow) - cat("\n") - } - } + txt = attr(df1, "title") + txt %<>% paste0(" {", getOption("surveytable.survey_label"), "}") + attr(df1, "title") = txt if (nzchar(csv)) { if (!is.null(txt <- attr(df1, "title"))) { @@ -55,7 +25,8 @@ } # Important for integrating the output into other programming tasks - names(df1) %<>% make.unique + # names(df1) %<>% make.unique rownames(df1) = NULL - invisible(df1) + class(df1) = c("surveytable_table", "data.frame") + df1 } diff --git a/R/zzz.R b/R/zzz.R index 45a24a9..3749fa7 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,30 +1,27 @@ .onAttach = function(libname, pkgname) { - # packageStartupMessage("\nThere are 3 related packages:" - # , "\n* surveytable: functions for tabulating survey estimates" - # , "\n* nchsdata: public use files (PUFs) from the the National Center for Health Statistics (NCHS)" - # , "\n* importsurvey: functions for importing data into R" - # , "\n\nYou've just loaded ", pkgname, "." - # ) - - packageStartupMessage("Before you can tabulate estimates, you have to specify which survey object" + txt = paste0( + "Before you can tabulate estimates, you have to specify which survey object" , " you would like to analyze. You can do this in a couple of ways:" , "\n\na) This package comes with a survey object for use in examples called" , " 'namcs2019sv'. This object has selected variables from the NAMCS 2019 PUF survey." , " To use this survey object:" - , "\n\nset_survey('namcs2019sv')" + , "\n\nset_survey(namcs2019sv)" , "\n\nb) If you have a survey object stored in a file:" , "\n\nmysurvey = readRDS('file_name.rds')" - , "\nset_survey('mysurvey')" + , "\n\nset_survey(mysurvey)" , "\n\nFor info on how to create a survey object from a data frame, see" , " ?survey::svydesign or ?survey::svrepdesign ." ) + + txt = paste(strwrap(txt), collapse = "\n") + packageStartupMessage(txt) } +env = new.env() + .onLoad = function(libname, pkgname) { options( - surveytable.survey = "" - , surveytable.survey_label = "" - , surveytable.survey_envir = .GlobalEnv + surveytable.survey_label = "" , surveytable.check_present = TRUE , surveytable.present_restricted = ".present_restricted" @@ -38,7 +35,6 @@ , surveytable.names_prct = c("Percent", "SE", "LL", "UL") , surveytable.csv = "" - , surveytable.screen = TRUE , surveytable.max_levels = 20 , surveytable.drop_na = FALSE diff --git a/README.Rmd b/README.Rmd index cb87ad1..bee5741 100644 --- a/README.Rmd +++ b/README.Rmd @@ -18,7 +18,7 @@ knitr::opts_chunk$set( -The `surveytable` package provides short and understandable commands that generate tabulated, formatted, and rounded survey estimates. One useful function, which operates on categorical and logical variables, tabulates estimated counts and percentages with their standard errors and confidence intervals. Other functions list the variables in a survey, estimate the total population, tabulate survey subsets and variable interactions, tabulate numeric variables, tabulate rates, create or modify survey variables, perform t-tests, and save the output. All of the tabulation functions check the National Center for Health Statistics (NCHS) presentation standards to flag low-precision estimates. If the `surveytable` code is called from an R Markdown notebook or a Quarto document, it generates HTML tables, which can be incorporated directly into documents. +The `surveytable` package provides short and understandable commands that generate tabulated, formatted, and rounded survey estimates. One useful function, which operates on categorical and logical variables, tabulates estimated counts and percentages with their standard errors and confidence intervals. Other functions list the variables in a survey, estimate the total population, tabulate survey subsets and variable interactions, tabulate numeric variables, tabulate rates, create or modify survey variables, perform hypothesis tests, and save the output. All of the tabulation functions check the National Center for Health Statistics (NCHS) presentation standards to flag low-precision estimates. If the `surveytable` code is called from an R Markdown notebook or a Quarto document, it generates HTML tables, which can be incorporated directly into documents. ## Installation @@ -49,7 +49,7 @@ library(surveytable) ``` ```{r} -set_survey("namcs2019sv") +set_survey(namcs2019sv) ``` ```{r, results='asis'} diff --git a/README.md b/README.md index 16d5141..074069d 100644 --- a/README.md +++ b/README.md @@ -13,12 +13,12 @@ tabulates estimated counts and percentages with their standard errors and confidence intervals. Other functions list the variables in a survey, estimate the total population, tabulate survey subsets and variable interactions, tabulate numeric variables, tabulate rates, -create or modify survey variables, perform t-tests, and save the output. -All of the tabulation functions check the National Center for Health -Statistics (NCHS) presentation standards to flag low-precision -estimates. If the `surveytable` code is called from an R Markdown -notebook or a Quarto document, it generates HTML tables, which can be -incorporated directly into documents. +create or modify survey variables, perform hypothesis tests, and save +the output. All of the tabulation functions check the National Center +for Health Statistics (NCHS) presentation standards to flag +low-precision estimates. If the `surveytable` code is called from an R +Markdown notebook or a Quarto document, it generates HTML tables, which +can be incorporated directly into documents. ## Installation @@ -50,16 +50,16 @@ library(surveytable) ``` ``` r -set_survey("namcs2019sv") -#> _ -#> Survey name NAMCS 2019 PUF -#> Number of variables 33 -#> Number of observations 8250 -#> Stratified 1 - level Cluster Sampling design (with replacement) -#> With (398) clusters. -#> survey::svydesign(ids = ~CPSUM, strata = ~CSTRATM, weights = ~PATWT, -#> data = namcs2019sv_df) +set_survey(namcs2019sv) #> * To adjust how counts are rounded, see ?set_count_int +#> _ +#> Survey name NAMCS 2019 PUF +#> Number of variables 33 +#> Number of observations 8250 +#> Info1 Stratified 1 - level Cluster Sampling design (with replacement) +#> Info2 With (398) clusters. +#> Info3 survey::svydesign(ids = ~CPSUM, strata = ~CSTRATM, weights = ~PATWT, +#> Info4 data = namcs2019sv_df) ``` ``` r diff --git a/_pkgdown.yml b/_pkgdown.yml index 7eb8be4..6fa1a92 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -36,3 +36,4 @@ reference: - surveytable-options - survey_subset - svyciprop_adjusted + - print.surveytable_table diff --git a/cran-comments.md b/cran-comments.md index 858617d..57dc244 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -3,3 +3,38 @@ 0 errors | 0 warnings | 1 note * This is a new release. + +## Responses to comments + +If there are references describing the methods in your package, please add these in the description field of your DESCRIPTION file in the form authors (year) authors (year) authors (year, ISBN:...) or if those are not available: with no space after 'doi:', 'arXiv:', 'https:' and angle brackets for auto-linking. (If you want to add a title as well please put it in +quotes: "Title") + +* DONE. Added references to 1 package and 3 papers. + +\dontrun{} should only be used if the example really cannot be executed (e.g. because of missing additional software, missing API keys, ...) by the user. That's why wrapping examples in \dontrun{} adds the comment ("# Not run:") as a warning for the user. Does not seem necessary. +Please replace \dontrun with \donttest. +Please unwrap the examples if they are executable in < 5 sec, or replace dontrun{} with \donttest{}. +-> set_output.Rd; survey_subset.Rd + +* DONE. Removed dontrun. + +You write information messages to the console that cannot be easily suppressed. +It is more R like to generate objects that can be used to extract the information a user is interested in, and then print() that object. +Instead of print()/cat() rather use message()/warning() or +if(verbose)cat(..) (or maybe stop()) if you really have to write text to the console. (except for print, summary, interactive functions) -> R/set_survey.R; R/z_write_out.R + +* set_survey.R: DONE. The function now returns an object. +* z_write_out.R: DONE. .write_out() now does not print anything. The functions that call .write_out() now return an object. R/print.surveytable_table.R now has the print functions for these objects. + +Please ensure that your functions do not write by default or in your examples/vignettes/tests in the user's home filespace (including the package directory and getwd()). This is not allowed by CRAN policies. +Please omit any default path in writing functions. In your examples/vignettes/tests you can write to tempdir(). -> R/z_write_out.R + +* DONE. In examples for set_output() and in vignettes, now using tempfile(). + +Please also use on.exit() to reset the options in R/z_write_out.R (line 31). + +* DONE. Now in R/print.surveytable_table.R (line 45). + +Please do not modifiy the .GlobalEnv. This is not allowed by the CRAN policies. -> R/zzz.R + +* DONE. The package no longer modifies .GlobalEnv. diff --git a/docs/404.html b/docs/404.html index a9585f4..0158ecd 100644 --- a/docs/404.html +++ b/docs/404.html @@ -24,7 +24,7 @@ surveytable - 0.9.1 + 0.9.2