From 0c5fd0b502ea07940054aef21d34b16eecd0679d Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 19 Apr 2024 10:02:53 -0700 Subject: [PATCH 01/14] Adding model construction helpers (#121) **What changes are proposed in this pull request?** * Adding functions to assist in constructing models `construct_model()`, `reformulate2()` (similar to `stats::reformulate()` but adds backticks around variable names with spaces in them), `bt()` (adds backtics to variable as needed), and `bt_strip()` (removes backticks from character variable names). I also updated `ard_survey_svychisq()` to use `reformulate2()` instead of `stats::reformulate()` which allows variable names with spaces in them. Other instances of `stats::reformulate()` should also be updated in the future. The reason we're adding the constructors is because the full ARS (Analysis Result Standard) requires that we begin with a data frame, and these help us take a data frame, a response variable, and covariates to construct complex models. **Reference GitHub issue associated with pull request.** _e.g., 'closes #'_ closes #108 -------------------------------------------------------------------------------- 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] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`. - [x] 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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --------- Co-authored-by: Davide Garolini --- NAMESPACE | 5 + R/ard_stats_anova.R | 84 ++++------ R/ard_survey_svychisq.R | 2 +- R/construction_helpers.R | 146 ++++++++++++++++++ _pkgdown.yml | 1 + inst/WORDLIST | 2 + man/ard_stats_anova.Rd | 28 ++-- man/construction_helpers.Rd | 112 ++++++++++++++ tests/testthat/_snaps/construction_helpers.md | 15 ++ tests/testthat/test-ard_stats_anova.R | 29 ++-- tests/testthat/test-ard_survey_svychisq.R | 16 ++ tests/testthat/test-construction_helpers.R | 30 ++++ 12 files changed, 390 insertions(+), 80 deletions(-) create mode 100644 R/construction_helpers.R create mode 100644 man/construction_helpers.Rd create mode 100644 tests/testthat/_snaps/construction_helpers.md create mode 100644 tests/testthat/test-construction_helpers.R diff --git a/NAMESPACE b/NAMESPACE index b2033afd1..282c4efb4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ S3method(ard_regression,default) S3method(ard_stats_anova,anova) S3method(ard_stats_anova,data.frame) +S3method(construct_model,data.frame) export("%>%") export(all_of) export(any_of) @@ -36,6 +37,9 @@ export(ard_survey_svyranktest) export(ard_survey_svyttest) export(ard_survival_survdiff) export(ard_survival_survfit) +export(bt) +export(bt_strip) +export(construct_model) export(contains) export(ends_with) export(everything) @@ -49,6 +53,7 @@ export(proportion_ci_jeffreys) export(proportion_ci_strat_wilson) export(proportion_ci_wald) export(proportion_ci_wilson) +export(reformulate2) export(starts_with) export(where) import(rlang) diff --git a/R/ard_stats_anova.R b/R/ard_stats_anova.R index 4e4ef5f23..1019d7757 100644 --- a/R/ard_stats_anova.R +++ b/R/ard_stats_anova.R @@ -10,21 +10,13 @@ #' a data frame #' @param formulas (`list`)\cr #' a list of formulas -#' @param fn (`string`)\cr -#' string naming the function to be called, e.g. `"glm"`. -#' If function belongs to a library that is not attached, the package name -#' must be specified in the `package` argument. -#' @param fn.args (named `list`)\cr -#' named list of arguments that will be passed to `fn`. -#' @param package (`string`)\cr -#' string of package name that will be temporarily loaded when function -#' specified in `method` is executed. -#' @param method (`string`)\cr +#' @param method_text (`string`)\cr #' string of the method used. Default is `"ANOVA results from `stats::anova()`"`. #' We provide the option to change this as `stats::anova()` can produce #' results from many types of models that may warrant a more precise #' description. #' @inheritParams rlang::args_dots_empty +#' @inheritParams construction_helpers #' #' @details #' When a list of formulas is supplied to `ard_stats_anova()`, these formulas @@ -34,12 +26,12 @@ #' The models are constructed using `rlang::exec()`, which is similar to `do.call()`. #' #' ```r -#' rlang::exec(.fn = fn, formula = formula, data = data, !!!fn.args) +#' rlang::exec(.fn = method, formula = formula, data = data, !!!method.args) #' ``` #' #' The above function is executed in `withr::with_namespace(package)`, which -#' allows for the use of `ard_stats_anova(fn)` from packages, -#' e.g. `package = 'lme4'` must be specified when `fn = 'glmer'`. +#' allows for the use of `ard_stats_anova(method)` from packages, +#' e.g. `package = 'lme4'` must be specified when `method = 'glmer'`. #' See example below. #' #' @return ARD data frame @@ -55,15 +47,15 @@ #' ard_stats_anova( #' x = mtcars, #' formulas = list(am ~ mpg, am ~ mpg + hp), -#' fn = "glm", -#' fn.args = list(family = binomial) +#' method = "glm", +#' method.args = list(family = binomial) #' ) #' #' ard_stats_anova( #' x = mtcars, #' formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)), -#' fn = "glmer", -#' fn.args = list(family = binomial), +#' method = "glmer", +#' method.args = list(family = binomial), #' package = "lme4" #' ) NULL @@ -76,22 +68,22 @@ ard_stats_anova <- function(x, ...) { #' @rdname ard_stats_anova #' @export -ard_stats_anova.anova <- function(x, method = "ANOVA results from `stats::anova()`", ...) { +ard_stats_anova.anova <- function(x, method_text = "ANOVA results from `stats::anova()`", ...) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_dots_empty() check_pkg_installed("broom", reference_pkg = "cardx") - check_string(method, message = "Argument {.arg method} must be a string of a function name.") + check_string(method_text) # return df in cards formats ------------------------------------------------- lst_results <- cards::eval_capture_conditions( - .anova_tidy_and_reshape(x, method = method) + .anova_tidy_and_reshape(x, method_text = method_text) ) # final tidying up of cards data frame --------------------------------------- - .anova_final_ard_prep(lst_results, method = method) + .anova_final_ard_prep(lst_results, method_text = method_text) } @@ -99,37 +91,29 @@ ard_stats_anova.anova <- function(x, method = "ANOVA results from `stats::anova( #' @export ard_stats_anova.data.frame <- function(x, formulas, - fn, - fn.args = list(), + method, + method.args = list(), package = "base", - method = "ANOVA results from `stats::anova()`", + method_text = "ANOVA results from `stats::anova()`", ...) { set_cli_abort_call() # check inputs --------------------------------------------------------------- check_dots_empty() - check_string(package) check_pkg_installed(c("broom", "withr", package), reference_pkg = "cardx") check_not_missing(formulas) - check_not_missing(x) - check_not_missing(fn) - check_string(method, message = "Argument {.arg method} must be a string of a function name.") - check_data_frame(x) - check_string(fn) - if (str_detect(fn, "::")) { - cli::cli_abort( - c( - "Argument {.arg fn} cannot be namespaced.", - i = "Put the package name in the {.arg package} argument." - ), - call = get_cli_abort_call() + check_class(formulas, cls = "list") + walk( + formulas, + ~ check_class( + .x, + cls = "formula", + arg_name = "formulas", + message = "Each element of {.arg formulas} must be class {.cls formula}" ) - } + ) # calculate results and return df in cards formats --------------------------- - # process fn.args argument - fn.args <- rlang::call_args(rlang::enexpr(fn.args)) - # create models lst_results <- cards::eval_capture_conditions({ @@ -138,24 +122,20 @@ ard_stats_anova.data.frame <- function(x, lapply( formulas, function(formula) { - withr::with_namespace( - package = package, - call2(.fn = fn, formula = formula, data = x, !!!fn.args) |> - eval_tidy() - ) + construct_model(x = x, formula = formula, method = method, method.args = {{ method.args }}, package = package) } ) # now calculate `stats::anova()` and reshape results rlang::inject(stats::anova(!!!models)) |> - .anova_tidy_and_reshape(method = method) + .anova_tidy_and_reshape(method_text = method_text) }) # final tidying up of cards data frame --------------------------------------- - .anova_final_ard_prep(lst_results, method = method) + .anova_final_ard_prep(lst_results, method_text = method_text) } -.anova_tidy_and_reshape <- function(x, method) { +.anova_tidy_and_reshape <- function(x, method_text) { broom::tidy(x) |> dplyr::mutate( across(everything(), as.list), @@ -174,13 +154,13 @@ ard_stats_anova.data.frame <- function(x, dplyr::filter(., dplyr::n() == dplyr::row_number()) |> dplyr::mutate( stat_name = "method", - stat = list(.env$method) + stat = list(.env$method_text) ) ) } } -.anova_final_ard_prep <- function(lst_results, method) { +.anova_final_ard_prep <- function(lst_results, method_text) { # saving the results in data frame ------------------------------------------- df_card <- if (!is.null(lst_results[["result"]])) { @@ -189,7 +169,7 @@ ard_stats_anova.data.frame <- function(x, dplyr::tibble( variable = "model_1", stat_name = c("p.value", "method"), - stat = list(NULL, method) + stat = list(NULL, method_text) ) } diff --git a/R/ard_survey_svychisq.R b/R/ard_survey_svychisq.R index f5c092c99..8fb57325f 100644 --- a/R/ard_survey_svychisq.R +++ b/R/ard_survey_svychisq.R @@ -50,7 +50,7 @@ ard_survey_svychisq <- function(data, by, variables, statistic = "F", ...) { cards::tidy_as_ard( lst_tidy = cards::eval_capture_conditions( - survey::svychisq(stats::reformulate(termlabels = paste(variable, by, sep = "+"), response = NULL), design = data, statistic = statistic, ...) |> + survey::svychisq(reformulate2(termlabels = c(variable, by)), design = data, statistic = statistic, ...) |> broom::tidy() ), tidy_result_names = c("statistic", "p.value", "ndf", "ddf", "method"), diff --git a/R/construction_helpers.R b/R/construction_helpers.R new file mode 100644 index 000000000..144f8a7cf --- /dev/null +++ b/R/construction_helpers.R @@ -0,0 +1,146 @@ +#' Construction Helpers +#' +#' These functions help construct calls to various types of models. +#' +#' - `construct_model()`: Builds models of the form `method(data = data, formula = formula, method.args!!!)`. +#' If the `package` argument is specified, that package is temporarily attached +#' when the model is evaluated. +#' +#' - `reformulate2()`: This is a copy of `reformulate()` except that variable +#' names that contain a space are wrapped in backticks. +#' +#' - `bt()`: Adds backticks to a character vector. +#' +#' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick. +#' +#' @param x (`data.frame`)\cr +#' a data frame +#' @param formula (`formula`)\cr +#' a formula +#' @param method (`string`)\cr +#' string naming the function to be called, e.g. `"glm"`. +#' If function belongs to a library that is not attached, the package name +#' must be specified in the `package` argument. +#' @param method.args (named `list`)\cr +#' named list of arguments that will be passed to `fn`. +#' @param package (`string`)\cr +#' string of package name that will be temporarily loaded when function +#' specified in `method` is executed. +#' @param x (`character`)\cr +#' character vector, typically of variable names +#' @param pattern (`string`)\cr +#' regular expression string. If the regex matches, backticks are added +#' to the string. When `NULL`, backticks are not added. +#' @param pattern_term,pattern_response passed to `bt(pattern)` for arguments +#' `stats::reformulate(termlabels, response)`. +#' @inheritParams rlang::eval_tidy +#' @inheritParams stats::reformulate +#' @inheritParams rlang::args_dots_empty +#' +#' @return depends on the calling function +#' @name construction_helpers +#' +#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx")) +#' construct_model( +#' x = mtcars, +#' formula = am ~ mpg + (1 | vs), +#' method = "glmer", +#' method.args = list(family = binomial), +#' package = "lme4" +#' ) +#' +#' construct_model( +#' x = mtcars |> dplyr::rename(`M P G` = mpg), +#' formula = reformulate2(c("M P G", "cyl"), response = "hp"), +#' method = "lm" +#' ) |> +#' ard_regression() |> +#' dplyr::filter(stat_name %in% c("term", "estimate", "p.value")) +NULL + +#' @rdname construction_helpers +#' @export +construct_model <- function(x, ...) { + UseMethod("construct_model") +} + +#' @rdname construction_helpers +#' @export +construct_model.data.frame <- function(x, formula, method, method.args = list(), package = "base", env = caller_env(), ...) { + set_cli_abort_call() + # check pkg installations ---------------------------------------------------- + check_dots_empty() + check_pkg_installed(c("withr", package), reference_pkg = "cardx") + + check_not_missing(formula) + check_class(formula, cls = "formula") + + check_not_missing(method) + check_string(method) + check_not_namespaced(method) + + # convert method.args to list of expressions (to account for NSE inputs) ----- + method.args <- call_args(enexpr(method.args)) + + # build model ---------------------------------------------------------------- + withr::with_namespace( + package = package, + call2(.fn = method, formula = formula, data = x, !!!method.args) |> + eval_tidy(env = env) + ) +} + +#' @rdname construction_helpers +#' @export +reformulate2 <- function(termlabels, response = NULL, intercept = TRUE, + pattern_term = "[ \n\r]", pattern_response = "[ \n\r]", + env = parent.frame()) { + stats::reformulate( + termlabels = bt(termlabels, pattern_term), + response = bt(response, pattern_response), + intercept = intercept, + env = env + ) +} + +#' @rdname construction_helpers +#' @export +bt <- function(x, pattern = "[ \n\r]") { + if (is_empty(x)) { + return(x) + } + if (is_empty(pattern)) { + return(x) + } + ifelse( + str_detect(x, pattern = pattern), + paste0("`", x, "`"), + x + ) +} + +#' @rdname construction_helpers +#' @export +bt_strip <- function(x) { + ifelse( + str_detect(x, "^`.*`$"), + substr(x, 2, nchar(x) - 1), + x + ) +} + +check_not_namespaced <- function(x, + arg_name = rlang::caller_arg(x), + class = "check_not_namespaced", + call = get_cli_abort_call()) { + check_string(x, arg_name = arg_name, call = call, class = "check_not_namespaced") + + if (str_detect(x, "::")) { + c("Argument {.arg {arg_name}} cannot be namespaced.", + i = "Put the package name in the {.arg package} argument." + ) |> + cli::cli_abort(call = call, class = class) + } + + invisible(x) +} diff --git a/_pkgdown.yml b/_pkgdown.yml index a6cd431cf..9dace7a4a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -57,3 +57,4 @@ reference: - title: "Helpers" - contents: - proportion_ci + - construction_helpers diff --git a/inst/WORDLIST b/inst/WORDLIST index 4b9ae88ff..9ffe51b9f 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -18,6 +18,7 @@ XG Xin agresti anova +backtick cli clopper coull @@ -27,6 +28,7 @@ funder jeffreys pearson pre +quosures sd strat vif diff --git a/man/ard_stats_anova.Rd b/man/ard_stats_anova.Rd index 9e71a91df..c2ec37b56 100644 --- a/man/ard_stats_anova.Rd +++ b/man/ard_stats_anova.Rd @@ -8,15 +8,15 @@ \usage{ ard_stats_anova(x, ...) -\method{ard_stats_anova}{anova}(x, method = "ANOVA results from `stats::anova()`", ...) +\method{ard_stats_anova}{anova}(x, method_text = "ANOVA results from `stats::anova()`", ...) \method{ard_stats_anova}{data.frame}( x, formulas, - fn, - fn.args = list(), + method, + method.args = list(), package = "base", - method = "ANOVA results from `stats::anova()`", + method_text = "ANOVA results from `stats::anova()`", ... ) } @@ -27,7 +27,7 @@ a data frame} \item{...}{These dots are for future extensions and must be empty.} -\item{method}{(\code{string})\cr +\item{method_text}{(\code{string})\cr string of the method used. Default is \verb{"ANOVA results from }stats::anova()\verb{"}. We provide the option to change this as \code{stats::anova()} can produce results from many types of models that may warrant a more precise @@ -36,12 +36,12 @@ description.} \item{formulas}{(\code{list})\cr a list of formulas} -\item{fn}{(\code{string})\cr +\item{method}{(\code{string})\cr string naming the function to be called, e.g. \code{"glm"}. If function belongs to a library that is not attached, the package name must be specified in the \code{package} argument.} -\item{fn.args}{(named \code{list})\cr +\item{method.args}{(named \code{list})\cr named list of arguments that will be passed to \code{fn}.} \item{package}{(\code{string})\cr @@ -64,12 +64,12 @@ and pass those models to \code{stats::anova()}. The models are constructed using \code{rlang::exec()}, which is similar to \code{do.call()}. -\if{html}{\out{
}}\preformatted{rlang::exec(.fn = fn, formula = formula, data = data, !!!fn.args) +\if{html}{\out{
}}\preformatted{rlang::exec(.fn = method, formula = formula, data = data, !!!method.args) }\if{html}{\out{
}} The above function is executed in \code{withr::with_namespace(package)}, which -allows for the use of \code{ard_stats_anova(fn)} from packages, -e.g. \code{package = 'lme4'} must be specified when \code{fn = 'glmer'}. +allows for the use of \code{ard_stats_anova(method)} from packages, +e.g. \code{package = 'lme4'} must be specified when \code{method = 'glmer'}. See example below. } \examples{ @@ -83,15 +83,15 @@ anova( ard_stats_anova( x = mtcars, formulas = list(am ~ mpg, am ~ mpg + hp), - fn = "glm", - fn.args = list(family = binomial) + method = "glm", + method.args = list(family = binomial) ) ard_stats_anova( x = mtcars, formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)), - fn = "glmer", - fn.args = list(family = binomial), + method = "glmer", + method.args = list(family = binomial), package = "lme4" ) \dontshow{\}) # examplesIf} diff --git a/man/construction_helpers.Rd b/man/construction_helpers.Rd new file mode 100644 index 000000000..fb00d9537 --- /dev/null +++ b/man/construction_helpers.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/construction_helpers.R +\name{construction_helpers} +\alias{construction_helpers} +\alias{construct_model} +\alias{construct_model.data.frame} +\alias{reformulate2} +\alias{bt} +\alias{bt_strip} +\title{Construction Helpers} +\usage{ +construct_model(x, ...) + +\method{construct_model}{data.frame}( + x, + formula, + method, + method.args = list(), + package = "base", + env = caller_env(), + ... +) + +reformulate2( + termlabels, + response = NULL, + intercept = TRUE, + pattern_term = "[ \\n\\r]", + pattern_response = "[ \\n\\r]", + env = parent.frame() +) + +bt(x, pattern = "[ \\n\\r]") + +bt_strip(x) +} +\arguments{ +\item{x}{(\code{character})\cr +character vector, typically of variable names} + +\item{...}{These dots are for future extensions and must be empty.} + +\item{formula}{(\code{formula})\cr +a formula} + +\item{method}{(\code{string})\cr +string naming the function to be called, e.g. \code{"glm"}. +If function belongs to a library that is not attached, the package name +must be specified in the \code{package} argument.} + +\item{method.args}{(named \code{list})\cr +named list of arguments that will be passed to \code{fn}.} + +\item{package}{(\code{string})\cr +string of package name that will be temporarily loaded when function +specified in \code{method} is executed.} + +\item{env}{The environment in which to evaluate \code{expr}. This +environment is not applicable for quosures because they have +their own environments.} + +\item{termlabels}{character vector giving the right-hand side of a + model formula. Cannot be zero-length.} + +\item{response}{character string, symbol or call giving the left-hand + side of a model formula, or \code{NULL}.} + +\item{intercept}{logical: should the formula have an intercept?} + +\item{pattern_term, pattern_response}{passed to \code{bt(pattern)} for arguments +\code{stats::reformulate(termlabels, response)}.} + +\item{pattern}{(\code{string})\cr +regular expression string. If the regex matches, backticks are added +to the string. When \code{NULL}, backticks are not added.} +} +\value{ +depends on the calling function +} +\description{ +These functions help construct calls to various types of models. +} +\details{ +\itemize{ +\item \code{construct_model()}: Builds models of the form \verb{method(data = data, formula = formula, method.args!!!)}. +If the \code{package} argument is specified, that package is temporarily attached +when the model is evaluated. +\item \code{reformulate2()}: This is a copy of \code{reformulate()} except that variable +names that contain a space are wrapped in backticks. +\item \code{bt()}: Adds backticks to a character vector. +\item \code{bt_strip()}: Removes backticks from a string if it begins and ends with a backtick. +} +} +\examples{ +\dontshow{if (do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +construct_model( + x = mtcars, + formula = am ~ mpg + (1 | vs), + method = "glmer", + method.args = list(family = binomial), + package = "lme4" +) + +construct_model( + x = mtcars |> dplyr::rename(`M P G` = mpg), + formula = reformulate2(c("M P G", "cyl"), response = "hp"), + method = "lm" +) |> + ard_regression() |> + dplyr::filter(stat_name \%in\% c("term", "estimate", "p.value")) +\dontshow{\}) # examplesIf} +} diff --git a/tests/testthat/_snaps/construction_helpers.md b/tests/testthat/_snaps/construction_helpers.md new file mode 100644 index 000000000..e354d9b82 --- /dev/null +++ b/tests/testthat/_snaps/construction_helpers.md @@ -0,0 +1,15 @@ +# construct_model() works + + Code + dplyr::filter(as.data.frame(ard_regression(construct_model(x = dplyr::rename( + mtcars, `M P G` = mpg), formula = reformulate2(c("M P G", "cyl"), response = "hp"), + method = "lm"))), stat_name %in% c("term", "estimate", "p.value")) + Output + variable variable_level context stat_name stat_label stat fmt_fn + 1 M P G regression term term `M P G` NULL + 2 M P G regression estimate Coefficient -2.774769 1 + 3 M P G regression p.value p-value 0.2125285 1 + 4 cyl regression term term cyl NULL + 5 cyl regression estimate Coefficient 23.97863 1 + 6 cyl regression p.value p-value 0.002814958 1 + diff --git a/tests/testthat/test-ard_stats_anova.R b/tests/testthat/test-ard_stats_anova.R index ec0197853..db55f67d9 100644 --- a/tests/testthat/test-ard_stats_anova.R +++ b/tests/testthat/test-ard_stats_anova.R @@ -38,7 +38,7 @@ test_that("ard_stats_anova.data.frame() works", { ard_stats_anova( x = mtcars, formulas = list(mpg ~ am, mpg ~ am + hp), - fn = "lm" + method = "lm" ) ) @@ -48,8 +48,8 @@ test_that("ard_stats_anova.data.frame() works", { ard_stats_anova( x = mtcars, formulas = list(mpg ~ hp, mpg ~ hp + vs), - fn = "geeglm", - fn.args = list(id = cyl), + method = "geeglm", + method.args = list(id = cyl), package = "geepack" ), NA @@ -75,8 +75,8 @@ test_that("ard_stats_anova.data.frame() works", { ard_stats_anova( x = mtcars, formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)), - fn = "glmer", - fn.args = list(family = binomial), + method = "glmer", + method.args = list(family = binomial), package = "lme4" ), NA @@ -102,8 +102,8 @@ test_that("ard_stats_anova.data.frame() works", { ard_stats_anova( x = mtcars, formulas = list(am ~ 1 + (1 | vs), am ~ mpg + (1 | vs)), - fn = "glmer", - fn.args = {{ args }}, + method = "glmer", + method.args = {{ args }}, package = "lme4" ) } @@ -118,8 +118,8 @@ test_that("ard_stats_anova.data.frame() works", { ard_stats_anova( x = mtcars, formulas = list(mpg ~ hp, mpg ~ hp + vs), - fn = "geeglm", - fn.args = {{ args }}, + method = "geeglm", + method.args = {{ args }}, package = "geepack" ) } @@ -131,12 +131,15 @@ test_that("ard_stats_anova.data.frame() works", { }) test_that("ard_stats_anova.data.frame() error messaging", { - expect_error( + expect_true( ard_stats_anova( x = mtcars, formulas = list(mpg ~ am, mpg ~ am + hp), - fn = "base::lm" - ), - "cannot be namespaced" + method = "base::lm" + ) |> + dplyr::pull("error") |> + unique() |> + unlist() |> + grepl(pattern = "^Argument `method` cannot be namespaced*", x = _) ) }) diff --git a/tests/testthat/test-ard_survey_svychisq.R b/tests/testthat/test-ard_survey_svychisq.R index 894fbbd8b..1d780f0dd 100644 --- a/tests/testthat/test-ard_survey_svychisq.R +++ b/tests/testthat/test-ard_survey_svychisq.R @@ -48,4 +48,20 @@ test_that("ard_survey_svychisq() works", { dclus2 |> ard_survey_svychisq(by = comp.imp, variables = c(sch.wide, stype)) ) + + # works with non-syntactic names + expect_equal( + { + dclus2_syntactic <- dclus2 + dclus2_syntactic$variables <- + dplyr::rename(dclus2_syntactic$variables, `comp imp` = comp.imp) + ard_survey_svychisq( + dclus2, + variables = sch.wide, + by = comp.imp, + statistic = "F" + )[c("context", "stat_name", "stat_label", "stat")] + }, + ard_svychisq[c("context", "stat_name", "stat_label", "stat")] + ) }) diff --git a/tests/testthat/test-construction_helpers.R b/tests/testthat/test-construction_helpers.R new file mode 100644 index 000000000..28490297e --- /dev/null +++ b/tests/testthat/test-construction_helpers.R @@ -0,0 +1,30 @@ +test_that("construct_model() works", { + expect_snapshot( + construct_model( + x = mtcars |> dplyr::rename(`M P G` = mpg), + formula = reformulate2(c("M P G", "cyl"), response = "hp"), + method = "lm" + ) |> + ard_regression() |> + as.data.frame() |> + dplyr::filter(stat_name %in% c("term", "estimate", "p.value")) + ) + + expect_equal( + mtcars[c("mpg", "hp", "vs")] |> + dplyr::rename(`M P G` = mpg, `h\np` = hp) |> + names() |> + bt(), + c("`M P G`", "`h\np`", "vs") + ) + + expect_equal( + bt_strip(c("`complex variable name`", "east_variable_name")), + c("complex variable name", "east_variable_name") + ) + + expect_error( + check_not_namespaced("geepack::geeglm"), + "cannot be namespaced" + ) +}) From 6e0625355f53079253460b6ea0c308cab18410ab Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Fri, 19 Apr 2024 17:03:46 +0000 Subject: [PATCH 02/14] [skip actions] Bump version to 0.1.0.9022 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4905778da..9b0867a4f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9021 +Version: 0.1.0.9022 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 70cedb7af..5f3c8c1a3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9021 +# cardx 0.1.0.9022 ### Breaking Changes From 1b93221760975e7dc87d436363ad6c3dcf68f663 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Fri, 19 Apr 2024 16:49:27 -0700 Subject: [PATCH 03/14] added `construct_model.survey.design()` method (#128) **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. - [ ] 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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- NAMESPACE | 1 + R/construction_helpers.R | 40 +++++++++++++++++++--- man/construction_helpers.Rd | 18 ++++++++-- tests/testthat/test-construction_helpers.R | 21 ++++++++++++ 4 files changed, 73 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 282c4efb4..a14d71b38 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ S3method(ard_regression,default) S3method(ard_stats_anova,anova) S3method(ard_stats_anova,data.frame) S3method(construct_model,data.frame) +S3method(construct_model,survey.design) export("%>%") export(all_of) export(any_of) diff --git a/R/construction_helpers.R b/R/construction_helpers.R index 144f8a7cf..ae5873532 100644 --- a/R/construction_helpers.R +++ b/R/construction_helpers.R @@ -13,8 +13,10 @@ #' #' - `bt_strip()`: Removes backticks from a string if it begins and ends with a backtick. #' -#' @param x (`data.frame`)\cr -#' a data frame +#' @param x +#' - `construct_model.data.frame()` (`data.frame`) a data frame +#' - `construct_model.survey.design()` (`survey.design`) a survey design object +#' - `bt()`/`bt_strip()` (`character`) character vector, typically of variable names #' @param formula (`formula`)\cr #' a formula #' @param method (`string`)\cr @@ -26,8 +28,6 @@ #' @param package (`string`)\cr #' string of package name that will be temporarily loaded when function #' specified in `method` is executed. -#' @param x (`character`)\cr -#' character vector, typically of variable names #' @param pattern (`string`)\cr #' regular expression string. If the regex matches, backticks are added #' to the string. When `NULL`, backticks are not added. @@ -80,7 +80,7 @@ construct_model.data.frame <- function(x, formula, method, method.args = list(), check_not_namespaced(method) # convert method.args to list of expressions (to account for NSE inputs) ----- - method.args <- call_args(enexpr(method.args)) + method.args <- .as_list_of_exprs({{ method.args }}) # build model ---------------------------------------------------------------- withr::with_namespace( @@ -90,6 +90,36 @@ construct_model.data.frame <- function(x, formula, method, method.args = list(), ) } +#' @rdname construction_helpers +#' @export +construct_model.survey.design <- function(x, formula, method, method.args = list(), package = "survey", env = caller_env(), ...) { + set_cli_abort_call() + # check pkg installations ---------------------------------------------------- + check_dots_empty() + check_pkg_installed(c("withr", package), reference_pkg = "cardx") + + check_not_missing(formula) + check_class(formula, cls = "formula") + + check_not_missing(method) + check_string(method) + check_not_namespaced(method) + + # convert method.args to list of expressions (to account for NSE inputs) ----- + method.args <- .as_list_of_exprs({{ method.args }}) + + # build model ---------------------------------------------------------------- + withr::with_namespace( + package = package, + call2(.fn = method, formula = formula, design = x, !!!method.args) |> + eval_tidy(env = env) + ) +} + +.as_list_of_exprs <- function(x) { + call_args(enexpr(x)) +} + #' @rdname construction_helpers #' @export reformulate2 <- function(termlabels, response = NULL, intercept = TRUE, diff --git a/man/construction_helpers.Rd b/man/construction_helpers.Rd index fb00d9537..82d5439a3 100644 --- a/man/construction_helpers.Rd +++ b/man/construction_helpers.Rd @@ -4,6 +4,7 @@ \alias{construction_helpers} \alias{construct_model} \alias{construct_model.data.frame} +\alias{construct_model.survey.design} \alias{reformulate2} \alias{bt} \alias{bt_strip} @@ -21,6 +22,16 @@ construct_model(x, ...) ... ) +\method{construct_model}{survey.design}( + x, + formula, + method, + method.args = list(), + package = "survey", + env = caller_env(), + ... +) + reformulate2( termlabels, response = NULL, @@ -35,8 +46,11 @@ bt(x, pattern = "[ \\n\\r]") bt_strip(x) } \arguments{ -\item{x}{(\code{character})\cr -character vector, typically of variable names} +\item{x}{\itemize{ +\item \code{construct_model.data.frame()} (\code{data.frame}) a data frame +\item \code{construct_model.survey.design()} (\code{survey.design}) a survey design object +\item \code{bt()}/\code{bt_strip()} (\code{character}) character vector, typically of variable names +}} \item{...}{These dots are for future extensions and must be empty.} diff --git a/tests/testthat/test-construction_helpers.R b/tests/testthat/test-construction_helpers.R index 28490297e..c8ed0fb2e 100644 --- a/tests/testthat/test-construction_helpers.R +++ b/tests/testthat/test-construction_helpers.R @@ -1,3 +1,5 @@ +skip_if_not(is_pkg_installed(c("withr", "survey"), reference_pkg = "cardx")) + test_that("construct_model() works", { expect_snapshot( construct_model( @@ -27,4 +29,23 @@ test_that("construct_model() works", { check_not_namespaced("geepack::geeglm"), "cannot be namespaced" ) + + # now the survey method ------- + # styler: off + expect_equal({ + data(api, package = "survey") + # stratified sample + survey::svydesign(id = ~1, strata = ~stype, weights = ~pw, data = apistrat, fpc = ~fpc) |> + construct_model(formula = api00 ~ api99, method = "svyglm") |> + ard_regression() |> + cards::get_ard_statistics(stat_name %in% "estimate")}, + survey::svyglm( + api00 ~ api99, + design = survey::svydesign(id = ~1, strata = ~stype, weights = ~pw, data = apistrat, fpc = ~fpc) + ) |> + coef() |> + getElement(2L) |> + list(estimate = _) + ) + # styler: on }) From 4332d393c96abed70dc874ab61df9234c0a10b42 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Fri, 19 Apr 2024 23:50:25 +0000 Subject: [PATCH 04/14] [skip actions] Bump version to 0.1.0.9023 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9b0867a4f..5c600c7d8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9022 +Version: 0.1.0.9023 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 5f3c8c1a3..e7de90e55 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9022 +# cardx 0.1.0.9023 ### Breaking Changes From 306709071b358c58d0a53c1002a301376836ac26 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 20 Apr 2024 08:23:49 -0700 Subject: [PATCH 05/14] adding long mcnemar (#129) **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. - [ ] 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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- NAMESPACE | 1 + NEWS.md | 1 + R/ard_stats_mcnemar_test.R | 67 +++++++++++++++++++- man/ard_stats_mcnemar_test.Rd | 22 +++++++ tests/testthat/test-ard_stats_mcnemar_test.R | 19 +++++- 5 files changed, 108 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a14d71b38..b971519aa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(ard_stats_chisq_test) export(ard_stats_fisher_test) export(ard_stats_kruskal_test) export(ard_stats_mcnemar_test) +export(ard_stats_mcnemar_test_long) export(ard_stats_mood_test) export(ard_stats_oneway_test) export(ard_stats_paired_t_test) diff --git a/NEWS.md b/NEWS.md index e7de90e55..5068197c2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -21,6 +21,7 @@ ard_moodtest() -> ard_stats_mood_test() * Added the following functions for calculating Analysis Results Data (ARD). - `ard_stats_aov()` for calculating ANOVA results using `stats::aov()`. (#3) - `ard_stats_anova()` for calculating ANOVA results using `stats::anova()`. (#12) + - `ard_stats_mcnemar_test_long()` for McNemar's test from long data using `stats::mcnemar.test()`. - `ard_aod_wald_test()` for calculating Wald Tests for regression models using `aod::wald.test()`. (#84) - `ard_car_anova()` for calculating ANOVA results using `car::Anova()`. (#3) - `ard_stats_oneway_test()` for calculating ANOVA results using `stats::oneway.test()`. (#3) diff --git a/R/ard_stats_mcnemar_test.R b/R/ard_stats_mcnemar_test.R index fb6f31221..bf3fa3063 100644 --- a/R/ard_stats_mcnemar_test.R +++ b/R/ard_stats_mcnemar_test.R @@ -2,6 +2,9 @@ #' #' @description #' Analysis results data for McNemar's statistical test. +#' We have two functions depending on the structure of the data. +#' - `ard_stats_mcnemar_test()` is the structure expected by [`stats::mcnemar.test()`] +#' - `ard_stats_mcnemar_test_long()` is one row per ID per group #' #' @param data (`data.frame`)\cr #' a data frame. See below for details. @@ -11,9 +14,11 @@ #' column names to be compared. Independent tests will #' be computed for each variable. #' @param ... arguments passed to `stats::mcnemar.test(...)` +#' @param id ([`tidy-select`][dplyr::dplyr_tidy_select])\cr +#' column name of the subject or participant ID #' #' @return ARD data frame -#' @export +#' @name ard_stats_mcnemar_test #' #' @details #' For the `ard_stats_mcnemar_test()` function, the data is expected to be one row per subject. @@ -23,6 +28,21 @@ #' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx")) #' cards::ADSL |> #' ard_stats_mcnemar_test(by = "SEX", variables = "EFFFL") +#' +#' set.seed(1234) +#' cards::ADSL[c("USUBJID", "TRT01P")] |> +#' dplyr::mutate(TYPE = "PLANNED") |> +#' dplyr::rename(TRT01 = TRT01P) %>% +#' dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |> +#' ard_stats_mcnemar_test_long( +#' by = TYPE, +#' variable = TRT01, +#' id = USUBJID +#' ) +NULL + +#' @rdname ard_stats_mcnemar_test +#' @export ard_stats_mcnemar_test <- function(data, by, variables, ...) { set_cli_abort_call() @@ -61,6 +81,51 @@ ard_stats_mcnemar_test <- function(data, by, variables, ...) { dplyr::bind_rows() } +#' @rdname ard_stats_mcnemar_test +#' @export +ard_stats_mcnemar_test_long <- function(data, by, variables, id, ...) { + set_cli_abort_call() + + # check installed packages --------------------------------------------------- + check_pkg_installed("broom", reference_pkg = "cardx") + + # check/process inputs ------------------------------------------------------- + check_not_missing(data) + check_not_missing(variables) + check_not_missing(by) + check_not_missing(id) + check_data_frame(data) + data <- dplyr::ungroup(data) + cards::process_selectors(data, by = {{ by }}, variables = {{ variables }}, id = {{ id }}) + check_scalar(by) + check_scalar(id) + + # if no variables selected, return empty tibble ------------------------------ + if (is_empty(variables)) { + return(dplyr::tibble()) + } + # build ARD ------------------------------------------------------------------ + lapply( + variables, + function(variable) { + .format_mcnemartest_results( + by = by, + variable = variable, + lst_tidy = + cards::eval_capture_conditions({ + # adding this reshape inside the eval, so if there is an error it's captured in the ARD object + data_wide <- .paired_data_pivot_wider(data, by = by, variable = variable, id = id) + # performing McNemars test + stats::mcnemar.test(x = data_wide[["by1"]], y = data_wide[["by2"]], ...) |> + broom::tidy() + }), + ... + ) + } + ) |> + dplyr::bind_rows() +} + #' Convert McNemar's test to ARD #' #' @inheritParams cards::tidy_as_ard diff --git a/man/ard_stats_mcnemar_test.Rd b/man/ard_stats_mcnemar_test.Rd index 0f1327b8b..e2d096739 100644 --- a/man/ard_stats_mcnemar_test.Rd +++ b/man/ard_stats_mcnemar_test.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/ard_stats_mcnemar_test.R \name{ard_stats_mcnemar_test} \alias{ard_stats_mcnemar_test} +\alias{ard_stats_mcnemar_test_long} \title{ARD McNemar's Test} \usage{ ard_stats_mcnemar_test(data, by, variables, ...) + +ard_stats_mcnemar_test_long(data, by, variables, id, ...) } \arguments{ \item{data}{(\code{data.frame})\cr @@ -18,12 +21,20 @@ column names to be compared. Independent tests will be computed for each variable.} \item{...}{arguments passed to \code{stats::mcnemar.test(...)}} + +\item{id}{(\code{\link[dplyr:dplyr_tidy_select]{tidy-select}})\cr +column name of the subject or participant ID} } \value{ ARD data frame } \description{ Analysis results data for McNemar's statistical test. +We have two functions depending on the structure of the data. +\itemize{ +\item \code{ard_stats_mcnemar_test()} is the structure expected by \code{\link[stats:mcnemar.test]{stats::mcnemar.test()}} +\item \code{ard_stats_mcnemar_test_long()} is one row per ID per group +} } \details{ For the \code{ard_stats_mcnemar_test()} function, the data is expected to be one row per subject. @@ -34,5 +45,16 @@ Please use \code{table(x = data[[variable]], y = data[[by]])} to check the conti \dontshow{if (do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "broom", reference_pkg = "cardx"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} cards::ADSL |> ard_stats_mcnemar_test(by = "SEX", variables = "EFFFL") + +set.seed(1234) +cards::ADSL[c("USUBJID", "TRT01P")] |> + dplyr::mutate(TYPE = "PLANNED") |> + dplyr::rename(TRT01 = TRT01P) \%>\% + dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |> + ard_stats_mcnemar_test_long( + by = TYPE, + variable = TRT01, + id = USUBJID + ) \dontshow{\}) # examplesIf} } diff --git a/tests/testthat/test-ard_stats_mcnemar_test.R b/tests/testthat/test-ard_stats_mcnemar_test.R index 5b54f50fa..6928a130c 100644 --- a/tests/testthat/test-ard_stats_mcnemar_test.R +++ b/tests/testthat/test-ard_stats_mcnemar_test.R @@ -1,4 +1,4 @@ -skip_if_not(is_pkg_installed("broom", reference_pkg = "cardx")) +skip_if_not(is_pkg_installed(c("broom", "withr"), reference_pkg = "cardx")) test_that("ard_stats_mcnemar_test() works", { expect_error( @@ -50,4 +50,21 @@ test_that("ard_stats_mcnemar_test() works", { cards::ADSL |> ard_stats_mcnemar_test(by = SEX, variables = c(EFFFL, COMP16FL)) ) + + # testing long format version + withr::local_seed(1234) + expect_error( + ard_stats_mcnemar_test_long <- + cards::ADSL[c("USUBJID", "TRT01P")] |> + dplyr::mutate(TYPE = "PLANNED") |> + dplyr::rename(TRT01 = TRT01P) %>% + dplyr::bind_rows(dplyr::mutate(., TYPE = "ACTUAL", TRT01 = sample(TRT01))) |> + ard_stats_mcnemar_test_long( + by = TYPE, + variable = TRT01, + id = USUBJID + ), + NA + ) + expect_null(ard_stats_mcnemar_test_long$error |> unique() |> unlist()) }) From 4375254148bdda495830e281c72dd1f6868a3530 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Sat, 20 Apr 2024 15:24:42 +0000 Subject: [PATCH 06/14] [skip actions] Bump version to 0.1.0.9024 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5c600c7d8..8dca0f8a9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9023 +Version: 0.1.0.9024 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 5068197c2..16b19cd94 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9023 +# cardx 0.1.0.9024 ### Breaking Changes From 1a585990e71296e60b5b9805eba3408d2aaeac2f Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 20 Apr 2024 16:18:26 -0700 Subject: [PATCH 07/14] Adding `ard_emmeans_mean_difference()` (#130) **What changes are proposed in this pull request?** * Adding `ard_emmeans_mean_difference()`. (#34) Provide more detail here as needed. **Reference GitHub issue associated with pull request.** _e.g., 'closes #'_ closes #34 -------------------------------------------------------------------------------- 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. - [ ] 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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- .github/workflows/R-CMD-check.yaml | 2 +- DESCRIPTION | 1 + NAMESPACE | 1 + NEWS.md | 1 + R/ard_emmeans_mean_difference.R | 134 ++++++++++++++++++ _pkgdown.yml | 1 + inst/WORDLIST | 1 + man/ard_emmeans_mean_difference.Rd | 80 +++++++++++ .../test-ard_emmeans_mean_difference.R | 86 +++++++++++ 9 files changed, 306 insertions(+), 1 deletion(-) create mode 100644 R/ard_emmeans_mean_difference.R create mode 100644 man/ard_emmeans_mean_difference.Rd create mode 100644 tests/testthat/test-ard_emmeans_mean_difference.R diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 50de31520..a2dee80c7 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -29,7 +29,7 @@ jobs: - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'oldrel-1'} + # - {os: ubuntu-latest, r: 'oldrel-1'} # - {os: ubuntu-latest, r: 'oldrel-2'} # - {os: ubuntu-latest, r: 'oldrel-3'} # - {os: ubuntu-latest, r: 'oldrel-4'} diff --git a/DESCRIPTION b/DESCRIPTION index 8dca0f8a9..760f487f5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,6 +30,7 @@ Suggests: broom.helpers (>= 1.15.0), car (>= 3.0-11), effectsize (>= 0.6.0), + emmeans (>= 1.7.3), geepack (>= 1.3.2), ggsurvfit (>= 1.0.0), lme4 (>= 1.1-31), diff --git a/NAMESPACE b/NAMESPACE index b971519aa..d1e1abdba 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ export(ard_effectsize_cohens_d) export(ard_effectsize_hedges_g) export(ard_effectsize_paired_cohens_d) export(ard_effectsize_paired_hedges_g) +export(ard_emmeans_mean_difference) export(ard_proportion_ci) export(ard_regression) export(ard_regression_basic) diff --git a/NEWS.md b/NEWS.md index 16b19cd94..4a5ce8978 100644 --- a/NEWS.md +++ b/NEWS.md @@ -35,6 +35,7 @@ ard_moodtest() -> ard_stats_mood_test() - `ard_survey_svyttest()` for weighted/survey t-tests using `survey::svyttest()`. (#70) - `ard_survey_svyranktest()` for weighted/survey rank tests using `survey::svyranktest()`. (#71) - `ard_car_vif()` for calculating the variance inflation factor using `car::vif()`. (#10) + - `ard_emmeans_mean_difference()` for calculating the least-squares mean differences using the {emmeans} package. (#34) * Updated functions `ard_stats_t_test()`, `ard_stats_paired_t_test()`, `ard_stats_wilcox_test()`, `ard_stats_paired_wilcox_test()`, `ard_stats_chisq_test()`, `ard_stats_fisher_test()`, `ard_stats_kruskal_test()`, `ard_stats_mcnemar_test()`, and `ard_stats_mood_test()` to accept multiple variables at once. Independent tests are calculated for each variable. The `variable` argument is renamed to `variables`. (#77) diff --git a/R/ard_emmeans_mean_difference.R b/R/ard_emmeans_mean_difference.R new file mode 100644 index 000000000..b4e2fa5e9 --- /dev/null +++ b/R/ard_emmeans_mean_difference.R @@ -0,0 +1,134 @@ +#' ARD for LS Mean Difference +#' +#' @description +#' This function calculates least-squares mean differences using the 'emmeans' +#' package using the following +#' +#' ```r +#' emmeans::emmeans(object = , specs = ~ ) |> +#' emmeans::contrast(method = "pairwise") |> +#' summary(infer = TRUE, level = ) +#' ``` +#' +#' The arguments `data`, `formula`, `method`, `method.args`, `package` are used +#' to construct the regression model via `cardx::construct_model()`. +#' +#' @param data (`data.frame`/`survey.design`)\cr +#' a data frame or survey design object +#' @inheritParams construct_model +#' @param response_type (`string`) +#' string indicating whether the model outcome is `'continuous'` +#' or `'binary'`. When `'binary'`, the call to `emmeans::emmeans()` is +#' supplemented with argument `regrid="response"`. +#' @param conf.level (scalar `numeric`)\cr +#' confidence level for confidence interval. Default is `0.95`. +#' @param primary_covariate (`string`)\cr +#' string indicating the primary covariate (typically the dichotomous treatment variable). +#' Default is the first covariate listed in the formula. +#' +#' @return ARD data frame +#' @export +#' +#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "emmeans", reference_pkg = "cardx")) +#' ard_emmeans_mean_difference( +#' data = mtcars, +#' formula = mpg ~ am + cyl, +#' method = "lm" +#' ) +#' +#' ard_emmeans_mean_difference( +#' data = mtcars, +#' formula = vs ~ am + mpg, +#' method = "glm", +#' method.args = list(family = binomial), +#' response_type = "binary" +#' ) +ard_emmeans_mean_difference <- function(data, formula, method, + method.args = list(), + package = "base", + response_type = c("continuous", "binary"), + conf.level = 0.95, + primary_covariate = + stats::terms(formula) |> + attr("term.labels") |> + getElement(1L)) { + set_cli_abort_call() + + # check package installation ------------------------------------------------- + check_pkg_installed(c("emmeans", package), reference_pkg = "cardx") + check_not_missing(data) + check_not_missing(formula) + check_not_missing(method) + check_class(data, c("data.frame", "survey.design")) + check_class(formula, cls = "formula") + check_string(package) + check_string(primary_covariate) + check_scalar(conf.level) + check_range(conf.level, range = c(0, 1)) + response_type <- arg_match(response_type, error_call = get_cli_abort_call()) + + # construct primary model ---------------------------------------------------- + mod <- + construct_model( + x = data, formula = formula, method = method, + method.args = {{ method.args }}, + package = package, env = caller_env() + ) + + # emmeans -------------------------------------------------------------------- + emmeans_args <- list(object = mod, specs = reformulate2(primary_covariate)) + if (response_type %in% "binary") emmeans_args <- c(emmeans_args, list(regrid = "response")) + emmeans <- + withr::with_namespace( + package = "emmeans", + code = do.call("emmeans", args = emmeans_args) + ) + + df_results <- + emmeans |> + emmeans::contrast(method = "pairwise") |> + summary(infer = TRUE, level = conf.level) + + # convert results to ARD format ---------------------------------------------- + df_results |> + dplyr::as_tibble() |> + dplyr::rename( + conf.low = any_of("asymp.LCL"), + conf.high = any_of("asymp.UCL"), + conf.low = any_of("lower.CL"), + conf.high = any_of("upper.CL") + ) %>% + dplyr::select( + variable_level = "contrast", + "estimate", + std.error = "SE", "df", + "conf.low", "conf.high", "p.value" + ) %>% + dplyr::mutate( + conf.level = .env$conf.level, + method = + ifelse( + length(attr(stats::terms(formula), "term.labels") |> discard(~ startsWith(., "1 |"))) == 1L, + "Least-squares mean difference", + "Least-squares adjusted mean difference" + ), + across(everything(), as.list), + variable = "contrast", + group1 = .env$primary_covariate + ) |> + tidyr::pivot_longer( + cols = -c("group1", "variable", "variable_level"), + names_to = "stat_name", + values_to = "stat" + ) |> + dplyr::left_join(.df_ttest_stat_labels(primary_covariate), by = "stat_name") |> + dplyr::mutate( + context = "emmeans_mean_difference", + stat_label = dplyr::coalesce(.data$stat_label, .data$stat_name), + warning = list(NULL), + error = list(NULL), + fmt_fn = map(.data$stat, \(.x) if (is.numeric(.x)) 1L else NULL) # styler: off + ) |> + cards::tidy_ard_column_order() %>% + {structure(., class = c("card", class(.)))} # styler: off +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 9dace7a4a..e22a3e83d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -47,6 +47,7 @@ reference: - ard_car_vif - ard_effectsize_cohens_d - ard_effectsize_hedges_g + - ard_emmeans_mean_difference - ard_proportion_ci - ard_regression - ard_regression_basic diff --git a/inst/WORDLIST b/inst/WORDLIST index 9ffe51b9f..073fb6ff4 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -24,6 +24,7 @@ clopper coull de deff +emmeans funder jeffreys pearson diff --git a/man/ard_emmeans_mean_difference.Rd b/man/ard_emmeans_mean_difference.Rd new file mode 100644 index 000000000..2a7c9ffa9 --- /dev/null +++ b/man/ard_emmeans_mean_difference.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ard_emmeans_mean_difference.R +\name{ard_emmeans_mean_difference} +\alias{ard_emmeans_mean_difference} +\title{ARD for LS Mean Difference} +\usage{ +ard_emmeans_mean_difference( + data, + formula, + method, + method.args = list(), + package = "base", + response_type = c("continuous", "binary"), + conf.level = 0.95, + primary_covariate = getElement(attr(stats::terms(formula), "term.labels"), 1L) +) +} +\arguments{ +\item{data}{(\code{data.frame}/\code{survey.design})\cr +a data frame or survey design object} + +\item{formula}{(\code{formula})\cr +a formula} + +\item{method}{(\code{string})\cr +string naming the function to be called, e.g. \code{"glm"}. +If function belongs to a library that is not attached, the package name +must be specified in the \code{package} argument.} + +\item{method.args}{(named \code{list})\cr +named list of arguments that will be passed to \code{fn}.} + +\item{package}{(\code{string})\cr +string of package name that will be temporarily loaded when function +specified in \code{method} is executed.} + +\item{response_type}{(\code{string}) +string indicating whether the model outcome is \code{'continuous'} +or \code{'binary'}. When \code{'binary'}, the call to \code{emmeans::emmeans()} is +supplemented with argument \code{regrid="response"}.} + +\item{conf.level}{(scalar \code{numeric})\cr +confidence level for confidence interval. Default is \code{0.95}.} + +\item{primary_covariate}{(\code{string})\cr +string indicating the primary covariate (typically the dichotomous treatment variable). +Default is the first covariate listed in the formula.} +} +\value{ +ARD data frame +} +\description{ +This function calculates least-squares mean differences using the 'emmeans' +package using the following + +\if{html}{\out{
}}\preformatted{emmeans::emmeans(object = , specs = ~ ) |> + emmeans::contrast(method = "pairwise") |> + summary(infer = TRUE, level = ) +}\if{html}{\out{
}} + +The arguments \code{data}, \code{formula}, \code{method}, \code{method.args}, \code{package} are used +to construct the regression model via \code{cardx::construct_model()}. +} +\examples{ +\dontshow{if (do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = "emmeans", reference_pkg = "cardx"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +ard_emmeans_mean_difference( + data = mtcars, + formula = mpg ~ am + cyl, + method = "lm" +) + +ard_emmeans_mean_difference( + data = mtcars, + formula = vs ~ am + mpg, + method = "glm", + method.args = list(family = binomial), + response_type = "binary" +) +\dontshow{\}) # examplesIf} +} diff --git a/tests/testthat/test-ard_emmeans_mean_difference.R b/tests/testthat/test-ard_emmeans_mean_difference.R new file mode 100644 index 000000000..bb25c6785 --- /dev/null +++ b/tests/testthat/test-ard_emmeans_mean_difference.R @@ -0,0 +1,86 @@ +skip_if_not(is_pkg_installed(c("emmeans", "survey", "lme4"), reference_pkg = "cardx")) + +test_that("ard_emmeans_mean_difference() works", { + expect_error( + ard_emmeans_mean_difference <- + ard_emmeans_mean_difference( + data = mtcars, + formula = vs ~ am + mpg, + method = "glm", + method.args = list(family = binomial), + response_type = "binary" + ), + NA + ) + expect_equal( + cards::get_ard_statistics(ard_emmeans_mean_difference, stat_name %in% "method"), + list(method = "Least-squares adjusted mean difference") + ) + expect_equal( + cards::get_ard_statistics(ard_emmeans_mean_difference, stat_name %in% "estimate") |> + unlist() |> + unname(), + glm(vs ~ am + mpg, data = mtcars, family = binomial) |> + emmeans::emmeans(specs = ~am, regrid = "response") |> + emmeans::contrast(method = "pairwise") |> + summary(infer = TRUE) |> + getElement("estimate") + ) + + + expect_error( + ard_emmeans_mean_difference_lme4 <- + ard_emmeans_mean_difference( + data = mtcars, + formula = vs ~ am + (1 | cyl), + method = "glmer", + method.args = list(family = binomial), + package = "lme4", + response_type = "binary" + ), + NA + ) + expect_equal( + cards::get_ard_statistics(ard_emmeans_mean_difference_lme4, stat_name %in% "method"), + list(method = "Least-squares mean difference") + ) + expect_equal( + cards::get_ard_statistics(ard_emmeans_mean_difference_lme4, stat_name %in% "estimate") |> + unlist() |> + unname(), + lme4::glmer(vs ~ am + (1 | cyl), data = mtcars, family = binomial) |> + emmeans::emmeans(specs = ~am, regrid = "response") |> + emmeans::contrast(method = "pairwise") |> + summary(infer = TRUE) |> + getElement("estimate") + ) + + + #styler: off + expect_error({ + data(api, package = "survey") + ard_emmeans_mean_difference_svy <- + survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc) |> + ard_emmeans_mean_difference( + formula = api00 ~ sch.wide, + method = "svyglm", + package = "survey" + )}, + NA + ) + # styler: on + expect_equal( + cards::get_ard_statistics(ard_emmeans_mean_difference_svy, stat_name %in% "method"), + list(method = "Least-squares mean difference") + ) + expect_equal( + cards::get_ard_statistics(ard_emmeans_mean_difference_svy, stat_name %in% "estimate") |> + unlist() |> + unname(), + survey::svyglm(api00 ~ sch.wide, design = survey::svydesign(id = ~dnum, weights = ~pw, data = apiclus1, fpc = ~fpc)) |> + emmeans::emmeans(specs = ~sch.wide, regrid = "response") |> + emmeans::contrast(method = "pairwise") |> + summary(infer = TRUE) |> + getElement("estimate") + ) +}) From 5b309a5f964175e8dc8268fc3931a36cb2ed2eb9 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Sat, 20 Apr 2024 23:19:17 +0000 Subject: [PATCH 08/14] [skip actions] Bump version to 0.1.0.9025 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 760f487f5..da3fe09d3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9024 +Version: 0.1.0.9025 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 4a5ce8978..6330f0f0e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9024 +# cardx 0.1.0.9025 ### Breaking Changes From d50e4e17b63ff7e02223a9a966072d414741cd67 Mon Sep 17 00:00:00 2001 From: Daniel Sjoberg Date: Sat, 20 Apr 2024 20:43:15 -0700 Subject: [PATCH 09/14] lil update --- R/ard_emmeans_mean_difference.R | 8 ++++---- man/ard_emmeans_mean_difference.Rd | 6 +++--- tests/testthat/test-ard_emmeans_mean_difference.R | 4 ++-- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/R/ard_emmeans_mean_difference.R b/R/ard_emmeans_mean_difference.R index b4e2fa5e9..86af2a44b 100644 --- a/R/ard_emmeans_mean_difference.R +++ b/R/ard_emmeans_mean_difference.R @@ -18,7 +18,7 @@ #' @inheritParams construct_model #' @param response_type (`string`) #' string indicating whether the model outcome is `'continuous'` -#' or `'binary'`. When `'binary'`, the call to `emmeans::emmeans()` is +#' or `'dichotomous'`. When `'dichotomous'`, the call to `emmeans::emmeans()` is #' supplemented with argument `regrid="response"`. #' @param conf.level (scalar `numeric`)\cr #' confidence level for confidence interval. Default is `0.95`. @@ -41,12 +41,12 @@ #' formula = vs ~ am + mpg, #' method = "glm", #' method.args = list(family = binomial), -#' response_type = "binary" +#' response_type = "dichotomous" #' ) ard_emmeans_mean_difference <- function(data, formula, method, method.args = list(), package = "base", - response_type = c("continuous", "binary"), + response_type = c("continuous", "dichotomous"), conf.level = 0.95, primary_covariate = stats::terms(formula) |> @@ -77,7 +77,7 @@ ard_emmeans_mean_difference <- function(data, formula, method, # emmeans -------------------------------------------------------------------- emmeans_args <- list(object = mod, specs = reformulate2(primary_covariate)) - if (response_type %in% "binary") emmeans_args <- c(emmeans_args, list(regrid = "response")) + if (response_type %in% "dichotomous") emmeans_args <- c(emmeans_args, list(regrid = "response")) emmeans <- withr::with_namespace( package = "emmeans", diff --git a/man/ard_emmeans_mean_difference.Rd b/man/ard_emmeans_mean_difference.Rd index 2a7c9ffa9..97466d7d6 100644 --- a/man/ard_emmeans_mean_difference.Rd +++ b/man/ard_emmeans_mean_difference.Rd @@ -10,7 +10,7 @@ ard_emmeans_mean_difference( method, method.args = list(), package = "base", - response_type = c("continuous", "binary"), + response_type = c("continuous", "dichotomous"), conf.level = 0.95, primary_covariate = getElement(attr(stats::terms(formula), "term.labels"), 1L) ) @@ -36,7 +36,7 @@ specified in \code{method} is executed.} \item{response_type}{(\code{string}) string indicating whether the model outcome is \code{'continuous'} -or \code{'binary'}. When \code{'binary'}, the call to \code{emmeans::emmeans()} is +or \code{'dichotomous'}. When \code{'dichotomous'}, the call to \code{emmeans::emmeans()} is supplemented with argument \code{regrid="response"}.} \item{conf.level}{(scalar \code{numeric})\cr @@ -74,7 +74,7 @@ ard_emmeans_mean_difference( formula = vs ~ am + mpg, method = "glm", method.args = list(family = binomial), - response_type = "binary" + response_type = "dichotomous" ) \dontshow{\}) # examplesIf} } diff --git a/tests/testthat/test-ard_emmeans_mean_difference.R b/tests/testthat/test-ard_emmeans_mean_difference.R index bb25c6785..c140c5b8b 100644 --- a/tests/testthat/test-ard_emmeans_mean_difference.R +++ b/tests/testthat/test-ard_emmeans_mean_difference.R @@ -8,7 +8,7 @@ test_that("ard_emmeans_mean_difference() works", { formula = vs ~ am + mpg, method = "glm", method.args = list(family = binomial), - response_type = "binary" + response_type = "dichotomous" ), NA ) @@ -36,7 +36,7 @@ test_that("ard_emmeans_mean_difference() works", { method = "glmer", method.args = list(family = binomial), package = "lme4", - response_type = "binary" + response_type = "dichotomous" ), NA ) From 21f53c35a9083c056ae76783b69cc5c711a65a62 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Sun, 21 Apr 2024 03:44:05 +0000 Subject: [PATCH 10/14] [skip actions] Bump version to 0.1.0.9026 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index da3fe09d3..b2513dca0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9025 +Version: 0.1.0.9026 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 6330f0f0e..3d3bbea01 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9025 +# cardx 0.1.0.9026 ### Breaking Changes From a77becf561a2cce689d769135a6890a1cf173b2b Mon Sep 17 00:00:00 2001 From: Emily de la Rua <59304861+edelarua@users.noreply.github.com> Date: Thu, 25 Apr 2024 11:20:42 -0400 Subject: [PATCH 11/14] Remove all-NA `variable_level` column from regression ARD output (#135) **What changes are proposed in this pull request?** * Removed all-NA `variable_level` column from regression ARDs constructed from simple linear regression models. (#134) Also fixed failing example for `construct_model` which uses `ard_regression` but did not require `broom.helpers` to be installed. Closes #134 -------------------------------------------------------------------------------- Pre-review Checklist (if item does not apply, mark is as complete) - [ ] **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] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`. - [x] If a new `ard_*()` function was added, `set_cli_abort_call()` has been set. - [x] 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"))` - [x] 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 :white_check_mark: - [ ] Approve Pull Request - [ ] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- R/ard_regression.R | 1 + R/ard_regression_basic.R | 3 ++- R/construction_helpers.R | 2 +- man/construction_helpers.Rd | 2 +- tests/testthat/_snaps/construction_helpers.md | 14 +++++++------- tests/testthat/test-ard_regression.R | 4 ++++ tests/testthat/test-ard_regression_basic.R | 4 ++++ tests/testthat/test-construction_helpers.R | 2 +- 8 files changed, 21 insertions(+), 11 deletions(-) diff --git a/R/ard_regression.R b/R/ard_regression.R index a7b0561cb..f07fabc7d 100644 --- a/R/ard_regression.R +++ b/R/ard_regression.R @@ -49,6 +49,7 @@ ard_regression.default <- function(x, tidy_fun = broom.helpers::tidy_with_broom_ values_to = "stat" ) |> dplyr::filter(map_lgl(.data$stat, Negate(is.na))) |> + dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x))))) |> dplyr::mutate( fmt_fn = lapply( diff --git a/R/ard_regression_basic.R b/R/ard_regression_basic.R index e923245fb..c9a5b3ebe 100644 --- a/R/ard_regression_basic.R +++ b/R/ard_regression_basic.R @@ -55,5 +55,6 @@ ard_regression_basic <- function(x, tidy_fun = broom.helpers::tidy_with_broom_or utils::modifyList(val = rlang::dots_list(...)) rlang::inject(ard_regression(x = x, tidy_fun = tidy_fun, !!!args)) |> - dplyr::filter(!.data$stat_name %in% stats_to_remove) + dplyr::filter(!.data$stat_name %in% stats_to_remove) |> + dplyr::select(-(cards::all_ard_variables("levels") & dplyr::where(\(x) all(is.na(x))))) } diff --git a/R/construction_helpers.R b/R/construction_helpers.R index ae5873532..47e220cc2 100644 --- a/R/construction_helpers.R +++ b/R/construction_helpers.R @@ -40,7 +40,7 @@ #' @return depends on the calling function #' @name construction_helpers #' -#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx")) +#' @examplesIf do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4", "broom.helpers"), reference_pkg = "cardx")) #' construct_model( #' x = mtcars, #' formula = am ~ mpg + (1 | vs), diff --git a/man/construction_helpers.Rd b/man/construction_helpers.Rd index 82d5439a3..3264af7f3 100644 --- a/man/construction_helpers.Rd +++ b/man/construction_helpers.Rd @@ -106,7 +106,7 @@ names that contain a space are wrapped in backticks. } } \examples{ -\dontshow{if (do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4"), reference_pkg = "cardx"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (do.call(asNamespace("cardx")$is_pkg_installed, list(pkg = c("withr", "lme4", "broom.helpers"), reference_pkg = "cardx"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} construct_model( x = mtcars, formula = am ~ mpg + (1 | vs), diff --git a/tests/testthat/_snaps/construction_helpers.md b/tests/testthat/_snaps/construction_helpers.md index e354d9b82..d904c5939 100644 --- a/tests/testthat/_snaps/construction_helpers.md +++ b/tests/testthat/_snaps/construction_helpers.md @@ -5,11 +5,11 @@ mtcars, `M P G` = mpg), formula = reformulate2(c("M P G", "cyl"), response = "hp"), method = "lm"))), stat_name %in% c("term", "estimate", "p.value")) Output - variable variable_level context stat_name stat_label stat fmt_fn - 1 M P G regression term term `M P G` NULL - 2 M P G regression estimate Coefficient -2.774769 1 - 3 M P G regression p.value p-value 0.2125285 1 - 4 cyl regression term term cyl NULL - 5 cyl regression estimate Coefficient 23.97863 1 - 6 cyl regression p.value p-value 0.002814958 1 + variable context stat_name stat_label stat fmt_fn + 1 M P G regression term term `M P G` NULL + 2 M P G regression estimate Coefficient -2.774769 1 + 3 M P G regression p.value p-value 0.2125285 1 + 4 cyl regression term term cyl NULL + 5 cyl regression estimate Coefficient 23.97863 1 + 6 cyl regression p.value p-value 0.002814958 1 diff --git a/tests/testthat/test-ard_regression.R b/tests/testthat/test-ard_regression.R index 6fec0806e..7b834e764 100644 --- a/tests/testthat/test-ard_regression.R +++ b/tests/testthat/test-ard_regression.R @@ -20,3 +20,7 @@ test_that("ard_regression() works", { "Treatment Arm" ) }) + +test_that("ard_regression() does not produce `variable_level` column where not applicable", { + expect_true(!"variable_level" %in% names(lm(mpg ~ hp, mtcars) |> ard_regression())) +}) diff --git a/tests/testthat/test-ard_regression_basic.R b/tests/testthat/test-ard_regression_basic.R index 93932b563..487426348 100644 --- a/tests/testthat/test-ard_regression_basic.R +++ b/tests/testthat/test-ard_regression_basic.R @@ -9,3 +9,7 @@ test_that("ard_regression_basic() works", { expect_snapshot(as.data.frame(ard) |> dplyr::select(-fmt_fn)) }) + +test_that("ard_regression_basic() does not produce `variable_level` column where not applicable", { + expect_true(!"variable_level" %in% names(lm(mpg ~ hp, mtcars) |> ard_regression_basic())) +}) diff --git a/tests/testthat/test-construction_helpers.R b/tests/testthat/test-construction_helpers.R index c8ed0fb2e..0ff715752 100644 --- a/tests/testthat/test-construction_helpers.R +++ b/tests/testthat/test-construction_helpers.R @@ -1,4 +1,4 @@ -skip_if_not(is_pkg_installed(c("withr", "survey"), reference_pkg = "cardx")) +skip_if_not(is_pkg_installed(c("broom.helpers", "withr", "survey"), reference_pkg = "cardx")) test_that("construct_model() works", { expect_snapshot( From 3ef9132d3c0456d9811776ee1e074f6705afbb31 Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Thu, 25 Apr 2024 15:21:37 +0000 Subject: [PATCH 12/14] [skip actions] Bump version to 0.1.0.9027 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b2513dca0..6ab961ebb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9026 +Version: 0.1.0.9027 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 3d3bbea01..8464b2800 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9026 +# cardx 0.1.0.9027 ### Breaking Changes From a95e0918007646493553597c2255ea4e9c7ab977 Mon Sep 17 00:00:00 2001 From: Zelos Zhu Date: Thu, 25 Apr 2024 14:19:48 -0400 Subject: [PATCH 13/14] Closes #116 Check for other package messaging in our snapshots (#125) **What changes are proposed in this pull request?** Check and remove snapshots that contain other-package messaging Provide more detail here as needed. Closes #116 -------------------------------------------------------------------------------- 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] If a new `ard_*()` function was added, it passes the ARD structural checks from `cards::check_ard_structure()`. - [x] If a new `ard_*()` function was added, `set_cli_abort_call()` has been set. - [x] 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"))` - [x] 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) - [x] If a bug was fixed, a unit test was added. - [x] Code coverage is suitable for any new functions/features: `devtools::test_coverage()` When the branch is ready to be merged: - [x] 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). - [x] **All** GitHub Action workflows pass with a :white_check_mark: - [x] Approve Pull Request - [x] Merge the PR. Please use "Squash and merge" or "Rebase and merge". --- tests/testthat/_snaps/ard_car_vif.md | 23 +----- .../_snaps/ard_effectsize_cohens_d.md | 33 -------- .../_snaps/ard_effectsize_hedges_g.md | 33 -------- tests/testthat/_snaps/ard_stats_t_test.md | 75 ------------------- tests/testthat/test-ard_car_vif.R | 14 +--- tests/testthat/test-ard_effectsize_cohens_d.R | 14 ++-- tests/testthat/test-ard_effectsize_hedges_g.R | 14 ++-- tests/testthat/test-ard_stats_t_test.R | 12 ++- 8 files changed, 32 insertions(+), 186 deletions(-) delete mode 100644 tests/testthat/_snaps/ard_stats_t_test.md diff --git a/tests/testthat/_snaps/ard_car_vif.md b/tests/testthat/_snaps/ard_car_vif.md index 8d0a7a74b..4f3b5ac9d 100644 --- a/tests/testthat/_snaps/ard_car_vif.md +++ b/tests/testthat/_snaps/ard_car_vif.md @@ -20,27 +20,12 @@ 1 BMIBL car_vif VIF VIF 1.010522 1 NULL NULL 2 EDUCLVL car_vif VIF VIF 1.010522 1 NULL NULL -# ard_car_vif() appropriate errors are given for model with only 1 term - - Code - as.data.frame(ard_car_vif(lm(AGE ~ ARM, data = cards::ADSL))) - Output - variable context stat_name stat_label stat fmt_fn warning - 1 ARM car_vif VIF VIF NULL NULL NULL - 2 ARM car_vif GVIF GVIF NULL NULL NULL - 3 ARM car_vif aGVIF Adjusted GVIF NULL NULL NULL - 4 ARM car_vif df df NULL NULL NULL - error - 1 model contains fewer than 2 terms - 2 model contains fewer than 2 terms - 3 model contains fewer than 2 terms - 4 model contains fewer than 2 terms - # ard_vif() issues friendly messaging for incorrect object passed in/can't get terms of model Code - ard_vif(cards::ADSL) + ard_car_vif(cards::ADSL) Condition - Error in `ard_vif()`: - ! could not find function "ard_vif" + Error in `ard_car_vif()`: + ! There was an error running `car::vif()`. See below. + x no applicable method for 'vcov' applied to an object of class "c('tbl_df', 'tbl', 'data.frame')" diff --git a/tests/testthat/_snaps/ard_effectsize_cohens_d.md b/tests/testthat/_snaps/ard_effectsize_cohens_d.md index 6cd20d5a2..f7a81921d 100644 --- a/tests/testthat/_snaps/ard_effectsize_cohens_d.md +++ b/tests/testthat/_snaps/ard_effectsize_cohens_d.md @@ -1,21 +1,5 @@ # ard_effectsize_cohens_d() works - Code - as.data.frame(dplyr::select(ard_effectsize_cohens_d(cards::ADSL, by = ARM, - variables = AGE), c("variable", "stat_name", "error"))) - Output - variable stat_name error - 1 AGE estimate Grouping variable y must have exactly 2 levels. - 2 AGE conf.level Grouping variable y must have exactly 2 levels. - 3 AGE conf.low Grouping variable y must have exactly 2 levels. - 4 AGE conf.high Grouping variable y must have exactly 2 levels. - 5 AGE mu Grouping variable y must have exactly 2 levels. - 6 AGE paired Grouping variable y must have exactly 2 levels. - 7 AGE pooled_sd Grouping variable y must have exactly 2 levels. - 8 AGE alternative Grouping variable y must have exactly 2 levels. - ---- - Code as.data.frame(dplyr::slice_head(dplyr::group_by(dplyr::select( ard_effectsize_cohens_d(dplyr::filter(cards::ADSL, ARM %in% c("Placebo", @@ -30,20 +14,3 @@ 5 ARM HEIGHTBL effectsize_cohens_d CI Confidence Level 0.95 6 ARM HEIGHTBL effectsize_cohens_d CI Lower Bound -0.600975 -# ard_effectsize_paired_cohens_d() works - - Code - as.data.frame(dplyr::select(ard_effectsize_paired_cohens_d(dplyr::mutate( - ADSL_paired, ARM = ifelse(dplyr::row_number() == 1L, "3rd ARM", ARM)), by = ARM, - variable = AGE, id = USUBJID), c("variable", "stat_name", "error"))) - Output - variable stat_name error - 1 AGE estimate The `by` argument must have two and only two levels. - 2 AGE conf.level The `by` argument must have two and only two levels. - 3 AGE conf.low The `by` argument must have two and only two levels. - 4 AGE conf.high The `by` argument must have two and only two levels. - 5 AGE mu The `by` argument must have two and only two levels. - 6 AGE paired The `by` argument must have two and only two levels. - 7 AGE pooled_sd The `by` argument must have two and only two levels. - 8 AGE alternative The `by` argument must have two and only two levels. - diff --git a/tests/testthat/_snaps/ard_effectsize_hedges_g.md b/tests/testthat/_snaps/ard_effectsize_hedges_g.md index e06a4ae16..51de3474b 100644 --- a/tests/testthat/_snaps/ard_effectsize_hedges_g.md +++ b/tests/testthat/_snaps/ard_effectsize_hedges_g.md @@ -1,21 +1,5 @@ # ard_effectsize_hedges_g() works - Code - as.data.frame(dplyr::select(ard_effectsize_hedges_g(cards::ADSL, by = ARM, - variable = AGE), c("variable", "stat_name", "error"))) - Output - variable stat_name error - 1 AGE estimate Grouping variable y must have exactly 2 levels. - 2 AGE conf.level Grouping variable y must have exactly 2 levels. - 3 AGE conf.low Grouping variable y must have exactly 2 levels. - 4 AGE conf.high Grouping variable y must have exactly 2 levels. - 5 AGE mu Grouping variable y must have exactly 2 levels. - 6 AGE paired Grouping variable y must have exactly 2 levels. - 7 AGE pooled_sd Grouping variable y must have exactly 2 levels. - 8 AGE alternative Grouping variable y must have exactly 2 levels. - ---- - Code as.data.frame(dplyr::slice_head(dplyr::group_by(dplyr::select( ard_effectsize_hedges_g(dplyr::filter(cards::ADSL, ARM %in% c("Placebo", @@ -30,20 +14,3 @@ 5 ARM HEIGHTBL effectsize_hedges_g CI Confidence Level 0.95 6 ARM HEIGHTBL effectsize_hedges_g CI Lower Bound -0.5982873 -# ard_effectsize_paired_hedges_g() works - - Code - as.data.frame(dplyr::select(ard_effectsize_paired_hedges_g(dplyr::mutate( - ADSL_paired, ARM = ifelse(dplyr::row_number() == 1L, "3rd ARM", ARM)), by = ARM, - variable = AGE, id = USUBJID), c("variable", "stat_name", "error"))) - Output - variable stat_name error - 1 AGE estimate The `by` argument must have two and only two levels. - 2 AGE conf.level The `by` argument must have two and only two levels. - 3 AGE conf.low The `by` argument must have two and only two levels. - 4 AGE conf.high The `by` argument must have two and only two levels. - 5 AGE mu The `by` argument must have two and only two levels. - 6 AGE paired The `by` argument must have two and only two levels. - 7 AGE pooled_sd The `by` argument must have two and only two levels. - 8 AGE alternative The `by` argument must have two and only two levels. - diff --git a/tests/testthat/_snaps/ard_stats_t_test.md b/tests/testthat/_snaps/ard_stats_t_test.md deleted file mode 100644 index 0b378d374..000000000 --- a/tests/testthat/_snaps/ard_stats_t_test.md +++ /dev/null @@ -1,75 +0,0 @@ -# ard_stats_t_test() works - - Code - as.data.frame(ard_stats_t_test(cards::ADSL, by = ARM, variable = AGE, - var.equal = TRUE)) - Output - group1 variable context stat_name stat_label stat fmt_fn - 1 ARM AGE stats_t_test estimate Mean Difference NULL NULL - 2 ARM AGE stats_t_test estimate1 Group 1 Mean NULL NULL - 3 ARM AGE stats_t_test estimate2 Group 2 Mean NULL NULL - 4 ARM AGE stats_t_test statistic t Statistic NULL NULL - 5 ARM AGE stats_t_test p.value p-value NULL NULL - 6 ARM AGE stats_t_test parameter Degrees of Freedom NULL NULL - 7 ARM AGE stats_t_test conf.low CI Lower Bound NULL NULL - 8 ARM AGE stats_t_test conf.high CI Upper Bound NULL NULL - 9 ARM AGE stats_t_test method method NULL NULL - 10 ARM AGE stats_t_test alternative alternative NULL NULL - 11 ARM AGE stats_t_test mu H0 Mean 0 1 - 12 ARM AGE stats_t_test paired Paired t-test FALSE NULL - 13 ARM AGE stats_t_test var.equal Equal Variances TRUE NULL - 14 ARM AGE stats_t_test conf.level CI Confidence Level 0.95 1 - warning error - 1 NULL grouping factor must have exactly 2 levels - 2 NULL grouping factor must have exactly 2 levels - 3 NULL grouping factor must have exactly 2 levels - 4 NULL grouping factor must have exactly 2 levels - 5 NULL grouping factor must have exactly 2 levels - 6 NULL grouping factor must have exactly 2 levels - 7 NULL grouping factor must have exactly 2 levels - 8 NULL grouping factor must have exactly 2 levels - 9 NULL grouping factor must have exactly 2 levels - 10 NULL grouping factor must have exactly 2 levels - 11 NULL grouping factor must have exactly 2 levels - 12 NULL grouping factor must have exactly 2 levels - 13 NULL grouping factor must have exactly 2 levels - 14 NULL grouping factor must have exactly 2 levels - -# ard_stats_paired_t_test() works - - Code - as.data.frame(ard_stats_paired_t_test(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 stat fmt_fn - 1 ARM AGE stats_t_test estimate Mean Difference NULL NULL - 2 ARM AGE stats_t_test estimate1 Group 1 Mean NULL NULL - 3 ARM AGE stats_t_test estimate2 Group 2 Mean NULL NULL - 4 ARM AGE stats_t_test statistic t Statistic NULL NULL - 5 ARM AGE stats_t_test p.value p-value NULL NULL - 6 ARM AGE stats_t_test parameter Degrees of Freedom NULL NULL - 7 ARM AGE stats_t_test conf.low CI Lower Bound NULL NULL - 8 ARM AGE stats_t_test conf.high CI Upper Bound NULL NULL - 9 ARM AGE stats_t_test method method NULL NULL - 10 ARM AGE stats_t_test alternative alternative NULL NULL - 11 ARM AGE stats_t_test mu H0 Mean 0 1 - 12 ARM AGE stats_t_test paired Paired t-test TRUE NULL - 13 ARM AGE stats_t_test var.equal Equal Variances TRUE NULL - 14 ARM AGE stats_t_test conf.level CI Confidence Level 0.95 1 - warning error - 1 NULL The `by` argument must have two and only two levels. - 2 NULL The `by` argument must have two and only two levels. - 3 NULL The `by` argument must have two and only two levels. - 4 NULL The `by` argument must have two and only two levels. - 5 NULL The `by` argument must have two and only two levels. - 6 NULL The `by` argument must have two and only two levels. - 7 NULL The `by` argument must have two and only two levels. - 8 NULL The `by` argument must have two and only two levels. - 9 NULL The `by` argument must have two and only two levels. - 10 NULL The `by` argument must have two and only two levels. - 11 NULL The `by` argument must have two and only two levels. - 12 NULL The `by` argument must have two and only two levels. - 13 NULL The `by` argument must have two and only two levels. - 14 NULL The `by` argument must have two and only two levels. - diff --git a/tests/testthat/test-ard_car_vif.R b/tests/testthat/test-ard_car_vif.R index 390fdb77f..34ea2df7b 100644 --- a/tests/testthat/test-ard_car_vif.R +++ b/tests/testthat/test-ard_car_vif.R @@ -15,18 +15,12 @@ test_that("ard_car_vif() works", { }) test_that("ard_car_vif() appropriate errors are given for model with only 1 term", { - expect_snapshot( - lm(AGE ~ ARM, data = cards::ADSL) |> - ard_car_vif() |> - as.data.frame() - ) expect_equal( lm(AGE ~ ARM, data = cards::ADSL) |> ard_car_vif() |> - dplyr::select(error) |> - unlist() |> - unique(), - "model contains fewer than 2 terms" + dplyr::select(error) %>% + is.null(), + FALSE ) }) @@ -34,6 +28,6 @@ test_that("ard_car_vif() appropriate errors are given for model with only 1 term test_that("ard_vif() issues friendly messaging for incorrect object passed in/can't get terms of model", { expect_snapshot( error = TRUE, - cards::ADSL |> ard_vif() + cards::ADSL |> ard_car_vif() ) }) diff --git a/tests/testthat/test-ard_effectsize_cohens_d.R b/tests/testthat/test-ard_effectsize_cohens_d.R index fe5c771bf..cf846afe0 100644 --- a/tests/testthat/test-ard_effectsize_cohens_d.R +++ b/tests/testthat/test-ard_effectsize_cohens_d.R @@ -26,11 +26,12 @@ test_that("ard_effectsize_cohens_d() works", { ) # errors are properly handled - expect_snapshot( + expect_equal( cards::ADSL |> ard_effectsize_cohens_d(by = ARM, variables = AGE) |> - dplyr::select(c("variable", "stat_name", "error")) |> - as.data.frame() + dplyr::select(error) %>% + is.null(), + FALSE ) # test that the function works with multiple variables @@ -83,13 +84,14 @@ test_that("ard_effectsize_paired_cohens_d() works", { ) # errors are properly handled - expect_snapshot( + expect_equal( ADSL_paired |> dplyr::mutate( ARM = ifelse(dplyr::row_number() == 1L, "3rd ARM", ARM) ) |> ard_effectsize_paired_cohens_d(by = ARM, variable = AGE, id = USUBJID) |> - dplyr::select(c("variable", "stat_name", "error")) |> - as.data.frame() + dplyr::select(error) %>% + is.null(), + FALSE ) }) diff --git a/tests/testthat/test-ard_effectsize_hedges_g.R b/tests/testthat/test-ard_effectsize_hedges_g.R index 47f84ed93..3bd0024e0 100644 --- a/tests/testthat/test-ard_effectsize_hedges_g.R +++ b/tests/testthat/test-ard_effectsize_hedges_g.R @@ -24,11 +24,12 @@ test_that("ard_effectsize_hedges_g() works", { ) # errors are properly handled - expect_snapshot( + expect_equal( cards::ADSL |> ard_effectsize_hedges_g(by = ARM, variable = AGE) |> - dplyr::select(c("variable", "stat_name", "error")) |> - as.data.frame() + dplyr::select(error) %>% + is.null(), + FALSE ) # test that the function works with multiple variables as once @@ -83,13 +84,14 @@ test_that("ard_effectsize_paired_hedges_g() works", { ) # errors are properly handled - expect_snapshot( + expect_equal( ADSL_paired |> dplyr::mutate( ARM = ifelse(dplyr::row_number() == 1L, "3rd ARM", ARM) ) |> ard_effectsize_paired_hedges_g(by = ARM, variable = AGE, id = USUBJID) |> - dplyr::select(c("variable", "stat_name", "error")) |> - as.data.frame() + dplyr::select(error) %>% + is.null(), + FALSE ) }) diff --git a/tests/testthat/test-ard_stats_t_test.R b/tests/testthat/test-ard_stats_t_test.R index 15bb29a2d..9e487906a 100644 --- a/tests/testthat/test-ard_stats_t_test.R +++ b/tests/testthat/test-ard_stats_t_test.R @@ -44,10 +44,12 @@ test_that("ard_stats_t_test() works", { ) # errors are properly handled - expect_snapshot( + expect_equal( cards::ADSL |> ard_stats_t_test(by = ARM, variable = AGE, var.equal = TRUE) |> - as.data.frame() + dplyr::select(error) %>% + is.null(), + FALSE ) # test that the function works with multiple variables at once @@ -102,12 +104,14 @@ test_that("ard_stats_paired_t_test() works", { ) # errors are properly handled - expect_snapshot( + expect_equal( ADSL_paired |> dplyr::mutate( ARM = ifelse(dplyr::row_number() == 1L, "3rd ARM", ARM) ) |> ard_stats_paired_t_test(by = ARM, variable = AGE, id = USUBJID, var.equal = TRUE) |> - as.data.frame() + dplyr::select(error) %>% + is.null(), + FALSE ) }) From 07689a2f90af6c28e6d831caddd9ce4c982c557b Mon Sep 17 00:00:00 2001 From: ddsjoberg Date: Thu, 25 Apr 2024 18:20:40 +0000 Subject: [PATCH 14/14] [skip actions] Bump version to 0.1.0.9028 --- DESCRIPTION | 2 +- NEWS.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6ab961ebb..3839a677f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: cardx Title: Extra Analysis Results Data Utilities -Version: 0.1.0.9027 +Version: 0.1.0.9028 Authors@R: c( person("Daniel", "Sjoberg", , "danield.sjoberg@gmail.com", role = c("aut", "cre")), person("Abinaya", "Yogasekaram", , "abinaya.yogasekaram@contractors.roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index 8464b2800..27ee17f65 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# cardx 0.1.0.9027 +# cardx 0.1.0.9028 ### Breaking Changes