fixed zero weights issue

NAMESPACE

@@ -7,6 +7,7 @@ export(set_survey)
 export(show_options)
 export(show_output)
 export(show_survey)
+export(survey_subset)
 export(tab)
 export(tab_cross)
 export(tab_rate)

R/set_survey.R

@@ -33,6 +33,24 @@ set_survey = function(survey_name = "") {
 
   options(surveytable.survey = survey_name)
 
+  # zero weights cause issues with tab():
+  # counts = svyby(frm, frm, design, unwtd.count)$counts
+  # assert_that(length(neff) == length(counts))
+  #
+  # prob == 1 / weight ?
+  if (any(design$prob == Inf)) {
+    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(survey_name, design, envir = .GlobalEnv)
+  }
+  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))
@@ -66,14 +84,16 @@ show_survey = function() {
   invisible(NULL)
 }
 
+
 .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")
+    , msg = "You need to specify a survey before the other functions will work. See ?set_survey")
   design = get0(survey_name)
   assert_that(!is.null(design)
-              , msg = paste0(survey_name, " does not exist. Did you forget to load it? See ?set_survey"))
+      , msg = paste0(survey_name, " does not exist. Did you forget to load it? See ?set_survey"))
   assert_that(inherits(design, "survey.design")
-          , msg = paste0(survey_name, " must be a survey.design. Is ", class(design)[1] ))
+              , msg = paste0(survey_name, " must be a survey.design. Is ", class(design)[1] ))
+  assert_that( all(design$prob > 0), all(design$prob < Inf) )
   design
 }

R/survey_subset.R

@@ -0,0 +1,37 @@
+#' Subset a survey, while preserving variable labels
+#'
+#' @param design a survey design object
+#' @param subset an expression specifying the subpopulation
+#' @param label survey label of the newly created survey design object
+#'
+#' @return a new survey design object
+#' @export
+#'
+#' @examples
+#' children = survey_subset(vars2019, AGE < 18, "Children")
+#' set_survey("children")
+#' tab("AGER")
+survey_subset = function(design, subset, label) {
+  assert_that(inherits(design, "survey.design")
+              , msg = paste0("Must be a survey.design. Is ", class(design)[1] ))
+
+  vls = lapply(design$variables, FUN = function(x) attr(x, "label"))
+  nm = names(vls)
+  assert_that(all(nm == names(design$variables)))
+
+  # survey:::subset.survey.design
+  e <- substitute(subset)
+  r <- eval(e, design$variables, parent.frame())
+  r <- r & !is.na(r)
+  d1 <- design[r, ]
+  d1$call = NULL
+
+  assert_that(all(nm == names(d1$variables)))
+
+  for (vr in nm) {
+    attr(d1$variables[,vr], "label") = vls[[vr]]
+  }
+
+  attr(d1, "label") = label
+  d1
+}

R/tab.R

@@ -131,8 +131,10 @@ tab = function(...
 	  attr(mp, "title") = .getvarname(design, vr)
     return(.write_out(mp, screen = screen, csv = csv))
 	} else if (nlv > max_levels) {
-	  warning(.getvarname(design, vr)
-          , ": Categorical variable with too many levels: "
+	  # don't use assert_that
+	  # if multiple tables are being produced, want to go to the next table
+	  warning(vr
+          , ": categorical variable with too many levels: "
           , nlv, ", but ", max_levels
           , " allowed. Try increasing the max_levels argument or "
           , "see ?set_output"
@@ -144,6 +146,7 @@ tab = function(...
 
 	##
 	counts = svyby(frm, frm, design, unwtd.count)$counts
+	assert_that(length(counts) == nlv)
 	if (getOption("surveytable.do_present")) {
 	  pro = getOption("surveytable.present_restricted") %>% do.call(list(counts))
 	} else {

_pkgdown.yml

@@ -34,3 +34,4 @@ reference:
   - set_output
   - show_options
   - surveytable-options
+  - survey_subset

docs/pkgdown.yml

@@ -6,7 +6,7 @@ articles:
   a02-Example-Residential-Care-Community-RCC-Services-User-SU: a02-Example-Residential-Care-Community-RCC-Services-User-SU.html
   a03-Example-National-Ambulatory-Medical-Care-Survey-NAMCS-report: a03-Example-National-Ambulatory-Medical-Care-Survey-NAMCS-report.html
   surveytable: surveytable.html
-last_built: 2023-11-08T18:00Z
+last_built: 2023-11-09T01:52Z
 urls:
   reference: https://cdcgov.github.io/surveytable/reference
   article: https://cdcgov.github.io/surveytable/articles

docs/sitemap.xml

@@ -54,6 +54,9 @@
   <url>
     <loc>https://cdcgov.github.io/surveytable/reference/surveytable-package.html</loc>
   </url>
+  <url>
+    <loc>https://cdcgov.github.io/surveytable/reference/survey_subset.html</loc>
+  </url>
   <url>
     <loc>https://cdcgov.github.io/surveytable/reference/tab.html</loc>
   </url>