Skip to content

Commit 635b6dc

Browse files
ddsjobergddsjoberg
authored
survey one-sample CIs (#177)
**What changes are proposed in this pull request?** * Style this entry in a way that can be copied directly into `NEWS.md`. (#<issue number>, @<username>) Provide more detail here as needed. **Reference GitHub issue associated with pull request.** _e.g., 'closes #<issue number>'_ -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [ ] **All** GitHub Action workflows pass with a ✅ - [ ] PR branch has pulled the most recent updates from master branch: `usethis::pr_merge_main()` - [ ] If a bug was fixed, a unit test was added. - [ ] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`. - [ ] If a new `ard_*()` function was added, `set_cli_abort_call()` has been set. - [ ] If a new `ard_*()` function was added and it depends on another package (such as, `broom`), `is_pkg_installed("broom", reference_pkg = "cardx")` has been set in the function call and the following added to the roxygen comments: `@examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom"", reference_pkg = "cardx"))` - [ ] Code coverage is suitable for any new functions/features (generally, 100% coverage for new code): `devtools::test_coverage()` Reviewer Checklist (if item does not apply, mark is as complete) - [ ] If a bug was fixed, a unit test was added. - [ ] Code coverage is suitable for any new functions/features: `devtools::test_coverage()` When the branch is ready to be merged: - [ ] Update `NEWS.md` with the changes from this pull request under the heading "`# cardx (development version)`". If there is an issue associated with the pull request, reference it in parentheses at the end update (see `NEWS.md` for examples). - [ ] **All** GitHub Action workflows pass with a ✅ - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge".
1 parent b4bc78d commit 635b6dc

10 files changed

+907
-0
lines changed

‎NAMESPACE‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,8 @@ export(ard_stats_t_test)
4343
export(ard_stats_t_test_onesample)
4444
export(ard_stats_wilcox_test)
4545
export(ard_stats_wilcox_test_onesample)
46+
export(ard_survey_categorical_ci)
47+
export(ard_survey_continuous_ci)
4648
export(ard_survey_svychisq)
4749
export(ard_survey_svyranktest)
4850
export(ard_survey_svyttest)

‎R/ard_survey_categorical_ci.R‎

Lines changed: 183 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,183 @@
1+
#' ARD survey categorical CIs
2+
#'
3+
#' Confidence intervals for categorical variables calculated via
4+
#' [`survey::svyciprop()`].
5+
#'
6+
#' @inheritParams ard_continuous.survey.design
7+
#' @param method (`string`)\cr
8+
#' Method passed to `survey::svyciprop(method)`
9+
#' @param conf.level (scalar `numeric`)\cr
10+
#' confidence level for confidence interval. Default is `0.95`.
11+
#' @param df (`numeric`)\cr
12+
#' denominator degrees of freedom, passed to `survey::svyciprop(df)`.
13+
#' Default is `survey::degf(data)`.
14+
#' @param ... arguments passed to `survey::svyciprop()`
15+
#'
16+
#' @return ARD data frame
17+
#' @export
18+
#'
19+
#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "survey", reference_pkg = "cardx"))
20+
#' data(api, package = "survey")
21+
#' dclus1 <- survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)
22+
#'
23+
#' ard_survey_categorical_ci(dclus1, variables = sch.wide)
24+
#' ard_survey_categorical_ci(dclus1, variables = sch.wide, method = "xlogit")
25+
ard_survey_categorical_ci <- function(data,
26+
variables,
27+
by = NULL,
28+
method = c("logit", "likelihood", "asin", "beta", "mean", "xlogit"),
29+
conf.level = 0.95,
30+
df = survey::degf(data),
31+
...) {
32+
set_cli_abort_call()
33+
34+
# check inputs ---------------------------------------------------------------
35+
check_not_missing(data)
36+
check_class(data, "survey.design")
37+
check_not_missing(variables)
38+
39+
cards::process_selectors(
40+
data = data$variables,
41+
variables = {{ variables }},
42+
by = {{ by }}
43+
)
44+
check_scalar(by, allow_empty = TRUE)
45+
check_scalar_range(conf.level, range = c(0, 1))
46+
method <- arg_match(method)
47+
48+
# calculate and return ARD of one sample CI ----------------------------------
49+
.calculate_ard_onesample_survey_ci(
50+
FUN = .svyciprop_wrapper,
51+
data = data,
52+
variables = variables,
53+
by = by,
54+
conf.level = conf.level,
55+
method = method,
56+
df = df,
57+
...
58+
)
59+
}
60+
61+
.calculate_ard_onesample_survey_ci <- function(FUN, data, variables, by, conf.level, ...) {
62+
# return empty data frame if no variables to process -------------------------
63+
if (is_empty(variables)) return(dplyr::tibble()) # styler: off
64+
65+
# calculate results ----------------------------------------------------------
66+
map(
67+
variables,
68+
function(variable) {
69+
.calculate_one_ard_categorical_survey_ci(
70+
FUN = FUN,
71+
data = data,
72+
variable = variable,
73+
by = by,
74+
conf.level = conf.level,
75+
...
76+
)
77+
}
78+
) |>
79+
dplyr::bind_rows()
80+
}
81+
82+
.calculate_one_ard_categorical_survey_ci <- function(FUN, data, variable, by, conf.level, ...) {
83+
variable_levels <- .unique_values_sort(data$variables, variable = variable)
84+
if (!is_empty(by)) {
85+
by_levels <- .unique_values_sort(data$variables, variable = by)
86+
lst_data <-
87+
map(
88+
by_levels,
89+
~ call2("subset", expr(data), expr(!!sym(by) == !!.x)) |> eval()
90+
) |>
91+
set_names(as.character(by_levels))
92+
}
93+
94+
df_full <-
95+
case_switch(
96+
!is_empty(by) ~
97+
tidyr::expand_grid(
98+
group1_level = as.character(by_levels) |> as.list(),
99+
variable_level = as.character(variable_levels) |> as.list()
100+
) |>
101+
dplyr::mutate(group1 = .env$by, variable = .env$variable),
102+
.default =
103+
dplyr::tibble(
104+
variable = .env$variable,
105+
variable_level = as.character(variable_levels) |> as.list()
106+
)
107+
) |>
108+
dplyr::rowwise() |>
109+
dplyr::mutate(
110+
lst_result =
111+
FUN(
112+
data =
113+
case_switch(
114+
is_empty(.env$by) ~ data,
115+
.default = lst_data[[.data$group1_level]]
116+
),
117+
variable = .data$variable,
118+
variable_level = .data$variable_level,
119+
conf.level = .env$conf.level,
120+
...
121+
) |>
122+
list(),
123+
result =
124+
.data$lst_result[["result"]] |>
125+
enframe("stat_name", "stat") |>
126+
list(),
127+
warning = .data$lst_result["warning"] |> unname(),
128+
error = .data$lst_result["error"] |> unname(),
129+
context = "survey_categorical_ci"
130+
) |>
131+
dplyr::select(-"lst_result") |>
132+
dplyr::ungroup() |>
133+
tidyr::unnest("result") |>
134+
dplyr::mutate(
135+
stat_label = .data$stat_name,
136+
fmt_fn = map(.data$stat, ~ case_switch(is.numeric(.x) ~ 2L, .default = as.character))
137+
) |>
138+
cards::tidy_ard_column_order() %>%
139+
structure(., class = c("card", class(.)))
140+
}
141+
142+
143+
.svyciprop_wrapper <- function(data, variable, variable_level, conf.level, method, df, ...) {
144+
lst_results <-
145+
cards::eval_capture_conditions(
146+
survey::svyciprop(
147+
formula = inject(~ I(!!sym(variable) == !!variable_level)),
148+
design = data,
149+
method = method,
150+
level = conf.level,
151+
df = df,
152+
...
153+
) %>%
154+
{list(.[[1]], attr(., "ci"))} |> # styler: off
155+
unlist() |>
156+
set_names(c("estimate", "conf.low", "conf.high")) |>
157+
as.list()
158+
)
159+
160+
# add NULL results if error
161+
if (is_empty(lst_results[["result"]])) {
162+
lst_results[["result"]] <- rep_named(c("estimate", "conf.low", "conf.high"), list(NULL))
163+
}
164+
165+
# add other args
166+
lst_results[["result"]] <- lst_results[["result"]] |> append(list(method = method, conf.level = conf.level))
167+
168+
# return list result
169+
lst_results
170+
}
171+
172+
173+
case_switch <- function(..., .default = NULL) {
174+
dots <- dots_list(...)
175+
176+
for (f in dots) {
177+
if (isTRUE(eval(f_lhs(f), envir = attr(f, ".Environment")))) {
178+
return(eval(f_rhs(f), envir = attr(f, ".Environment")))
179+
}
180+
}
181+
182+
return(.default)
183+
}

0 commit comments

Comments
 (0)