From 8652a4233bef22eb2ac3a53b5c8384488f9f0ff9 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Wed, 21 Feb 2024 09:47:45 -0800 Subject: [PATCH 01/11] lil updates --- DESCRIPTION | 2 +- inst/WORDLIST | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8f0983bbe..58e91a2aa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,7 +14,7 @@ BugReports: https://github.com/insightsengineering/cardx/issues Depends: R (>= 4.1) Imports: - cards (>= 0.0.0.9044), + cards (>= 0.0.0.9048), cli (>= 3.6.1), dplyr (>= 1.1.2), glue (>= 1.6.2), diff --git a/inst/WORDLIST b/inst/WORDLIST index 14073fb50..1a602fd4c 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,8 +1,11 @@ ARD Biopharmaceutical +CMD Clopper +Codecov Hoffmann Jeffreys +Lifecycle Newcombe Su XG From 2e07a4fdf389b1b1beef786e7e37154bf6e8bf42 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Wed, 21 Feb 2024 17:48:41 +0000 Subject: [PATCH 02/11] [skip actions] Bump version to 0.0.0.9039 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 58e91a2aa..ab85335aa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.0.0.9038 +Version: 0.0.0.9039 Authors@R: c( person("Daniel", "Sjoberg", , "sjobergd@gene.com", role = c("aut", "cre")), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")) diff --git a/NEWS.md b/NEWS.md index ba5f4e5d2..d109141cd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.0.0.9038 +# cardx 0.0.0.9039 ### New Features * New package! From 39ccf3f0cd68401f8a6b3d524470cb3b994fe13f Mon Sep 17 00:00:00 2001 From: Davide Garolini Date: Wed, 21 Feb 2024 19:07:53 +0100 Subject: [PATCH 03/11] McNemar's statistical test addition: `ard_mcnemartest` (#51) **What changes are proposed in this pull request?** * Added `ard_mcnemartest()` statistical test function. Closes #40 * I am wondering if we need to have `ccorrect = TRUE` as default, following the default in stats, and if we should make this option more apparent in the case we change this default. * Also, I do not know if it would be relevant but I used an utility function to find dichotomies in a data-set that could result useful as a tool if there is not one already doing this: ``` r # Assuming your data.frame is named df df <- data.frame( A = c(1, 0, 1, 0), # dichotomous B = c(1, 2, 3, 4), # not dichotomous C = c("Yes", "No", "Yes", "No"), # dichotomous D = c(TRUE, FALSE, TRUE, FALSE) # dichotomous ) # Function to find dichotomous columns find_dichotomous_columns <- function(df) { dichotomous_columns <- c() for (col_name in names(df)) { if (length(unique(df[[col_name]])) == 2) { dichotomous_columns <- c(dichotomous_columns, col_name) } } return(dichotomous_columns) } # Find and display dichotomous columns dichotomous_columns <- find_dichotomous_columns(df) print(dichotomous_columns) #> [1] "A" "C" "D" di_cols <- find_dichotomous_columns(cards::ADSL) print(di_cols) #> [1] "SEX" "ETHNIC" "EFFFL" "COMP8FL" "COMP16FL" "COMP24FL" #> [7] "DISCONFL" "DSRAEFL" "DTHFL" "DURDSGR1" ``` Created on 2024-02-14 with [reprex v2.1.0](https://reprex.tidyverse.org) * `.paired_data_pivot_wider` is in the Wilcoxon test. Should we have it as a tool in a dedicated file? It looks general to me. -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [x] **All** GitHub Action workflows pass with a :white_check_mark: - [x] PR branch has pulled the most recent updates from master branch: `usethis::pr_merge_main()` - [x] If a bug was fixed, a unit test was added. - [x] Code coverage is suitable for any new functions/features (generally, 100% coverage for new code): `devtools::test_coverage()` - [x] Request a reviewer Reviewer Checklist (if item does not apply, mark is as complete) - [ ] If a bug was fixed, a unit test was added. - [ ] Run `pkgdown::build_site()`. Check the R console for errors, and review the rendered website. - [ ] 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 "`# cards (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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --------- Signed-off-by: Davide Garolini Signed-off-by: Davide Garolini Signed-off-by: Daniel Sjoberg Co-authored-by: Abinaya Yogasekaram <73252787+ayogasekaram@users.noreply.github.com> Co-authored-by: Daniel Sjoberg --- NAMESPACE | 1 + R/ard_mcnemartest.R | 108 ++++++++++++++++++++++++++ R/ard_wilcoxtest.R | 12 ++- _pkgdown.yml | 1 + inst/WORDLIST | 1 + man/ard_mcnemartest.Rd | 36 +++++++++ man/dot-format_mcnemartest_results.Rd | 38 +++++++++ man/dot-format_wilcoxtest_results.Rd | 8 +- tests/testthat/test-ard_mcnemartest.R | 40 ++++++++++ 9 files changed, 242 insertions(+), 3 deletions(-) create mode 100644 R/ard_mcnemartest.R create mode 100644 man/ard_mcnemartest.Rd create mode 100644 man/dot-format_mcnemartest_results.Rd create mode 100644 tests/testthat/test-ard_mcnemartest.R diff --git a/NAMESPACE b/NAMESPACE index d58df76b4..6d710dda8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(any_of) export(ard_chisqtest) export(ard_fishertest) export(ard_kruskaltest) +export(ard_mcnemartest) export(ard_paired_ttest) export(ard_paired_wilcoxtest) export(ard_proportion_ci) diff --git a/R/ard_mcnemartest.R b/R/ard_mcnemartest.R new file mode 100644 index 000000000..168a8f51c --- /dev/null +++ b/R/ard_mcnemartest.R @@ -0,0 +1,108 @@ +#' ARD McNemar's Test +#' +#' @description +#' Analysis results data for McNemar's statistical test. +#' +#' @param data (`data.frame`)\cr +#' a data frame. See below for details. +#' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' column name to compare by. +#' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' column name to be compared. +#' @param ... arguments passed to `stats::mcnemar.test(...)` +#' +#' @return ARD data frame +#' @name ard_mcnemartest +#' +#' @details +#' For the `ard_mcnemartest()` function, the data is expected to be one row per subject. +#' The data is passed as `stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)`. +#' Please use `table(x = data[[variable]], y = data[[by]])` to check the contingency table. +#' +#' @examples +#' cards::ADSL |> +#' ard_mcnemartest(by = "SEX", variable = "EFFFL") +#' +NULL + +#' @rdname ard_mcnemartest +#' @export +ard_mcnemartest <- function(data, by, variable, ...) { + # check installed packages --------------------------------------------------- + cards::check_pkg_installed("broom", reference_pkg = "cardx") + + # check/process inputs ------------------------------------------------------- + check_not_missing(data) + check_not_missing(variable) + check_not_missing(by) + check_class_data_frame(x = data) + data <- dplyr::ungroup(data) + cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) + check_scalar(by) + check_scalar(variable) + + # build ARD ------------------------------------------------------------------ + .format_mcnemartest_results( + by = by, + variable = variable, + lst_tidy = + cards::eval_capture_conditions( + stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...) |> + broom::tidy() + ), + ... + ) +} + +#' Convert McNemar's test to ARD +#' +#' @inheritParams cards::tidy_as_ard +#' @inheritParams stats::mcnemar.test +#' @param by (`string`)\cr by column name +#' @param variable (`string`)\cr variable column name +#' @param ... passed to `stats::mcnemar.test(...)` +#' +#' @return ARD data frame +#' +#' @examples +#' cardx:::.format_mcnemartest_results( +#' by = "ARM", +#' variable = "AGE", +#' lst_tidy = +#' cards::eval_capture_conditions( +#' stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |> +#' broom::tidy() +#' ) +#' ) +#' +#' @keywords internal +.format_mcnemartest_results <- function(by, variable, lst_tidy, ...) { + # build ARD ------------------------------------------------------------------ + ret <- + cards::tidy_as_ard( + lst_tidy = lst_tidy, + tidy_result_names = c("statistic", "p.value", "method"), + fun_args_to_record = c("correct"), + formals = formals(asNamespace("stats")[["mcnemar.test"]]), + passed_args = dots_list(...), + lst_ard_columns = list(group1 = by, variable = variable, context = "mcnemartest") + ) + + # add the stat label --------------------------------------------------------- + ret |> + dplyr::left_join( + .df_mcnemar_stat_labels(), + by = "stat_name" + ) |> + dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> + cards::tidy_ard_column_order() +} + +.df_mcnemar_stat_labels <- function() { + dplyr::tribble( + ~stat_name, ~stat_label, + "statistic", "X-squared Statistic", + "parameter", "Degrees of Freedom", + "p.value", "p-value", + ) +} diff --git a/R/ard_wilcoxtest.R b/R/ard_wilcoxtest.R index 3ed5a1e4a..071c77ba8 100644 --- a/R/ard_wilcoxtest.R +++ b/R/ard_wilcoxtest.R @@ -105,17 +105,23 @@ ard_paired_wilcoxtest <- function(data, by, variable, id, ...) { ) } + #' Convert Wilcoxon test to ARD #' #' @inheritParams cards::tidy_as_ard #' @inheritParams stats::wilcox.test #' @param by (`string`)\cr by column name #' @param variable (`string`)\cr variable column name -#' @param ... passed to `wilcox.test(...)` +#' @param ... passed to `stats::wilcox.test(...)` #' #' @return ARD data frame -#' @keywords internal +#' #' @examples +#' # Pre-processing ADSL to have grouping factor (ARM here) with 2 levels +#' ADSL <- cards::ADSL |> +#' dplyr::filter(ARM %in% c("Placebo", "Xanomeline High Dose")) |> +#' ard_wilcoxtest(by = "ARM", variable = "AGE") +#' #' cardx:::.format_wilcoxtest_results( #' by = "ARM", #' variable = "AGE", @@ -126,6 +132,8 @@ ard_paired_wilcoxtest <- function(data, by, variable, id, ...) { #' broom::tidy() #' ) #' ) +#' +#' @keywords internal .format_wilcoxtest_results <- function(by, variable, lst_tidy, paired, ...) { # build ARD ------------------------------------------------------------------ ret <- diff --git a/_pkgdown.yml b/_pkgdown.yml index b3c97b7c0..e23c70a05 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -27,6 +27,7 @@ reference: - ard_chisqtest - ard_fishertest - ard_kruskaltest + - ard_mcnemartest - ard_ttest - ard_wilcoxtest diff --git a/inst/WORDLIST b/inst/WORDLIST index 1a602fd4c..6aabb79bb 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -5,6 +5,7 @@ Clopper Codecov Hoffmann Jeffreys +McNemar's Lifecycle Newcombe Su diff --git a/man/ard_mcnemartest.Rd b/man/ard_mcnemartest.Rd new file mode 100644 index 000000000..7fdfafceb --- /dev/null +++ b/man/ard_mcnemartest.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ard_mcnemartest.R +\name{ard_mcnemartest} +\alias{ard_mcnemartest} +\title{ARD McNemar's Test} +\usage{ +ard_mcnemartest(data, by, variable, ...) +} +\arguments{ +\item{data}{(\code{data.frame})\cr +a data frame. See below for details.} + +\item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +column name to compare by.} + +\item{variable}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +column name to be compared.} + +\item{...}{arguments passed to \code{stats::mcnemar.test(...)}} +} +\value{ +ARD data frame +} +\description{ +Analysis results data for McNemar's statistical test. +} +\details{ +For the \code{ard_mcnemartest()} function, the data is expected to be one row per subject. +The data is passed as \code{stats::mcnemar.test(x = data[[variable]], y = data[[by]], ...)}. +Please use \code{table(x = data[[variable]], y = data[[by]])} to check the contingency table. +} +\examples{ +cards::ADSL |> + ard_mcnemartest(by = "SEX", variable = "EFFFL") + +} diff --git a/man/dot-format_mcnemartest_results.Rd b/man/dot-format_mcnemartest_results.Rd new file mode 100644 index 000000000..a809a791c --- /dev/null +++ b/man/dot-format_mcnemartest_results.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ard_mcnemartest.R +\name{.format_mcnemartest_results} +\alias{.format_mcnemartest_results} +\title{Convert McNemar's test to ARD} +\usage{ +.format_mcnemartest_results(by, variable, lst_tidy, ...) +} +\arguments{ +\item{by}{(\code{string})\cr by column name} + +\item{variable}{(\code{string})\cr variable column name} + +\item{lst_tidy}{(named \code{list})\cr +list of tidied results constructed with \code{\link[cards:eval_capture_conditions]{eval_capture_conditions()}}, +e.g. \code{eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy())}.} + +\item{...}{passed to \code{stats::mcnemar.test(...)}} +} +\value{ +ARD data frame +} +\description{ +Convert McNemar's test to ARD +} +\examples{ +cardx:::.format_mcnemartest_results( + by = "ARM", + variable = "AGE", + lst_tidy = + cards::eval_capture_conditions( + stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]]) |> + broom::tidy() + ) +) + +} +\keyword{internal} diff --git a/man/dot-format_wilcoxtest_results.Rd b/man/dot-format_wilcoxtest_results.Rd index 55318dba0..10f70950e 100644 --- a/man/dot-format_wilcoxtest_results.Rd +++ b/man/dot-format_wilcoxtest_results.Rd @@ -17,7 +17,7 @@ e.g. \code{eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy \item{paired}{a logical indicating whether you want a paired test.} -\item{...}{passed to \code{wilcox.test(...)}} +\item{...}{passed to \code{stats::wilcox.test(...)}} } \value{ ARD data frame @@ -26,6 +26,11 @@ ARD data frame Convert Wilcoxon test to ARD } \examples{ +# Pre-processing ADSL to have grouping factor (ARM here) with 2 levels +ADSL <- cards::ADSL |> + dplyr::filter(ARM \%in\% c("Placebo", "Xanomeline High Dose")) |> + ard_wilcoxtest(by = "ARM", variable = "AGE") + cardx:::.format_wilcoxtest_results( by = "ARM", variable = "AGE", @@ -36,5 +41,6 @@ cardx:::.format_wilcoxtest_results( broom::tidy() ) ) + } \keyword{internal} diff --git a/tests/testthat/test-ard_mcnemartest.R b/tests/testthat/test-ard_mcnemartest.R new file mode 100644 index 000000000..de4f4e582 --- /dev/null +++ b/tests/testthat/test-ard_mcnemartest.R @@ -0,0 +1,40 @@ +test_that("ard_mcnemartest() works", { + expect_error( + ard_mcnemartest <- + cards::ADSL |> + ard_mcnemartest(by = SEX, variable = EFFFL), + NA + ) + + expect_equal( + ard_mcnemartest |> + cards::get_ard_statistics(stat_name %in% c("statistic", "p.value", "parameter", "method")), + stats::mcnemar.test(cards::ADSL[["SEX"]], cards::ADSL[["EFFFL"]], correct = TRUE) |> + broom::tidy() |> + unclass(), + ignore_attr = TRUE + ) + + # errors are properly handled + expect_equal( + cards::ADSL |> + ard_mcnemartest(by = ARM, variable = AGE, correct = FALSE) |> + dplyr::pull(error) |> + getElement(1L), + "'x' and 'y' must have the same number of levels (minimum 2)" + ) + + # non-syntactic column names work too + ADSL_tmp <- cards::ADSL |> + dplyr::rename("if" = AGE, "_c d" = EFFFL) + + expect_equal( + cards::ADSL |> + dplyr::rename(`Planned Tx` = TRT01P, `Age Group` = AGEGR1) |> + ard_mcnemartest(by = `Planned Tx`, variable = `Age Group`) |> + cards::get_ard_statistics(), + cards::ADSL |> + ard_mcnemartest(by = TRT01P, variable = AGEGR1) |> + cards::get_ard_statistics() + ) +}) From fe0ece19faeb6304d8fa82a814b84850dfa478fb Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Wed, 21 Feb 2024 18:08:42 +0000 Subject: [PATCH 04/11] [skip actions] Bump version to 0.0.0.9040 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ab85335aa..e01ac9933 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.0.0.9039 +Version: 0.0.0.9040 Authors@R: c( person("Daniel", "Sjoberg", , "sjobergd@gene.com", role = c("aut", "cre")), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")) diff --git a/NEWS.md b/NEWS.md index d109141cd..25cabf4fb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.0.0.9039 +# cardx 0.0.0.9040 ### New Features * New package! From 4200037271d595aeb1eb6dedfedcd68562d905fa Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Wed, 21 Feb 2024 18:09:37 +0000 Subject: [PATCH 05/11] [skip actions] Update WORDLIST --- inst/WORDLIST | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/WORDLIST b/inst/WORDLIST index 6aabb79bb..243f05fcc 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -5,8 +5,8 @@ Clopper Codecov Hoffmann Jeffreys -McNemar's Lifecycle +McNemar's Newcombe Su XG From 28eaf307f4dad3d3e9bf86171a2fc2175bdcd178 Mon Sep 17 00:00:00 2001 From: Zelos Zhu Date: Wed, 21 Feb 2024 14:03:32 -0500 Subject: [PATCH 06/11] Closes #52 for moods test (#52) **What changes are proposed in this pull request?** * Style this entry in a way that can be copied directly into `NEWS.md`. (#, @) Provide more detail here as needed. **Reference GitHub issue associated with pull request.** _e.g., 'closes #'_ -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [ ] **All** GitHub Action workflows pass with a :white_check_mark: - [ ] 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. - [ ] Code coverage is suitable for any new functions/features (generally, 100% coverage for new code): `devtools::test_coverage()` - [ ] Request a reviewer Reviewer Checklist (if item does not apply, mark is as complete) - [ ] If a bug was fixed, a unit test was added. - [ ] Run `pkgdown::build_site()`. Check the R console for errors, and review the rendered website. - [ ] 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 "`# cards (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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --------- Signed-off-by: Zelos Zhu Signed-off-by: Daniel Sjoberg Co-authored-by: Daniel Sjoberg --- NAMESPACE | 1 + R/ard_moodtest.R | 101 ++++++++++++++++++++++++++ _pkgdown.yml | 1 + man/ard_moodtest.Rd | 35 +++++++++ man/dot-format_moodtest_results.Rd | 37 ++++++++++ tests/testthat/_snaps/ard_moodtest.md | 16 ++++ tests/testthat/test-ard_moodtest.R | 25 +++++++ 7 files changed, 216 insertions(+) create mode 100644 R/ard_moodtest.R create mode 100644 man/ard_moodtest.Rd create mode 100644 man/dot-format_moodtest_results.Rd create mode 100644 tests/testthat/_snaps/ard_moodtest.md create mode 100644 tests/testthat/test-ard_moodtest.R diff --git a/NAMESPACE b/NAMESPACE index 6d710dda8..83c3db954 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(any_of) export(ard_chisqtest) export(ard_fishertest) export(ard_kruskaltest) +export(ard_moodtest) export(ard_mcnemartest) export(ard_paired_ttest) export(ard_paired_wilcoxtest) diff --git a/R/ard_moodtest.R b/R/ard_moodtest.R new file mode 100644 index 000000000..f1d11dde2 --- /dev/null +++ b/R/ard_moodtest.R @@ -0,0 +1,101 @@ +#' ARD Mood Test +#' +#' @description +#' Analysis results data for Mood two sample test of scale. Note this not to be confused with +#' the Brown-Mood test of medians. +#' +#' @param data (`data.frame`)\cr +#' a data frame. See below for details. +#' @param by ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' column name to compare by. +#' @param variable ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' column name to be compared. +#' @param ... arguments passed to `mood.test(...)` +#' +#' @return ARD data frame +#' @name ard_moodtest +#' +#' @details +#' For the `ard_moodtest()` function, the data is expected to be one row per subject. +#' The data is passed as `mood.test(data[[variable]] ~ data[[by]], ...)`. +#' @rdname ard_moodtest +#' @export +#' +#' @examples +#' cards::ADSL |> +#' ard_moodtest(by = "SEX", variable = "AGE") +ard_moodtest <- function(data, by, variable, ...) { + # check installed packages --------------------------------------------------- + cards::check_pkg_installed("broom", reference_pkg = "cardx") + + # check/process inputs ------------------------------------------------------- + check_not_missing(data) + check_not_missing(variable) + check_not_missing(by) + check_class_data_frame(x = data) + data <- dplyr::ungroup(data) + cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) + check_scalar(by) + check_scalar(variable) + + # build ARD ------------------------------------------------------------------ + .format_moodtest_results( + by = by, + variable = variable, + lst_tidy = + cards::eval_capture_conditions( + stats::mood.test(data[[variable]] ~ data[[by]], ...) |> + broom::tidy() + ), + ... + ) +} +#' Convert mood test results to ARD +#' +#' @inheritParams cards::tidy_as_ard +#' @inheritParams stats::mood.test +#' @param by (`string`)\cr by column name +#' @param variable (`string`)\cr variable column name +#' @param ... passed to `mood.test(...)` +#' +#' @return ARD data frame +#' @keywords internal +#' @examples +#' cardx:::.format_moodtest_results( +#' by = "SEX", +#' variable = "AGE", +#' lst_tidy = +#' cards::eval_capture_conditions( +#' stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |> +#' broom::tidy() +#' ) +#' ) +.format_moodtest_results <- function(by, variable, lst_tidy, ...) { + # build ARD ------------------------------------------------------------------ + ret <- + cards::tidy_as_ard( + lst_tidy = lst_tidy, + tidy_result_names = c("statistic", "p.value", "method", "alternative"), + formals = formals(asNamespace("stats")[["mood.test.default"]]), + passed_args = c(dots_list(...)), + lst_ard_columns = list(group1 = by, variable = variable, context = "moodtest") + ) + + # add the stat label --------------------------------------------------------- + ret |> + dplyr::left_join( + .df_moodtest_stat_labels(), + by = "stat_name" + ) |> + dplyr::mutate(stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name)) |> + cards::tidy_ard_column_order() +} + +.df_moodtest_stat_labels <- function() { + dplyr::tribble( + ~stat_name, ~stat_label, + "statistic", "Z-Statistic", + "p.value", "p-value", + "alternative", "Alternative Hypothesis" + ) +} diff --git a/_pkgdown.yml b/_pkgdown.yml index e23c70a05..3f30f9016 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -27,6 +27,7 @@ reference: - ard_chisqtest - ard_fishertest - ard_kruskaltest + - ard_moodtest - ard_mcnemartest - ard_ttest - ard_wilcoxtest diff --git a/man/ard_moodtest.Rd b/man/ard_moodtest.Rd new file mode 100644 index 000000000..7d9bce6f0 --- /dev/null +++ b/man/ard_moodtest.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ard_moodtest.R +\name{ard_moodtest} +\alias{ard_moodtest} +\title{ARD Mood Test} +\usage{ +ard_moodtest(data, by, variable, ...) +} +\arguments{ +\item{data}{(\code{data.frame})\cr +a data frame. See below for details.} + +\item{by}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +column name to compare by.} + +\item{variable}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +column name to be compared.} + +\item{...}{arguments passed to \code{mood.test(...)}} +} +\value{ +ARD data frame +} +\description{ +Analysis results data for Mood two sample test of scale. Note this not to be confused with +the Brown-Mood test of medians. +} +\details{ +For the \code{ard_moodtest()} function, the data is expected to be one row per subject. +The data is passed as \code{mood.test(data[[variable]] ~ data[[by]], ...)}. +} +\examples{ +cards::ADSL |> + ard_moodtest(by = "SEX", variable = "AGE") +} diff --git a/man/dot-format_moodtest_results.Rd b/man/dot-format_moodtest_results.Rd new file mode 100644 index 000000000..95cae344e --- /dev/null +++ b/man/dot-format_moodtest_results.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ard_moodtest.R +\name{.format_moodtest_results} +\alias{.format_moodtest_results} +\title{Convert mood test results to ARD} +\usage{ +.format_moodtest_results(by, variable, lst_tidy, ...) +} +\arguments{ +\item{by}{(\code{string})\cr by column name} + +\item{variable}{(\code{string})\cr variable column name} + +\item{lst_tidy}{(named \code{list})\cr +list of tidied results constructed with \code{\link[cards:eval_capture_conditions]{eval_capture_conditions()}}, +e.g. \code{eval_capture_conditions(t.test(mtcars$mpg ~ mtcars$am) |> broom::tidy())}.} + +\item{...}{passed to \code{mood.test(...)}} +} +\value{ +ARD data frame +} +\description{ +Convert mood test results to ARD +} +\examples{ +cardx:::.format_moodtest_results( + by = "SEX", + variable = "AGE", + lst_tidy = + cards::eval_capture_conditions( + stats::mood.test(ADSL[["AGE"]] ~ ADSL[["SEX"]]) |> + broom::tidy() + ) +) +} +\keyword{internal} diff --git a/tests/testthat/_snaps/ard_moodtest.md b/tests/testthat/_snaps/ard_moodtest.md new file mode 100644 index 000000000..6f1890bc2 --- /dev/null +++ b/tests/testthat/_snaps/ard_moodtest.md @@ -0,0 +1,16 @@ +# ard_moodtest() works + + Code + as.data.frame(ard_moodtest(cards::ADSL, by = SEX, variable = AGE)) + Output + group1 variable context stat_name stat_label + 1 SEX AGE moodtest statistic Z-Statistic + 2 SEX AGE moodtest p.value p-value + 3 SEX AGE moodtest method method + 4 SEX AGE moodtest alternative Alternative Hypothesis + statistic statistic_fmt_fn warning error + 1 0.1292194 1 NULL NULL + 2 0.8971841 1 NULL NULL + 3 Mood two-sample test of scale NULL NULL NULL + 4 two.sided NULL NULL NULL + diff --git a/tests/testthat/test-ard_moodtest.R b/tests/testthat/test-ard_moodtest.R new file mode 100644 index 000000000..bbb7b3fd4 --- /dev/null +++ b/tests/testthat/test-ard_moodtest.R @@ -0,0 +1,25 @@ +test_that("ard_moodtest() works", { + expect_error( + ard_moodtest <- + cards::ADSL |> + ard_moodtest(by = SEX, variable = AGE), + NA + ) + + expect_equal( + ard_moodtest |> + cards::get_ard_statistics(stat_name %in% c("statistic", "p.value")), + with(cards::ADSL, mood.test(AGE ~ SEX)) |> + broom::tidy() |> + dplyr::select(statistic, p.value) |> + unclass(), + ignore_attr = TRUE + ) + + # errors are properly handled + expect_snapshot( + cards::ADSL |> + ard_moodtest(by = SEX, variable = AGE) |> + as.data.frame() + ) +}) From cff2b9d5ec0c28514068931a7396aac817d4277f Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Wed, 21 Feb 2024 19:04:24 +0000 Subject: [PATCH 07/11] [skip actions] Bump version to 0.0.0.9041 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e01ac9933..bd4c44270 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.0.0.9040 +Version: 0.0.0.9041 Authors@R: c( person("Daniel", "Sjoberg", , "sjobergd@gene.com", role = c("aut", "cre")), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")) diff --git a/NEWS.md b/NEWS.md index 25cabf4fb..c1b0e2448 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.0.0.9040 +# cardx 0.0.0.9041 ### New Features * New package! From ddbd0121f75cd7bd2ffc929608f9c8989f3e553e Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Wed, 21 Feb 2024 12:43:51 -0800 Subject: [PATCH 08/11] general renaming (#58) **What changes are proposed in this pull request?** * Style this entry in a way that can be copied directly into `NEWS.md`. (#, @) Provide more detail here as needed. **Reference GitHub issue associated with pull request.** _e.g., 'closes #'_ -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [ ] **All** GitHub Action workflows pass with a :white_check_mark: - [ ] 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. - [ ] Code coverage is suitable for any new functions/features (generally, 100% coverage for new code): `devtools::test_coverage()` - [ ] Request a reviewer Reviewer Checklist (if item does not apply, mark is as complete) - [ ] If a bug was fixed, a unit test was added. - [ ] Run `pkgdown::build_site()`. Check the R console for errors, and review the rendered website. - [ ] 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 "`# cards (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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- DESCRIPTION | 2 +- NAMESPACE | 2 +- R/ard_regression.R | 8 +- tests/testthat/_snaps/ard_chisqtest.md | 2 +- tests/testthat/_snaps/ard_kruskaltest.md | 10 +- tests/testthat/_snaps/ard_moodtest.md | 10 +- tests/testthat/_snaps/ard_proportion_ci.md | 28 +++--- tests/testthat/_snaps/ard_regression.md | 8 +- tests/testthat/_snaps/ard_ttest.md | 105 +++++++++------------ tests/testthat/test-ard_regression.R | 2 +- 10 files changed, 81 insertions(+), 96 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index bd4c44270..d2f7c1e13 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,7 +14,7 @@ BugReports: https://github.com/insightsengineering/cardx/issues Depends: R (>= 4.1) Imports: - cards (>= 0.0.0.9048), + cards (>= 0.0.0.9049), cli (>= 3.6.1), dplyr (>= 1.1.2), glue (>= 1.6.2), diff --git a/NAMESPACE b/NAMESPACE index 83c3db954..281f79855 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,8 +7,8 @@ export(any_of) export(ard_chisqtest) export(ard_fishertest) export(ard_kruskaltest) -export(ard_moodtest) export(ard_mcnemartest) +export(ard_moodtest) export(ard_paired_ttest) export(ard_paired_wilcoxtest) export(ard_proportion_ci) diff --git a/R/ard_regression.R b/R/ard_regression.R index 2b74bbbca..73a70c7ca 100644 --- a/R/ard_regression.R +++ b/R/ard_regression.R @@ -44,13 +44,13 @@ ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_ tidyr::pivot_longer( cols = -c("variable", "variable_level"), names_to = "stat_name", - values_to = "statistic" + values_to = "stat" ) |> - dplyr::filter(map_lgl(.data$statistic, Negate(is.na))) |> + dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |> dplyr::mutate( - statistic_fmt_fn = + fmt_fn = lapply( - .data$statistic, + .data$stat, function(x) { switch(is.integer(x), 0L) %||% # styler: off switch(is.numeric(x), 1L) # styler: off diff --git a/tests/testthat/_snaps/ard_chisqtest.md b/tests/testthat/_snaps/ard_chisqtest.md index 140469664..1454e47f0 100644 --- a/tests/testthat/_snaps/ard_chisqtest.md +++ b/tests/testthat/_snaps/ard_chisqtest.md @@ -5,7 +5,7 @@ by = "ARM", variable = "AGEGR1"), ard_chisqtest(data = adsl_sub, by = "SEX", variable = "AGEGR1")))) Output - ARM SEX variable context stat_name statistic + ARM SEX variable context stat_name stat 1 Overall ARM AGEGR1 chisqtest statistic 5.079442e+00 2 Overall ARM AGEGR1 chisqtest p.value 7.888842e-02 3 Overall ARM AGEGR1 chisqtest parameter 2.000000e+00 diff --git a/tests/testthat/_snaps/ard_kruskaltest.md b/tests/testthat/_snaps/ard_kruskaltest.md index 0e6df424e..14f93f68f 100644 --- a/tests/testthat/_snaps/ard_kruskaltest.md +++ b/tests/testthat/_snaps/ard_kruskaltest.md @@ -8,9 +8,9 @@ 2 ARM AGE kruskaltest p.value p-value 3 ARM AGE kruskaltest parameter Degrees of Freedom 4 ARM AGE kruskaltest method method - statistic statistic_fmt_fn warning error - 1 1.63473 1 NULL NULL - 2 0.4415937 1 NULL NULL - 3 2 1 NULL NULL - 4 Kruskal-Wallis rank sum test NULL NULL NULL + stat fmt_fn warning error + 1 1.63473 1 NULL NULL + 2 0.4415937 1 NULL NULL + 3 2 1 NULL NULL + 4 Kruskal-Wallis rank sum test NULL NULL NULL diff --git a/tests/testthat/_snaps/ard_moodtest.md b/tests/testthat/_snaps/ard_moodtest.md index 6f1890bc2..b6bb0e8c2 100644 --- a/tests/testthat/_snaps/ard_moodtest.md +++ b/tests/testthat/_snaps/ard_moodtest.md @@ -8,9 +8,9 @@ 2 SEX AGE moodtest p.value p-value 3 SEX AGE moodtest method method 4 SEX AGE moodtest alternative Alternative Hypothesis - statistic statistic_fmt_fn warning error - 1 0.1292194 1 NULL NULL - 2 0.8971841 1 NULL NULL - 3 Mood two-sample test of scale NULL NULL NULL - 4 two.sided NULL NULL NULL + stat fmt_fn warning error + 1 0.1292194 1 NULL NULL + 2 0.8971841 1 NULL NULL + 3 Mood two-sample test of scale NULL NULL NULL + 4 two.sided NULL NULL NULL diff --git a/tests/testthat/_snaps/ard_proportion_ci.md b/tests/testthat/_snaps/ard_proportion_ci.md index 7082a15a3..d7388ed0f 100644 --- a/tests/testthat/_snaps/ard_proportion_ci.md +++ b/tests/testthat/_snaps/ard_proportion_ci.md @@ -5,13 +5,13 @@ Message {cards} data frame: 6 x 8 Output - variable context stat_name stat_label statistic statistic_fmt_fn - 1 rsp proporti… N N 80 0 - 2 rsp proporti… estimate estimate 0.625 1 - 3 rsp proporti… conf.low conf.low 0.487 1 - 4 rsp proporti… conf.high conf.high 0.719 1 - 5 rsp proporti… conf.level conf.lev… 0.95 1 - 6 rsp proporti… method method Stratifi… + variable context stat_name stat_label stat fmt_fn + 1 rsp proporti… N N 80 0 + 2 rsp proporti… estimate estimate 0.625 1 + 3 rsp proporti… conf.low conf.low 0.487 1 + 4 rsp proporti… conf.high conf.high 0.719 1 + 5 rsp proporti… conf.level conf.lev… 0.95 1 + 6 rsp proporti… method method Stratifi… Message i 2 more variables: warning, error @@ -22,13 +22,13 @@ Message {cards} data frame: 6 x 8 Output - variable context stat_name stat_label statistic statistic_fmt_fn - 1 rsp proporti… N N 80 0 - 2 rsp proporti… estimate estimate 0.625 1 - 3 rsp proporti… conf.low conf.low 0.448 1 - 4 rsp proporti… conf.high conf.high 0.753 1 - 5 rsp proporti… conf.level conf.lev… 0.95 1 - 6 rsp proporti… method method Stratifi… + variable context stat_name stat_label stat fmt_fn + 1 rsp proporti… N N 80 0 + 2 rsp proporti… estimate estimate 0.625 1 + 3 rsp proporti… conf.low conf.low 0.448 1 + 4 rsp proporti… conf.high conf.high 0.753 1 + 5 rsp proporti… conf.level conf.lev… 0.95 1 + 6 rsp proporti… method method Stratifi… Message i 2 more variables: warning, error diff --git a/tests/testthat/_snaps/ard_regression.md b/tests/testthat/_snaps/ard_regression.md index 79191e34f..fd3098a04 100644 --- a/tests/testthat/_snaps/ard_regression.md +++ b/tests/testthat/_snaps/ard_regression.md @@ -2,12 +2,12 @@ Code print(dplyr::mutate(ard_regression(lm(AGE ~ ARM, data = cards::ADSL), - add_estimate_to_reference_rows = TRUE), statistic = lapply(statistic, function( - x) ifelse(is.numeric(x), cards::round5(x, 3), x))), n = Inf) + add_estimate_to_reference_rows = TRUE), stat = lapply(stat, function(x) ifelse( + is.numeric(x), cards::round5(x, 3), x))), n = Inf) Message {cards} data frame: 43 x 7 Output - variable variable_level context stat_name stat_label statistic + variable variable_level context stat_name stat_label stat 1 ARM Placebo regressi… term term ARMPlace… 2 ARM Placebo regressi… var_label Label Descript… 3 ARM Placebo regressi… var_class Class character @@ -52,5 +52,5 @@ 42 ARM Xanomeli… regressi… conf.low CI Lower… -2.039 43 ARM Xanomeli… regressi… conf.high CI Upper… 2.953 Message - i 1 more variable: statistic_fmt_fn + i 1 more variable: fmt_fn diff --git a/tests/testthat/_snaps/ard_ttest.md b/tests/testthat/_snaps/ard_ttest.md index 8b914c418..9fc30da10 100644 --- a/tests/testthat/_snaps/ard_ttest.md +++ b/tests/testthat/_snaps/ard_ttest.md @@ -3,36 +3,36 @@ Code as.data.frame(ard_ttest(cards::ADSL, by = ARM, variable = AGE, var.equal = TRUE)) Output - group1 variable context stat_name stat_label statistic - 1 ARM AGE ttest estimate Mean Difference NULL - 2 ARM AGE ttest estimate1 Group 1 Mean NULL - 3 ARM AGE ttest estimate2 Group 2 Mean NULL - 4 ARM AGE ttest statistic t Statistic NULL - 5 ARM AGE ttest p.value p-value NULL - 6 ARM AGE ttest parameter Degrees of Freedom NULL - 7 ARM AGE ttest conf.low CI Lower Bound NULL - 8 ARM AGE ttest conf.high CI Upper Bound NULL - 9 ARM AGE ttest method method NULL - 10 ARM AGE ttest alternative alternative NULL - 11 ARM AGE ttest mu H0 Mean 0 - 12 ARM AGE ttest paired Paired t-test FALSE - 13 ARM AGE ttest var.equal Equal Variances TRUE - 14 ARM AGE ttest conf.level CI Confidence Level 0.95 - statistic_fmt_fn warning error - 1 NULL NULL grouping factor must have exactly 2 levels - 2 NULL NULL grouping factor must have exactly 2 levels - 3 NULL NULL grouping factor must have exactly 2 levels - 4 NULL NULL grouping factor must have exactly 2 levels - 5 NULL NULL grouping factor must have exactly 2 levels - 6 NULL NULL grouping factor must have exactly 2 levels - 7 NULL NULL grouping factor must have exactly 2 levels - 8 NULL NULL grouping factor must have exactly 2 levels - 9 NULL NULL grouping factor must have exactly 2 levels - 10 NULL NULL grouping factor must have exactly 2 levels - 11 1 NULL grouping factor must have exactly 2 levels - 12 NULL NULL grouping factor must have exactly 2 levels - 13 NULL NULL grouping factor must have exactly 2 levels - 14 1 NULL grouping factor must have exactly 2 levels + group1 variable context stat_name stat_label stat fmt_fn warning + 1 ARM AGE ttest estimate Mean Difference NULL NULL NULL + 2 ARM AGE ttest estimate1 Group 1 Mean NULL NULL NULL + 3 ARM AGE ttest estimate2 Group 2 Mean NULL NULL NULL + 4 ARM AGE ttest statistic t Statistic NULL NULL NULL + 5 ARM AGE ttest p.value p-value NULL NULL NULL + 6 ARM AGE ttest parameter Degrees of Freedom NULL NULL NULL + 7 ARM AGE ttest conf.low CI Lower Bound NULL NULL NULL + 8 ARM AGE ttest conf.high CI Upper Bound NULL NULL NULL + 9 ARM AGE ttest method method NULL NULL NULL + 10 ARM AGE ttest alternative alternative NULL NULL NULL + 11 ARM AGE ttest mu H0 Mean 0 1 NULL + 12 ARM AGE ttest paired Paired t-test FALSE NULL NULL + 13 ARM AGE ttest var.equal Equal Variances TRUE NULL NULL + 14 ARM AGE ttest conf.level CI Confidence Level 0.95 1 NULL + error + 1 grouping factor must have exactly 2 levels + 2 grouping factor must have exactly 2 levels + 3 grouping factor must have exactly 2 levels + 4 grouping factor must have exactly 2 levels + 5 grouping factor must have exactly 2 levels + 6 grouping factor must have exactly 2 levels + 7 grouping factor must have exactly 2 levels + 8 grouping factor must have exactly 2 levels + 9 grouping factor must have exactly 2 levels + 10 grouping factor must have exactly 2 levels + 11 grouping factor must have exactly 2 levels + 12 grouping factor must have exactly 2 levels + 13 grouping factor must have exactly 2 levels + 14 grouping factor must have exactly 2 levels # ard_paired_ttest() works @@ -40,36 +40,21 @@ as.data.frame(ard_paired_ttest(dplyr::mutate(ADSL_paired, ARM = ifelse(dplyr::row_number() == 1L, "3rd ARM", ARM)), by = ARM, variable = AGE, id = USUBJID, var.equal = TRUE)) Output - group1 variable context stat_name stat_label statistic - 1 ARM AGE ttest estimate Mean Difference NULL - 2 ARM AGE ttest estimate1 Group 1 Mean NULL - 3 ARM AGE ttest estimate2 Group 2 Mean NULL - 4 ARM AGE ttest statistic t Statistic NULL - 5 ARM AGE ttest p.value p-value NULL - 6 ARM AGE ttest parameter Degrees of Freedom NULL - 7 ARM AGE ttest conf.low CI Lower Bound NULL - 8 ARM AGE ttest conf.high CI Upper Bound NULL - 9 ARM AGE ttest method method NULL - 10 ARM AGE ttest alternative alternative NULL - 11 ARM AGE ttest mu H0 Mean 0 - 12 ARM AGE ttest paired Paired t-test TRUE - 13 ARM AGE ttest var.equal Equal Variances TRUE - 14 ARM AGE ttest conf.level CI Confidence Level 0.95 - statistic_fmt_fn warning - 1 NULL NULL - 2 NULL NULL - 3 NULL NULL - 4 NULL NULL - 5 NULL NULL - 6 NULL NULL - 7 NULL NULL - 8 NULL NULL - 9 NULL NULL - 10 NULL NULL - 11 1 NULL - 12 NULL NULL - 13 NULL NULL - 14 1 NULL + group1 variable context stat_name stat_label stat fmt_fn warning + 1 ARM AGE ttest estimate Mean Difference NULL NULL NULL + 2 ARM AGE ttest estimate1 Group 1 Mean NULL NULL NULL + 3 ARM AGE ttest estimate2 Group 2 Mean NULL NULL NULL + 4 ARM AGE ttest statistic t Statistic NULL NULL NULL + 5 ARM AGE ttest p.value p-value NULL NULL NULL + 6 ARM AGE ttest parameter Degrees of Freedom NULL NULL NULL + 7 ARM AGE ttest conf.low CI Lower Bound NULL NULL NULL + 8 ARM AGE ttest conf.high CI Upper Bound NULL NULL NULL + 9 ARM AGE ttest method method NULL NULL NULL + 10 ARM AGE ttest alternative alternative NULL NULL NULL + 11 ARM AGE ttest mu H0 Mean 0 1 NULL + 12 ARM AGE ttest paired Paired t-test TRUE NULL NULL + 13 ARM AGE ttest var.equal Equal Variances TRUE NULL NULL + 14 ARM AGE ttest conf.level CI Confidence Level 0.95 1 NULL error 1 The `by` argument must have two and only two levels. 2 The `by` argument must have two and only two levels. diff --git a/tests/testthat/test-ard_regression.R b/tests/testthat/test-ard_regression.R index 392532b50..5450fd6c8 100644 --- a/tests/testthat/test-ard_regression.R +++ b/tests/testthat/test-ard_regression.R @@ -3,7 +3,7 @@ test_that("ard_regression() works", { lm(AGE ~ ARM, data = cards::ADSL) |> ard_regression(add_estimate_to_reference_rows = TRUE) |> dplyr::mutate( - statistic = lapply(statistic, function(x) ifelse(is.numeric(x), cards::round5(x, 3), x)) + stat = lapply(stat, function(x) ifelse(is.numeric(x), cards::round5(x, 3), x)) ) |> print(n = Inf) ) From c50ecfd6c6292bf90247787ab6c94bd66725e2b2 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Wed, 21 Feb 2024 20:44:42 +0000 Subject: [PATCH 09/11] [skip actions] Bump version to 0.0.0.9042 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d2f7c1e13..895891f2e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.0.0.9041 +Version: 0.0.0.9042 Authors@R: c( person("Daniel", "Sjoberg", , "sjobergd@gene.com", role = c("aut", "cre")), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")) diff --git a/NEWS.md b/NEWS.md index c1b0e2448..80a2429f8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.0.0.9041 +# cardx 0.0.0.9042 ### New Features * New package! From d74c53b056ac3d4258c7c9bad419dea42ebe873b Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 23 Feb 2024 08:07:09 -0800 Subject: [PATCH 10/11] Updating checks file (#60) **What changes are proposed in this pull request?** * Style this entry in a way that can be copied directly into `NEWS.md`. (#, @) Provide more detail here as needed. **Reference GitHub issue associated with pull request.** _e.g., 'closes #'_ -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [ ] **All** GitHub Action workflows pass with a :white_check_mark: - [ ] 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. - [ ] Code coverage is suitable for any new functions/features (generally, 100% coverage for new code): `devtools::test_coverage()` - [ ] Request a reviewer Reviewer Checklist (if item does not apply, mark is as complete) - [ ] If a bug was fixed, a unit test was added. - [ ] Run `pkgdown::build_site()`. Check the R console for errors, and review the rendered website. - [ ] 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 "`# cards (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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- R/ard_chisqtest.R | 2 +- R/ard_fishertest.R | 2 +- R/ard_kruskaltest.R | 2 +- R/ard_mcnemartest.R | 2 +- R/ard_moodtest.R | 2 +- R/ard_ttest.R | 4 +- R/ard_wilcoxtest.R | 4 +- R/import-standalone-checks.R | 337 +++++++++++++++++++++---- R/proportion_ci.R | 18 +- tests/testthat/_snaps/proportion_ci.md | 4 +- 10 files changed, 312 insertions(+), 65 deletions(-) diff --git a/R/ard_chisqtest.R b/R/ard_chisqtest.R index 4528d83e8..c112be146 100644 --- a/R/ard_chisqtest.R +++ b/R/ard_chisqtest.R @@ -25,7 +25,7 @@ ard_chisqtest <- function(data, by, variable, ...) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) check_scalar(variable) diff --git a/R/ard_fishertest.R b/R/ard_fishertest.R index 04f7f5ff0..e7f8800e0 100644 --- a/R/ard_fishertest.R +++ b/R/ard_fishertest.R @@ -25,7 +25,7 @@ ard_fishertest <- function(data, by, variable, ...) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) check_scalar(variable) diff --git a/R/ard_kruskaltest.R b/R/ard_kruskaltest.R index 6e21453bf..944dd2ad4 100644 --- a/R/ard_kruskaltest.R +++ b/R/ard_kruskaltest.R @@ -26,7 +26,7 @@ ard_kruskaltest <- function(data, by, variable) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) check_scalar(variable) diff --git a/R/ard_mcnemartest.R b/R/ard_mcnemartest.R index 168a8f51c..2e3ffeace 100644 --- a/R/ard_mcnemartest.R +++ b/R/ard_mcnemartest.R @@ -35,7 +35,7 @@ ard_mcnemartest <- function(data, by, variable, ...) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) diff --git a/R/ard_moodtest.R b/R/ard_moodtest.R index f1d11dde2..dbce77559 100644 --- a/R/ard_moodtest.R +++ b/R/ard_moodtest.R @@ -32,7 +32,7 @@ ard_moodtest <- function(data, by, variable, ...) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) diff --git a/R/ard_ttest.R b/R/ard_ttest.R index f3e889b64..6dfcadff1 100644 --- a/R/ard_ttest.R +++ b/R/ard_ttest.R @@ -50,7 +50,7 @@ ard_ttest <- function(data, by, variable, ...) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) @@ -81,7 +81,7 @@ ard_paired_ttest <- function(data, by, variable, id, ...) { check_not_missing(variable) check_not_missing(by) check_not_missing(id) - check_class_data_frame(x = data) + check_data_frame(data) data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}, id = {{ id }}) check_scalar(by) diff --git a/R/ard_wilcoxtest.R b/R/ard_wilcoxtest.R index 071c77ba8..f02f614db 100644 --- a/R/ard_wilcoxtest.R +++ b/R/ard_wilcoxtest.R @@ -50,7 +50,7 @@ ard_wilcoxtest <- function(data, by, variable, ...) { check_not_missing(data) check_not_missing(variable) check_not_missing(by) - check_class_data_frame(x = data) + check_data_frame(data) data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}) check_scalar(by) @@ -81,7 +81,7 @@ ard_paired_wilcoxtest <- function(data, by, variable, id, ...) { check_not_missing(variable) check_not_missing(by) check_not_missing(id) - check_class_data_frame(x = data) + check_data_frame(data) data <- dplyr::ungroup(data) cards::process_selectors(data, by = {{ by }}, variable = {{ variable }}, id = {{ id }}) check_scalar(by) diff --git a/R/import-standalone-checks.R b/R/import-standalone-checks.R index 8fdc5896a..252cb1048 100644 --- a/R/import-standalone-checks.R +++ b/R/import-standalone-checks.R @@ -2,7 +2,6 @@ # Source: # ---------------------------------------------------------------------- # -# DO NOT MODIFY THIS FILE. INSTEAD MODIFY THE VERSION IN https://github.com/ddsjoberg/standalone/tree/main/R # --- # repo: ddsjoberg/standalone # file: standalone-checks.R @@ -20,31 +19,46 @@ #' Check Class #' -#' @param class (`character`)\cr +#' @param cls (`character`)\cr #' character vector or string indicating accepted classes. -#' Passed to `inherits(what=class)` +#' Passed to `inherits(what=cls)` #' @param x `(object)`\cr #' object to check -#' @param allow_null (`logical(1)`)\cr -#' Logical indicating whether a NULL value will pass the test. +#' @param message (`character`)\cr +#' string passed to `cli::cli_abort(message)` +#' @param allow_empty (`logical(1)`)\cr +#' Logical indicating whether an empty value will pass the test. #' Default is `FALSE` #' @param arg_name (`string`)\cr #' string indicating the label/symbol of the object being checked. #' Default is `rlang::caller_arg(x)` #' @inheritParams cli::cli_abort +#' @inheritParams rlang::abort #' @keywords internal #' @noRd -check_class <- function(x, class, allow_null = FALSE, - arg_name = rlang::caller_arg(x), call = parent.frame()) { - # include NULL class as acceptable if allow_null is TRUE - if (isTRUE(allow_null) && is.null(x)) { - return(invisible()) +check_class <- function(x, + cls, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_class", + call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible(x)) } - if (!inherits(x, class)) { - cli::cli_abort("The {.arg {arg_name}} argument must be class {.cls {class}}.", call = call) + if (!inherits(x, cls)) { + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) } #' Check Class Data Frame @@ -52,11 +66,108 @@ check_class <- function(x, class, allow_null = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_class_data_frame <- function(x, allow_null = FALSE, - arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_data_frame <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_data_frame", + call = parent.frame()) { + check_class( + x = x, cls = "data.frame", allow_empty = allow_empty, + message = message, arg_name = arg_name, class = class, call = call + ) +} + +#' Check Class Logical +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_logical <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_logical", + call = parent.frame()) { + check_class( + x = x, cls = "logical", allow_empty = allow_empty, + message = message, arg_name = arg_name, class = class, call = call + ) +} + +#' Check Class Logical and Scalar +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_scalar_logical <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be a scalar with class + {.cls {cls}} or empty, not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be a scalar with class + {.cls {cls}}, not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_scalar_logical", + call = parent.frame()) { + check_logical( + x = x, allow_empty = allow_empty, + message = message, arg_name = arg_name, + class = class, call = call + ) + + check_scalar( + x = x, allow_empty = allow_empty, + message = message, arg_name = arg_name, + call = call + ) +} + +#' Check String +#' +#' @inheritParams check_class +#' @keywords internal +#' @noRd +check_string <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be a string or empty, + not {.obj_type_friendly {x}}.", + "The {.arg {arg_name}} argument must be a string, + not {.obj_type_friendly {x}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_string", + call = parent.frame()) { check_class( - x = x, class = "data.frame", allow_null = allow_null, - arg_name = arg_name, call = call + x = x, cls = "character", allow_empty = allow_empty, + message = message, arg_name = arg_name, + class = class, call = call + ) + + check_scalar( + x = x, allow_empty = allow_empty, + message = message, arg_name = arg_name, + class = class, call = call ) } @@ -65,38 +176,71 @@ check_class_data_frame <- function(x, allow_null = FALSE, #' @inheritParams check_class #' @keywords internal #' @noRd -check_not_missing <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_not_missing <- function(x, + message = "The {.arg {arg_name}} argument cannot be missing.", + arg_name = rlang::caller_arg(x), + class = "check_not_missing", + call = parent.frame()) { if (missing(x)) { - cli::cli_abort("The {.arg {arg_name}} argument cannot be missing.", call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } + + # can't return 'x' because it may be an unevaluable obj, eg a bare tidyselect invisible() } #' Check Length #' -#' @param msg (`string`)\cr -#' string passed to `cli::cli_abort(message=)` #' @param length (`integer(1)`)\cr #' integer specifying the required length #' @inheritParams check_class #' @keywords internal #' @noRd -check_length <- function(x, length, arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_length <- function(x, length, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", + "The {.arg {arg_name}} argument must be length {.val {length}}." + ), + allow_empty = FALSE, + arg_name = rlang::caller_arg(x), + class = "check_length", + call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible(x)) + } + + # check length if (length(x) != length) { - cli::cli_abort("The {.arg {arg_name}} argument must be length {.val {length}}.", call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + + invisible(x) } #' Check is Scalar #' -#' @param msg (`string`)\cr -#' string passed to `cli::cli_abort(message=)` #' @inheritParams check_class #' @keywords internal #' @noRd -check_scalar <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { - check_length(x = x, length = 1L, arg_name = arg_name, call = call) +check_scalar <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be length {.val {length}} or empty.", + "The {.arg {arg_name}} argument must be length {.val {length}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_scalar", + call = parent.frame()) { + check_length( + x = x, length = 1L, message = message, + allow_empty = allow_empty, arg_name = arg_name, + class = class, call = call + ) } #' Check Range @@ -105,8 +249,7 @@ check_scalar <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame #' @param range numeric vector of length two #' @param include_bounds logical of length two indicating whether to allow #' the lower and upper bounds -#' @param scalar logical indicating whether `x` must be a scalar -#' @param msg string passed to `cli::cli_abort(message=)` +#' @inheritParams check_class #' #' @return invisible #' @keywords internal @@ -114,16 +257,17 @@ check_scalar <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame check_range <- function(x, range, include_bounds = c(FALSE, FALSE), + message = + "The {.arg {arg_name}} argument must be in the interval + {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, + {range[2]}{ifelse(include_bounds[2], ']', ')')}}.", + allow_empty = FALSE, arg_name = rlang::caller_arg(x), - scalar = FALSE, - msg = paste( - "The {.arg {arg_name}} argument must be in the interval", - "{.code {ifelse(include_bounds[1], '[', '(')}{range[1]},", - "{range[2]}{ifelse(include_bounds[2], ']', ')')}}." - ), + class = "check_range", call = parent.frame()) { - if (isTRUE(scalar)) { - check_scalar(x, arg_name = arg_name) + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible(x)) } print_error <- FALSE @@ -150,12 +294,42 @@ check_range <- function(x, # print error if (print_error) { - cli::cli_abort(msg, call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) } +#' Check Scalar Range +#' +#' @param x numeric scalar to check +#' @param range numeric vector of length two +#' @param include_bounds logical of length two indicating whether to allow +#' the lower and upper bounds +#' @inheritParams check_class +#' +#' @return invisible +#' @keywords internal +#' @noRd +check_scalar_range <- function(x, + range, + include_bounds = c(FALSE, FALSE), + allow_empty = FALSE, + message = + "The {.arg {arg_name}} argument must be in the interval + {.code {ifelse(include_bounds[1], '[', '(')}{range[1]}, + {range[2]}{ifelse(include_bounds[2], ']', ')')}} + and length {.val {1}}.", + arg_name = rlang::caller_arg(x), + class = "check_scalar_range", + call = parent.frame()) { + check_scalar(x, message = message, arg_name = arg_name, + allow_empty = allow_empty, class = class, call = call) + + check_range(x = x, range = range, include_bounds = include_bounds, + message = message, allow_empty = allow_empty, + arg_name = arg_name, class = class, call = call) +} #' Check Binary #' @@ -164,21 +338,88 @@ check_range <- function(x, #' `` and coded as `c(0, 1)` #' #' @param x a vector -#' @param call call environment +#' @inheritParams check_class #' #' @return invisible #' @keywords internal #' @noRd -check_binary <- function(x, arg_name = rlang::caller_arg(x), call = parent.frame()) { +check_binary <- function(x, + allow_empty = FALSE, + message = + ifelse( + allow_empty, + "Expecting {.arg {arg_name}} to be either {.cls logical}, + {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}, or empty.", + "Expecting {.arg {arg_name}} to be either {.cls logical} + or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}." + ), + arg_name = rlang::caller_arg(x), + class = "check_binary", + call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible(x)) + } + + # first check x is either logical or numeric + check_class(x, cls = c("logical", "numeric", "integer"), + arg_name = arg_name, message = message, class = class, call = call) + + # if "numeric" or "integer", it must be coded as 0, 1 if (!is.logical(x) && !(rlang::is_integerish(x) && rlang::is_empty(setdiff(x, c(0, 1, NA))))) { - paste( - "Expecting column {.arg {arg_name}} to be either {.cls logical}", - "or {.cls {c('numeric', 'integer')}} coded as {.val {c(0, 1)}}." - ) |> - cli::cli_abort(call = call) + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) } - invisible() + invisible(x) +} + + +#' Check Formula-List Selector +#' +#' Checks the structure of the formula-list selector used throughout the +#' cards, cardx, and gtsummary packages. +#' +#' @param x formula-list selecting object +#' @inheritParams check_class +#' +#' @return invisible +#' @keywords internal +#' @noRd +check_formula_list_selector <- function(x, + allow_empty = FALSE, + message = + c( + ifelse( + allow_empty, + "The {.arg {arg_name}} argument must be a named list, list of formulas, a single formula, or empty.", + "The {.arg {arg_name}} argument must be a named list, list of formulas, or a single formula." + ), + "i" = "Review {.help [?syntax](cards::syntax)} for examples and details." + ), + arg_name = rlang::caller_arg(x), + class = "check_formula_list_selector", + call = parent.frame()) { + # if empty, skip test + if (isTRUE(allow_empty) && rlang::is_empty(x)) { + return(invisible(x)) + } + + # first check the general structure; must be a list or formula + check_class( + x = x, cls = c("list", "formula"), allow_empty = allow_empty, + message = message, arg_name = arg_name, class = class, call = call + ) + + # if it's a list, then check each element is either named or a formula + if (inherits(x, "list")) { + for (i in seq_along(x)) { + if (!rlang::is_named(x[i]) && !inherits(x[[i]], "formula")) { + cli::cli_abort(message, class = c(class, "standalone-checks"), call = call) + } + } + } + + invisible(x) } # nocov end diff --git a/R/proportion_ci.R b/R/proportion_ci.R index 961b74594..059e3d071 100644 --- a/R/proportion_ci.R +++ b/R/proportion_ci.R @@ -30,7 +30,8 @@ proportion_ci_wald <- function(x, conf.level = 0.95, correct = FALSE) { # check inputs --------------------------------------------------------------- check_not_missing(x) check_binary(x) - check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE), scalar = TRUE) + check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) + check_scalar(conf.level) check_class(x = correct, "logical") check_scalar(correct) @@ -69,7 +70,8 @@ proportion_ci_wilson <- function(x, conf.level = 0.95, correct = FALSE) { check_binary(x) check_class(x = correct, "logical") check_scalar(correct) - check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE), scalar = TRUE) + check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) + check_scalar(conf.level) x <- stats::na.omit(x) @@ -94,7 +96,8 @@ proportion_ci_clopper_pearson <- function(x, conf.level = 0.95) { # check inputs --------------------------------------------------------------- check_not_missing(x) check_binary(x) - check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE), scalar = TRUE) + check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) + check_scalar(conf.level) x <- stats::na.omit(x) n <- length(x) @@ -113,7 +116,8 @@ proportion_ci_agresti_coull <- function(x, conf.level = 0.95) { # check inputs --------------------------------------------------------------- check_not_missing(x) check_binary(x) - check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE), scalar = TRUE) + check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) + check_scalar(conf.level) x <- stats::na.omit(x) @@ -149,7 +153,8 @@ proportion_ci_jeffreys <- function(x, conf.level = 0.95) { # check inputs --------------------------------------------------------------- check_not_missing(x) check_binary(x) - check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE), scalar = TRUE) + check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) + check_scalar(conf.level) x <- stats::na.omit(x) n <- length(x) @@ -232,7 +237,8 @@ proportion_ci_strat_wilson <- function(x, check_class(correct, "logical") check_scalar(correct) check_class(strata, "factor") - check_range(conf.level, range = c(0, 1), scalar = TRUE) + check_range(conf.level, range = c(0, 1), include_bounds = c(FALSE, FALSE)) + check_scalar(conf.level) # remove missing values from x and strata is_na <- is.na(x) | is.na(strata) diff --git a/tests/testthat/_snaps/proportion_ci.md b/tests/testthat/_snaps/proportion_ci.md index 5e9f0732e..42232bc36 100644 --- a/tests/testthat/_snaps/proportion_ci.md +++ b/tests/testthat/_snaps/proportion_ci.md @@ -513,7 +513,7 @@ Code proportion_ci_wilson(x_dbl, conf.level = c(0.9, 0.9)) Condition - Error in `check_range()`: + Error in `proportion_ci_wilson()`: ! The `conf.level` argument must be length 1. --- @@ -522,7 +522,7 @@ proportion_ci_wilson(mtcars$cyl) Condition Error in `proportion_ci_wilson()`: - ! Expecting column `x` to be either or coded as 0 and 1. + ! Expecting `x` to be either or coded as 0 and 1. # check the proportion_ci_strat_wilson() function works From 96591506eaa393a03fb174582fa22dd9e002677a Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Fri, 23 Feb 2024 16:07:59 +0000 Subject: [PATCH 11/11] [skip actions] Bump version to 0.0.0.9043 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 895891f2e..0adfbd47a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.0.0.9042 +Version: 0.0.0.9043 Authors@R: c( person("Daniel", "Sjoberg", , "sjobergd@gene.com", role = c("aut", "cre")), person("F. Hoffmann-La Roche AG", role = c("cph", "fnd")) diff --git a/NEWS.md b/NEWS.md index 80a2429f8..886bf70c9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.0.0.9042 +# cardx 0.0.0.9043 ### New Features * New package!