diff --git a/.Rbuildignore b/.Rbuildignore index c1d8c7e..8358911 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,3 +12,4 @@ ^README\.md$ ^rsconnect$ ^tpma-explorer\.Rproj$ +^.cache$ \ No newline at end of file diff --git a/.lintr b/.lintr index 52b33f6..e0a6781 100644 --- a/.lintr +++ b/.lintr @@ -1,3 +1,7 @@ +linters: linters_with_defaults( + line_length_linter(120), + object_length_linter(50) + ) exclusions: list( "data-raw/la-lookups.R" ) diff --git a/DESCRIPTION b/DESCRIPTION index 9e568d1..b82371f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: tpma.explorer Title: Explore TPMA Data -Version: 0.2.0.9000 +Version: 0.3.4 Authors@R: c( person("Matt", "Dray", , "matt.dray@nhs.net", role = c("aut", "cre")), person("Tom", "Jemmett", , "thomas.jemmett@nhs.net", role = "aut") @@ -18,6 +18,7 @@ Imports: AzureStor, bsicons, bslib, + cachem, config, dplyr, forcats, @@ -26,6 +27,7 @@ Imports: ggrepel, glue, gt, + httr2, jsonlite, markdown, purrr, @@ -36,11 +38,16 @@ Imports: shinycssloaders, stringr, tibble, - tidyr, - tidyselect, - withr + tidyr Remotes: The-Strategy-Unit/azkit Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 +Suggests: + mockery, + testthat (>= 3.0.0), + tidyselect, + vdiffr, + withr +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 8a933e6..3e4a64c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,15 +1,18 @@ # Generated by roxygen2: do not edit by hand -export(convert_md_to_html) export(entable_encounters) export(fetch_strategy_text) export(generate_rates_baseline_data) export(get_all_geo_data) export(get_container) export(get_golem_config) +export(get_peers_lookup) +export(get_rates_data) +export(get_rates_trend_data) export(isolate_provider_peers) export(make_strategy_group_lookup) export(md_file_to_html) +export(md_string_to_html) export(plot_age_sex_pyramid) export(plot_nee) export(plot_rates_box) diff --git a/R/add_external_resources.R b/R/add_external_resources.R index 5003741..aea7814 100644 --- a/R/add_external_resources.R +++ b/R/add_external_resources.R @@ -1,17 +1,3 @@ -#' Add External Resources to the Application -#' This function is internally used to add external resources inside the Shiny -#' application. -#' @noRd -add_external_resources <- function() { - shiny::addResourcePath( - "www", - app_sys("app/www") - ) - shiny::singleton( - shiny::tags$head() - ) -} - #' Access Files in the Current App #' @param ... Character vectors, specifying subdirectory and file(s) #' within your package. The default, none, returns the root of the app. diff --git a/R/fct_azure.R b/R/fct_azure.R deleted file mode 100644 index 63286b1..0000000 --- a/R/fct_azure.R +++ /dev/null @@ -1,32 +0,0 @@ -#' Get Azure Container -#' @param tenant Character. Tenant ID. -#' @param app_id Character. App ID. -#' @param ep_uri Character. Endpoint URI. -#' @param container_name Character. The name of the blob/storage container that -#' hosts files you want to read. -#' @return A blob_container/storage_container list. -#' @export -get_container <- function( - ep_uri = Sys.getenv("AZ_STORAGE_EP"), - container_name = Sys.getenv("AZ_CONTAINER_INPUTS") -) { - # if the app_id variable is empty, we assume that this is running on an Azure - # VM, and then we will use Managed Identities for authentication. - - token <- tryCatch( - { - AzureAuth::get_managed_token("https://storage.azure.com/") - }, - error = function(...) { - AzureAuth::get_azure_token( - resource = "https://storage.azure.com", - tenant = "common", - app = "04b07795-8ddb-461a-bbee-02f9e1bf7b46", - use_cache = TRUE # avoid browser-authorisation prompt - ) - } - ) - ep_uri |> - AzureStor::blob_endpoint(token = token) |> - AzureStor::storage_container(container_name) -} diff --git a/R/mod_plot_rates.R b/R/mod_plot_rates.R index ecf5641..2336963 100644 --- a/R/mod_plot_rates.R +++ b/R/mod_plot_rates.R @@ -35,77 +35,45 @@ mod_plot_rates_server <- function( ) { # load static data items strategies_config <- get_golem_config("mitigators_config") + strategy_group_lookup <- make_strategy_group_lookup(strategies_config) # return the shiny module shiny::moduleServer(id, function(input, output, session) { peers_lookup <- shiny::reactive({ - filename <- switch( - selected_geography(), - "nhp" = "nhp-peers.csv", - "la" = "la-peers.csv" - ) - - shiny::req(filename) - - readr::read_csv( - app_sys("app", "data", filename), - col_types = "c" - ) + get_peers_lookup(selected_geography()) }) |> shiny::bindCache(selected_geography()) # Prepare data ---- rates_data <- shiny::reactive({ - df <- inputs_data()[["rates"]] - - national <- df |> - dplyr::filter(.data$provider == "national") |> - dplyr::select( - "strategy", - "fyear", - national_rate = "std_rate" - ) - - df |> - dplyr::filter(!.data$provider %in% c("national", "unknown")) |> - dplyr::inner_join( - national, - by = c("strategy", "fyear") - ) |> - dplyr::rename(rate = "std_rate") |> - dplyr::select(-"crude_rate") + strategy <- shiny::req(selected_strategy()) + + get_rates_data( + inputs_data()[["rates"]], + strategy + ) }) rates_trend_data <- shiny::reactive({ - shiny::req(rates_data()) - shiny::req(selected_provider()) - shiny::req(selected_strategy()) + df <- shiny::req(rates_data()) + provider <- shiny::req(selected_provider()) - rates_data() |> - dplyr::filter( - .data$provider == selected_provider(), - .data$strategy == selected_strategy() - ) |> - dplyr::arrange(.data$fyear) + get_rates_trend_data(df, provider) }) rates_baseline_data <- shiny::reactive({ - shiny::req(rates_data()) - shiny::req(peers_lookup()) - shiny::req(selected_provider()) - shiny::req(selected_strategy()) - - provider_peers <- isolate_provider_peers( - selected_provider(), - peers_lookup() + df <- shiny::req(rates_data()) + peers_lookup <- shiny::req(peers_lookup()) + provider <- shiny::req(selected_provider()) + strategy <- shiny::req(selected_strategy()) + year <- shiny::req(selected_year()) + + generate_rates_baseline_data( + df, + provider, + peers_lookup, + year ) - rates_data() |> - generate_rates_baseline_data( - selected_provider(), - provider_peers, - selected_strategy(), - selected_year() - ) }) rates_funnel_calculations <- shiny::reactive({ @@ -133,15 +101,9 @@ mod_plot_rates_server <- function( }) strategy_config <- shiny::reactive({ - shiny::req(strategies_config) - shiny::req(selected_strategy()) - - strategy_group_lookup <- strategies_config |> make_strategy_group_lookup() - - strategy_group <- strategy_group_lookup |> - dplyr::filter(.data$strategy == selected_strategy()) |> - dplyr::pull("group") + strategy <- shiny::req(selected_strategy()) + strategy_group <- strategy_group_lookup[[strategy]] strategies_config[[strategy_group]] }) diff --git a/R/mod_select_geography.R b/R/mod_select_geography.R index 2223aee..4784ded 100644 --- a/R/mod_select_geography.R +++ b/R/mod_select_geography.R @@ -6,7 +6,10 @@ mod_select_geography_ui <- function(id) { shiny::selectInput( ns("geography_select"), "Filter by geography:", - choices = NULL + choices = c( + "NHS provider trusts" = "nhp", + "Local authorities (LAs)" = "la" + ) ) } @@ -14,20 +17,7 @@ mod_select_geography_ui <- function(id) { #' @param id Internal parameter for `shiny`. #' @noRd mod_select_geography_server <- function(id) { - geographies <- c( - "NHS provider trusts" = "nhp", - "Local authorities (LAs)" = "la" - ) - shiny::moduleServer(id, function(input, output, session) { - shiny::observe({ - shiny::req(geographies) - shiny::updateSelectInput( - session, - "geography_select", - choices = geographies - ) - }) shiny::reactive(input$geography_select) }) } diff --git a/R/mod_select_strategy.R b/R/mod_select_strategy.R index 3e7b4f6..2a40777 100644 --- a/R/mod_select_strategy.R +++ b/R/mod_select_strategy.R @@ -21,47 +21,53 @@ mod_select_strategy_ui <- function(id) { ) } -#' Select Strategy Server -#' @param id Internal parameter for `shiny`. +#' Get TPMAs for the drop down menu +#' +#' Reads the mitigators.json file and extracts the name and category (IP/OP/AE). +#' +#' @return A named list of data frames, where the names are the categories (IP/OP/AE) #' @noRd -mod_select_strategy_server <- function(id) { - # load static data items +mod_select_strategy_get_strategies <- function() { strategies <- jsonlite::read_json( app_sys("app", "data", "mitigators.json"), simplify_vector = TRUE ) + strategies |> + unlist() |> + tibble::enframe("strategy", "name") |> + dplyr::mutate( + category = stringr::str_extract( + .data$name, + "(?<= \\()(IP|OP|AE)(?=-(AA|EF))" # e.g. 'IP' in 'IP-AA-001' + ) |> + stringr::str_to_lower() + ) |> + dplyr::nest_by(.data$category) |> + tibble::deframe() +} + +#' Select Strategy Server +#' @param id Internal parameter for `shiny`. +#' @noRd +mod_select_strategy_server <- function(id) { + # load static data items + strategies <- mod_select_strategy_get_strategies() + # return the shiny module shiny::moduleServer(id, function(input, output, session) { - shiny::req(strategies) - - select_category <- shiny::reactive({ + selected_category <- shiny::reactive({ shiny::req(input$strategy_category_select) input$strategy_category_select }) shiny::observe({ - shiny::req(select_category()) + category <- shiny::req(selected_category()) - category_strategies <- strategies |> - unlist() |> - tibble::enframe("strategy", "name") |> - dplyr::mutate( - category = stringr::str_extract( - .data$name, - "(?<= \\()(IP|OP|AE)(?=-(AA|EF))" # e.g. 'IP' in 'IP-AA-001' - ) |> - stringr::str_to_lower() - ) |> - dplyr::filter(.data$category == select_category()) |> - dplyr::select("strategy", "name") |> + strategy_choices <- strategies[[category]] |> + dplyr::select("name", "strategy") |> tibble::deframe() - strategy_choices <- purrr::set_names( - names(category_strategies), - category_strategies - ) - shiny::updateSelectInput( session, "strategy_select", diff --git a/R/mod_show_strategy_text.R b/R/mod_show_strategy_text.R index b0d76fe..a177711 100644 --- a/R/mod_show_strategy_text.R +++ b/R/mod_show_strategy_text.R @@ -13,6 +13,16 @@ mod_show_strategy_text_ui <- function(id) { ) } +#' Get Strategy descriptions Lookup +#' @return a character vector of the strategy stubs. +#' @noRd +mod_show_strategy_text_get_descriptions_lookup <- function() { + jsonlite::read_json( + app_sys("app", "data", "descriptions.json"), + simplifyVector = TRUE + ) +} + #' Show Strategy Description Server #' @param id Internal parameter for `shiny`. #' @noRd @@ -21,20 +31,26 @@ mod_show_strategy_text_server <- function( selected_strategy ) { # load static data items - descriptions_lookup <- jsonlite::read_json( - app_sys("app", "data", "descriptions.json"), - simplifyVector = TRUE - ) + descriptions_lookup <- mod_show_strategy_text_get_descriptions_lookup() # return the shiny module shiny::moduleServer(id, function(input, output, session) { - output$strategy_text <- shiny::renderText({ - shiny::req(selected_strategy()) - shiny::req(descriptions_lookup) - selected_strategy() |> - fetch_strategy_text(descriptions_lookup) |> - convert_md_to_html() + strategy_stub <- shiny::reactive({ + strategy <- shiny::req(selected_strategy()) + + is_stub <- stringr::str_detect(strategy, descriptions_lookup) + descriptions_lookup[is_stub] + }) + + strategy_text <- shiny::reactive({ + s <- shiny::req(strategy_stub()) + fetch_strategy_text(s) }) |> - shiny::bindCache(selected_strategy()) + shiny::bindCache(strategy_stub()) + + output$strategy_text <- shiny::renderText({ + t <- shiny::req(strategy_text()) + md_string_to_html(t) + }) }) } diff --git a/R/utils_data.R b/R/utils_data.R index 95a9e3a..b5c39f7 100644 --- a/R/utils_data.R +++ b/R/utils_data.R @@ -69,21 +69,23 @@ get_golem_config <- function( #' @param strategies_config List. Configuration for strategies from the #' `"mitigators_config"` element of `golem-config.yml`, read in with #' [get_golem_config]. -#' @return A data.frame. +#' @return A lookup from strategy name to strategy group name. #' @export make_strategy_group_lookup <- function(strategies_config) { strategies_config |> purrr::map(\(strategy_group) { - strategy_group |> purrr::pluck("strategy_subset") |> names() + strategy_group |> + purrr::pluck("strategy_subset") |> + names() }) |> - tibble::enframe(name = "group", value = "strategy") |> - tidyr::unnest_longer("strategy") + purrr::imap(\(.x, .y) purrr::set_names(rep(.y, length(.x)), .x)) |> + purrr::flatten() } #' Read an Markdown File and Convert to HTML #' @param ... Character vectors. Construct a path to a Markdown file (like #' [file.path]). -#' @return A data.frame. +#' @return A shiny HTML object. #' @export md_file_to_html <- function(...) { file <- app_sys(...) @@ -92,3 +94,11 @@ md_file_to_html <- function(...) { } shiny::HTML(markdown::mark_html(file, output = FALSE, template = FALSE)) } + +#' Convert a Markdown String to HTML +#' @param text Character string. Markdown text to convert to HTML. +#' @return A shiny HTML object. +#' @export +md_string_to_html <- function(text) { + shiny::HTML(markdown::mark_html(text, output = FALSE, template = FALSE)) +} diff --git a/R/utils_plot.R b/R/utils_plot.R index be485a2..cf4b441 100644 --- a/R/utils_plot.R +++ b/R/utils_plot.R @@ -14,24 +14,20 @@ isolate_provider_peers <- function(provider, peers) { #' Generate Rates Baseline Data #' @param rates A data.frame. Rates data read from Azure. #' @param provider Character. Provider code, e.g. `"RCF"`. -#' @param peers Character. A vector of peers for given `provider`. -#' @param strategy Character. Strategy variable name, e.g. -#' `"alcohol_partially_attributable_acute"`. +#' @param peers_lookup Dataframe. A lookup from a provider to its peers. #' @param selected_year Integer. Baseline year in the form `202324`. #' @return A data.frame. #' @export generate_rates_baseline_data <- function( rates, provider, - peers, - strategy, + peers_lookup, selected_year ) { + peers <- isolate_provider_peers(provider, peers_lookup) + rates |> - dplyr::filter( - .data$strategy == .env$strategy, - .data$fyear == .env$selected_year - ) |> + dplyr::filter(.data$fyear == .env$selected_year) |> dplyr::mutate( is_peer = dplyr::case_when( .data$provider == .env$provider ~ FALSE, diff --git a/R/utils_plot_rates.R b/R/utils_plot_rates.R new file mode 100644 index 0000000..55ddcfc --- /dev/null +++ b/R/utils_plot_rates.R @@ -0,0 +1,73 @@ +#' Get Peers Lookup +#' +#' Reads the appropriate peers lookup file based on the selected geography. +#' +#' @param selected_geography Character. The selected geography, e.g. "nhp" or "la". +#' +#' @return A data.frame with provider codes and their corresponding peers. +#' +#' @export +get_peers_lookup <- function(selected_geography) { + filename <- switch( + selected_geography, + "nhp" = "nhp-peers.csv", + "la" = "la-peers.csv" + ) + + shiny::req(filename) + + readr::read_csv( + app_sys("app", "data", filename), + col_types = "c" + ) +} + +#' Get Rates Data +#' +#' This function prepares the data for the rates_data() reactive. It moves the +#' national row to a separate column. +#' +#' @param df the rates data from inputs_data +#' @param strategy Character. Strategy variable name to filter rows to +#' +#' @return Dataframe with national rates in a separate column +#' +#' @export +get_rates_data <- function(df, strategy) { + df <- df |> + dplyr::filter(.data$strategy == .env$strategy) + + national <- df |> + dplyr::filter(.data$provider == "national") |> + dplyr::select( + "strategy", + "fyear", + national_rate = "std_rate" + ) + + df |> + dplyr::filter(!.data$provider %in% c("national", "unknown")) |> + dplyr::inner_join( + national, + by = c("strategy", "fyear") + ) |> + dplyr::rename(rate = "std_rate") |> + dplyr::select(-"crude_rate") +} + +#' Get Rates Trend Data +#' +#' Extracts the trend for a specific provider from the rates data +#' (see [get_rates_data]). +#' +#' @param df A data.frame. Prepared by get_rates_data +#' @param provider Character. Provider code, e.g. `"RCF"`. +#' +#' @return Dataframe filtered to the specific provider +#' +#' @export +get_rates_trend_data <- function(df, provider) { + df |> + dplyr::filter(.data$provider == .env$provider) |> + dplyr::arrange(.data$fyear) +} diff --git a/R/utils_server.R b/R/utils_server.R index 70487e3..7dbe51d 100644 --- a/R/utils_server.R +++ b/R/utils_server.R @@ -1,12 +1,41 @@ +#' Get Azure Container +#' @param ep_uri Character. Endpoint URI. +#' @param container_name Character. The name of the blob/storage container that +#' hosts files you want to read. +#' @return A blob_container/storage_container list. +#' @export +get_container <- function( + ep_uri = Sys.getenv("AZ_STORAGE_EP"), + container_name = Sys.getenv("AZ_CONTAINER_INPUTS") +) { + # if the app_id variable is empty, we assume that this is running on an Azure + # VM, and then we will use Managed Identities for authentication. + + token <- tryCatch( + { + AzureAuth::get_managed_token("https://storage.azure.com/") + }, + error = function(...) { + AzureAuth::get_azure_token( + resource = "https://storage.azure.com", + tenant = "common", + app = "04b07795-8ddb-461a-bbee-02f9e1bf7b46", + use_cache = TRUE # avoid browser-authorisation prompt + ) + } + ) + ep_uri |> + AzureStor::blob_endpoint(token = token) |> + AzureStor::storage_container(container_name) +} + #' Read Inputs Datasets for All Geographies #' @param geography Character. The geography level for which the user wants to #' select a provider. Either "nhp" or "la". #' @return A list. One element for each dataframes of data. #' @export get_all_geo_data <- function(geography) { - inputs_container <- get_container( - container_name = Sys.getenv("AZ_CONTAINER_INPUTS") - ) + inputs_container <- get_container() data_types <- purrr::set_names(c( "age_sex", diff --git a/R/utils_show_strategy_text.R b/R/utils_show_strategy_text.R index 2b1980e..0bf3835 100644 --- a/R/utils_show_strategy_text.R +++ b/R/utils_show_strategy_text.R @@ -1,36 +1,23 @@ #' Fetch Strategy Text from NHP Inputs -#' @param strategy Character. Strategy variable name, e.g. -#' `"alcohol_partially_attributable_acute"`. -#' @param descriptions_lookup Character. The names of the available Markdown -#' description files. +#' @param strategy_stub Character. Strategy variable name stub, e.g. +#' `"alcohol_partially_attributable"`. #' @details Markdown files containing strategy descriptions are read from #' [NHP Inputs](https://github.com/The-Strategy-Unit/nhp_inputs/). #' @return Character. #' @export -fetch_strategy_text <- function(strategy, descriptions_lookup) { - is_stub <- stringr::str_detect(strategy, descriptions_lookup) - strategy_stub <- descriptions_lookup[is_stub] - - withr::with_tempfile("temp", { - # nolint start object_usage_linter. - utils::download.file( - glue::glue( - "https://raw.githubusercontent.com/The-Strategy-Unit/nhp_inputs/", - "refs/heads/main/inst/app/strategy_text/{strategy_stub}.md" - ), - temp - ) - cat("\n", file = temp, append = TRUE) # stop 'incomplete final line' warning - paste(readLines(temp), collapse = "\n") - # nolint end - }) -} - -#' Convert Strategy Text from Markdown to HTML -#' @param text Character. The Markdown text description for a strategy, as read -#' by [fetch_strategy_text]. -#' @return HTML/character. -#' @export -convert_md_to_html <- function(text) { - shiny::HTML(markdown::mark_html(text, output = FALSE, template = FALSE)) +fetch_strategy_text <- function(strategy_stub) { + httr2::request("https://raw.githubusercontent.com") |> + httr2::req_url_path( + "The-Strategy-Unit", + "nhp_inputs", + "refs", + "heads", + "main", + "inst", + "app", + "strategy_text", + glue::glue("{strategy_stub}.md") + ) |> + httr2::req_perform() |> + httr2::resp_body_string() } diff --git a/R/utils_table.R b/R/utils_table.R index 38a1c06..5d6a1a0 100644 --- a/R/utils_table.R +++ b/R/utils_table.R @@ -80,12 +80,12 @@ prepare_diagnoses_data <- function( } diagnoses_prepared <- diagnoses_filtered |> - dplyr::inner_join( + dplyr::left_join( diagnoses_lookup, by = c("diagnosis" = "diagnosis_code") ) |> tidyr::replace_na(list( - description = "Unknown/Invalid Diagnosis Code" + diagnosis_description = "Unknown/Invalid Diagnosis Code" )) |> dplyr::select("diagnosis_description", "n", "pcnt") diff --git a/air.toml b/air.toml new file mode 100644 index 0000000..e637396 --- /dev/null +++ b/air.toml @@ -0,0 +1,3 @@ +[format] +line-width = 120 +skip = ["tribble"] \ No newline at end of file diff --git a/man/convert_md_to_html.Rd b/man/convert_md_to_html.Rd deleted file mode 100644 index 2947999..0000000 --- a/man/convert_md_to_html.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils_show_strategy_text.R -\name{convert_md_to_html} -\alias{convert_md_to_html} -\title{Convert Strategy Text from Markdown to HTML} -\usage{ -convert_md_to_html(text) -} -\arguments{ -\item{text}{Character. The Markdown text description for a strategy, as read -by \link{fetch_strategy_text}.} -} -\value{ -HTML/character. -} -\description{ -Convert Strategy Text from Markdown to HTML -} diff --git a/man/fetch_strategy_text.Rd b/man/fetch_strategy_text.Rd index 8d5e1f1..69e188a 100644 --- a/man/fetch_strategy_text.Rd +++ b/man/fetch_strategy_text.Rd @@ -4,14 +4,11 @@ \alias{fetch_strategy_text} \title{Fetch Strategy Text from NHP Inputs} \usage{ -fetch_strategy_text(strategy, descriptions_lookup) +fetch_strategy_text(strategy_stub) } \arguments{ -\item{strategy}{Character. Strategy variable name, e.g. -\code{"alcohol_partially_attributable_acute"}.} - -\item{descriptions_lookup}{Character. The names of the available Markdown -description files.} +\item{strategy_stub}{Character. Strategy variable name stub, e.g. +\code{"alcohol_partially_attributable"}.} } \value{ Character. diff --git a/man/generate_rates_baseline_data.Rd b/man/generate_rates_baseline_data.Rd index 03b56e3..0a76d03 100644 --- a/man/generate_rates_baseline_data.Rd +++ b/man/generate_rates_baseline_data.Rd @@ -4,17 +4,14 @@ \alias{generate_rates_baseline_data} \title{Generate Rates Baseline Data} \usage{ -generate_rates_baseline_data(rates, provider, peers, strategy, selected_year) +generate_rates_baseline_data(rates, provider, peers_lookup, selected_year) } \arguments{ \item{rates}{A data.frame. Rates data read from Azure.} \item{provider}{Character. Provider code, e.g. \code{"RCF"}.} -\item{peers}{Character. A vector of peers for given \code{provider}.} - -\item{strategy}{Character. Strategy variable name, e.g. -\code{"alcohol_partially_attributable_acute"}.} +\item{peers_lookup}{Dataframe. A lookup from a provider to its peers.} \item{selected_year}{Integer. Baseline year in the form \code{202324}.} } diff --git a/man/get_container.Rd b/man/get_container.Rd index fc470c7..8d98d38 100644 --- a/man/get_container.Rd +++ b/man/get_container.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fct_azure.R +% Please edit documentation in R/utils_server.R \name{get_container} \alias{get_container} \title{Get Azure Container} @@ -14,10 +14,6 @@ get_container( \item{container_name}{Character. The name of the blob/storage container that hosts files you want to read.} - -\item{tenant}{Character. Tenant ID.} - -\item{app_id}{Character. App ID.} } \value{ A blob_container/storage_container list. diff --git a/man/get_peers_lookup.Rd b/man/get_peers_lookup.Rd new file mode 100644 index 0000000..f74df54 --- /dev/null +++ b/man/get_peers_lookup.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_plot_rates.R +\name{get_peers_lookup} +\alias{get_peers_lookup} +\title{Get Peers Lookup} +\usage{ +get_peers_lookup(selected_geography) +} +\arguments{ +\item{selected_geography}{Character. The selected geography, e.g. "nhp" or "la".} +} +\value{ +A data.frame with provider codes and their corresponding peers. +} +\description{ +Reads the appropriate peers lookup file based on the selected geography. +} diff --git a/man/get_rates_data.Rd b/man/get_rates_data.Rd new file mode 100644 index 0000000..4d9e127 --- /dev/null +++ b/man/get_rates_data.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_plot_rates.R +\name{get_rates_data} +\alias{get_rates_data} +\title{Get Rates Data} +\usage{ +get_rates_data(df, strategy) +} +\arguments{ +\item{df}{the rates data from inputs_data} + +\item{strategy}{Character. Strategy variable name to filter rows to} +} +\value{ +Dataframe with national rates in a separate column +} +\description{ +This function prepares the data for the rates_data() reactive. It moves the +national row to a separate column. +} diff --git a/man/get_rates_trend_data.Rd b/man/get_rates_trend_data.Rd new file mode 100644 index 0000000..b7cf153 --- /dev/null +++ b/man/get_rates_trend_data.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_plot_rates.R +\name{get_rates_trend_data} +\alias{get_rates_trend_data} +\title{Get Rates Trend Data} +\usage{ +get_rates_trend_data(df, provider) +} +\arguments{ +\item{df}{A data.frame. Prepared by get_rates_data} + +\item{provider}{Character. Provider code, e.g. \code{"RCF"}.} +} +\value{ +Dataframe filtered to the specific provider +} +\description{ +Extracts the trend for a specific provider from the rates data +(see \link{get_rates_data}). +} diff --git a/man/make_strategy_group_lookup.Rd b/man/make_strategy_group_lookup.Rd index 5edb755..111cfa2 100644 --- a/man/make_strategy_group_lookup.Rd +++ b/man/make_strategy_group_lookup.Rd @@ -12,7 +12,7 @@ make_strategy_group_lookup(strategies_config) \link{get_golem_config}.} } \value{ -A data.frame. +A lookup from strategy name to strategy group name. } \description{ Create a Simple Lookup of Strategies to Strategy Groups diff --git a/man/md_file_to_html.Rd b/man/md_file_to_html.Rd index 69bb163..d6e504f 100644 --- a/man/md_file_to_html.Rd +++ b/man/md_file_to_html.Rd @@ -11,7 +11,7 @@ md_file_to_html(...) \link{file.path}).} } \value{ -A data.frame. +A shiny HTML object. } \description{ Read an Markdown File and Convert to HTML diff --git a/man/md_string_to_html.Rd b/man/md_string_to_html.Rd new file mode 100644 index 0000000..5b05497 --- /dev/null +++ b/man/md_string_to_html.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_data.R +\name{md_string_to_html} +\alias{md_string_to_html} +\title{Convert a Markdown String to HTML} +\usage{ +md_string_to_html(text) +} +\arguments{ +\item{text}{Character string. Markdown text to convert to HTML.} +} +\value{ +A shiny HTML object. +} +\description{ +Convert a Markdown String to HTML +} diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..99f4fcf --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(tpma.explorer) + +test_check("tpma.explorer") diff --git a/tests/testthat/_snaps/app_ui.md b/tests/testthat/_snaps/app_ui.md new file mode 100644 index 0000000..a45f2c0 --- /dev/null +++ b/tests/testthat/_snaps/app_ui.md @@ -0,0 +1,197 @@ +# ui + + Code + ui + Output + + +
+
+
+
+
+
+
+
+ + Warning +
+
+ This app is in development and its output has not been verified. + The information presented here should not be relied on as fact. +
+ +
+ +
mod_show_strategy_text
+
+
+
mod_plot_rates
+
+
+
mod_table_procedures
+
mod_table_diagnoses
+
+
+
+
+
mod_plot_age_sex_pyramid
+
mod_plot_nee
+
+
+
+
+ +
+
+ +
+ +
+
+
Purpose
+

View summaries of data for Types of Potentially-Mitigatable Activity (TPMAs) for statistical units within different geographical categories.

+
+ +
+
+
+
+
Definitions
+

Visit the New Hospital Programme (NHP) project information website to:

+ +
+ +
+
+
+
+
Data
+

Placeholder.

+
+ +
+
+ +
+
+ +
+
+
Navigation
+

First, make selections in the left-hand panel:

+
    +
  1. From the Visualisations section: +
      +
    • Select from the Filter by geography dropdown to choose a geographical categorisation.
      • +
    • Select a statistical unit from the Choose dropdown to view its data.
      • +
    +
    2. +
  2. From the Types of potentially mitigatable activity (TPMAs) section: +
      +
    • Select from the Filter by activity type dropdown to choose from a category of TPMAs.
      • +
    • Select a TPMA from the Choose a TPMA dropdown to view data for that TPMA (your selections will automatically update the content of the Data section of the app).
      • +
    +
    3. +
  3. Use the navigation bar at the top to visit different sections of the app. Visit the: +
      +
    • Information tab (current tab) for background information and instructions.
      • +
    • Visualisations tab to view a description of the selected TPMA
      • +
    +
    4. +
+
+ +
+
+
+
+
Interface
+

You can hover over the information symbol () for further information about a visualisation.

+

To maximise the space for visualisations, you can:

+
    +
  • click the expand button () in the lower-right of a plot to expand to full screen
    • +
  • collapse the sidebar by clicking the toggle sidebar chevron in its upper-right corner
    • +
+
+ +
+
+ +
+ +
+
+
+
+ + + +
+
+ + diff --git a/tests/testthat/_snaps/fct_plots.md b/tests/testthat/_snaps/fct_plots.md new file mode 100644 index 0000000..b0492d0 --- /dev/null +++ b/tests/testthat/_snaps/fct_plots.md @@ -0,0 +1,44 @@ +# theme_rates (has_y_axis = TRUE) + + Code + actual + Output + List of 3 + $ legend.position : chr "none" + $ panel.background : + $ panel.grid.major.y: + ..@ colour : chr "#9d928a" + ..@ linewidth : NULL + ..@ linetype : chr "dotted" + ..@ lineend : NULL + ..@ linejoin : NULL + ..@ arrow : logi FALSE + ..@ arrow.fill : chr "#9d928a" + ..@ inherit.blank: logi FALSE + @ complete: logi FALSE + @ validate: logi TRUE + +# theme_rates (has_y_axis = FALSE) + + Code + actual + Output + List of 7 + $ legend.position : chr "none" + $ panel.background : + $ panel.grid.major.y: + ..@ colour : chr "#9d928a" + ..@ linewidth : NULL + ..@ linetype : chr "dotted" + ..@ lineend : NULL + ..@ linejoin : NULL + ..@ arrow : logi FALSE + ..@ arrow.fill : chr "#9d928a" + ..@ inherit.blank: logi FALSE + $ axis.title.y : + $ axis.text.y : + $ axis.ticks.x : + $ axis.ticks.y : + @ complete: logi FALSE + @ validate: logi TRUE + diff --git a/tests/testthat/_snaps/fct_plots/plot-age-sex-pyramid.svg b/tests/testthat/_snaps/fct_plots/plot-age-sex-pyramid.svg new file mode 100644 index 0000000..d46e121 --- /dev/null +++ b/tests/testthat/_snaps/fct_plots/plot-age-sex-pyramid.svg @@ -0,0 +1,152 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0-4 +5-9 +10-14 +15-19 +20-24 +25-29 +30-34 +35-39 +40-44 +45-49 +50-54 +55-59 +60-64 +65-69 +70-74 +75-79 +80-84 +85-89 +90+ + + + + + + + + + + + + + + + + + + + + + + + + +20 +10 +0 +10 +20 + + + +Females +Males +plot_age_sex_pyramid + + diff --git a/tests/testthat/_snaps/fct_plots/plot-nee.svg b/tests/testthat/_snaps/fct_plots/plot-nee.svg new file mode 100644 index 0000000..06afcab --- /dev/null +++ b/tests/testthat/_snaps/fct_plots/plot-nee.svg @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0 +25 +50 +75 +100 +80% prediction interval +plot_nee + + diff --git a/tests/testthat/_snaps/fct_plots/plot-rates-box.svg b/tests/testthat/_snaps/fct_plots/plot-rates-box.svg new file mode 100644 index 0000000..210403b --- /dev/null +++ b/tests/testthat/_snaps/fct_plots/plot-rates-box.svg @@ -0,0 +1,50 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +plot_rates_box + + diff --git a/tests/testthat/_snaps/fct_plots/plot-rates-funnel.svg b/tests/testthat/_snaps/fct_plots/plot-rates-funnel.svg new file mode 100644 index 0000000..0b58fa7 --- /dev/null +++ b/tests/testthat/_snaps/fct_plots/plot-rates-funnel.svg @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +a +b +c +d +i + + +0 +1,000 +2,000 +Population size +plot_rates_funnel + + diff --git a/tests/testthat/_snaps/fct_plots/plot-rates-trend.svg b/tests/testthat/_snaps/fct_plots/plot-rates-trend.svg new file mode 100644 index 0000000..4e27879 --- /dev/null +++ b/tests/testthat/_snaps/fct_plots/plot-rates-trend.svg @@ -0,0 +1,79 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +0.0% +5.0% +10.0% +15.0% + + + + + + + + + + + + + +2015/16 +2016/17 +2017/18 +2018/19 +2019/20 +2020/21 +2021/22 +2022/23 +2023/24 +Financial year +Rate per 100,000 population +plot_rates_trend + + diff --git a/tests/testthat/_snaps/fct_table.md b/tests/testthat/_snaps/fct_table.md new file mode 100644 index 0000000..77d7d9f --- /dev/null +++ b/tests/testthat/_snaps/fct_table.md @@ -0,0 +1,966 @@ +# entable_encounters (diagnoses) + + Code + actual + Output +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + +
DiagnosisCount of Activity (spells)% of Total Activity
A10050.0%
B5025.0%
C2512.5%
Other2512.5%
Total200—
+
+ +# entable_encounters (procedures) + + Code + actual + Output +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + +
ProceduresCount of Activity (spells)% of Total Activity
A10050.0%
B5025.0%
C2512.5%
Other2512.5%
Total200—
+
+ diff --git a/tests/testthat/_snaps/mod_plot_age_sex_pyramid.md b/tests/testthat/_snaps/mod_plot_age_sex_pyramid.md new file mode 100644 index 0000000..533b4f9 --- /dev/null +++ b/tests/testthat/_snaps/mod_plot_age_sex_pyramid.md @@ -0,0 +1,33 @@ +# ui + + Code + ui + Output +
+
+
+ Age-sex pyramid + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/_snaps/mod_plot_nee.md b/tests/testthat/_snaps/mod_plot_nee.md new file mode 100644 index 0000000..852453a --- /dev/null +++ b/tests/testthat/_snaps/mod_plot_nee.md @@ -0,0 +1,35 @@ +# ui + + Code + ui + Output +
+
+
+ National Elicitation Exercise (NEE) estimate + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/_snaps/mod_plot_rates.md b/tests/testthat/_snaps/mod_plot_rates.md new file mode 100644 index 0000000..563bd6f --- /dev/null +++ b/tests/testthat/_snaps/mod_plot_rates.md @@ -0,0 +1,13 @@ +# ui + + Code + ui + Output +
+ +
mod_plot_rates_trend
+
mod_plot_rates_funnel
+
mod_plot_rates_box
+ +
+ diff --git a/tests/testthat/_snaps/mod_plot_rates_box.md b/tests/testthat/_snaps/mod_plot_rates_box.md new file mode 100644 index 0000000..7c707e2 --- /dev/null +++ b/tests/testthat/_snaps/mod_plot_rates_box.md @@ -0,0 +1,35 @@ +# ui + + Code + ui + Output +
+
+
+ Rates Box + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/_snaps/mod_plot_rates_funnel.md b/tests/testthat/_snaps/mod_plot_rates_funnel.md new file mode 100644 index 0000000..bd8abf8 --- /dev/null +++ b/tests/testthat/_snaps/mod_plot_rates_funnel.md @@ -0,0 +1,35 @@ +# ui + + Code + ui + Output +
+
+
+ Rates Funnel + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/_snaps/mod_plot_rates_trend.md b/tests/testthat/_snaps/mod_plot_rates_trend.md new file mode 100644 index 0000000..9c1911b --- /dev/null +++ b/tests/testthat/_snaps/mod_plot_rates_trend.md @@ -0,0 +1,33 @@ +# ui + + Code + ui + Output +
+
+
+ Rates Trend + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/_snaps/mod_select_geography.md b/tests/testthat/_snaps/mod_select_geography.md new file mode 100644 index 0000000..221ffd4 --- /dev/null +++ b/tests/testthat/_snaps/mod_select_geography.md @@ -0,0 +1,14 @@ +# ui + + Code + ui + Output +
+ +
+ + +
+
+ diff --git a/tests/testthat/_snaps/mod_select_provider.md b/tests/testthat/_snaps/mod_select_provider.md new file mode 100644 index 0000000..3d8e8df --- /dev/null +++ b/tests/testthat/_snaps/mod_select_provider.md @@ -0,0 +1,13 @@ +# ui + + Code + ui + Output +
+ +
+ + +
+
+ diff --git a/tests/testthat/_snaps/mod_select_strategy.md b/tests/testthat/_snaps/mod_select_strategy.md new file mode 100644 index 0000000..453b61f --- /dev/null +++ b/tests/testthat/_snaps/mod_select_strategy.md @@ -0,0 +1,22 @@ +# ui + + Code + ui + Output +
+ +
+ + +
+
+
+ +
+ + +
+
+ diff --git a/tests/testthat/_snaps/mod_show_strategy_text.md b/tests/testthat/_snaps/mod_show_strategy_text.md new file mode 100644 index 0000000..5d47839 --- /dev/null +++ b/tests/testthat/_snaps/mod_show_strategy_text.md @@ -0,0 +1,21 @@ +# ui + + Code + ui + Output +
+
+
Description
+
+ +
+ +
+
+ diff --git a/tests/testthat/_snaps/mod_table_diagnoses.md b/tests/testthat/_snaps/mod_table_diagnoses.md new file mode 100644 index 0000000..cbc40ca --- /dev/null +++ b/tests/testthat/_snaps/mod_table_diagnoses.md @@ -0,0 +1,35 @@ +# ui + + Code + ui + Output +
+
+
+ Diagnoses summary + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/_snaps/mod_table_procedures.md b/tests/testthat/_snaps/mod_table_procedures.md new file mode 100644 index 0000000..47c8ba9 --- /dev/null +++ b/tests/testthat/_snaps/mod_table_procedures.md @@ -0,0 +1,35 @@ +# ui + + Code + ui + Output +
+
+
+ Procedures summary + + + + +
+
+ +
+ + + + + +
+
+ diff --git a/tests/testthat/helper-app_server.R b/tests/testthat/helper-app_server.R new file mode 100644 index 0000000..ae8104e --- /dev/null +++ b/tests/testthat/helper-app_server.R @@ -0,0 +1,20 @@ +setup_app_server_tests <- function(.env = parent.frame()) { + shiny::shinyOptions(cache = cachem::cache_mem()) + + mocks <- list( + mod_select_geography_server = mockery::mock(shiny::reactiveVal("nhp")), + mod_select_provider_server = mockery::mock(shiny::reactiveVal("ABC")), + mod_select_strategy_server = mockery::mock(shiny::reactiveVal("strategy")), + get_all_geo_data = mockery::mock(inputs_data_sample, cycle = TRUE), + mod_show_strategy_text_server = mockery::mock(), + mod_plot_rates_server = mockery::mock(), + mod_table_procedures_server = mockery::mock(), + mod_table_diagnoses_server = mockery::mock(), + mod_plot_age_sex_pyramid_server = mockery::mock(), + mod_plot_nee_server = mockery::mock() + ) + + do.call(testthat::local_mocked_bindings, c(mocks, .env = .env)) + + mocks +} diff --git a/tests/testthat/helper-app_ui.R b/tests/testthat/helper-app_ui.R new file mode 100644 index 0000000..e9d69b2 --- /dev/null +++ b/tests/testthat/helper-app_ui.R @@ -0,0 +1,24 @@ +setup_app_ui_tests <- function(.env = parent.frame()) { + setup_ui_test(.env) + + mocks <- list( + "mod_show_strategy_text_ui" = mockery::mock("mod_show_strategy_text"), + "mod_plot_rates_ui" = mockery::mock("mod_plot_rates"), + "mod_table_procedures_ui" = mockery::mock("mod_table_procedures"), + "mod_table_diagnoses_ui" = mockery::mock("mod_table_diagnoses"), + "mod_plot_age_sex_pyramid_ui" = mockery::mock("mod_plot_age_sex_pyramid"), + "mod_plot_nee_ui" = mockery::mock("mod_plot_nee"), + "mod_select_geography_ui" = mockery::mock("mod_select_geography"), + "mod_select_provider_ui" = mockery::mock("mod_select_provider"), + "mod_select_strategy_ui" = mockery::mock("mod_select_strategy") + ) + + withr::local_envvar( + .local_envir = .env, + "FEEDBACK_FORM_URL" = "https://example.com/" + ) + + do.call(testthat::local_mocked_bindings, c(mocks, .env = .env)) + + mocks +} diff --git a/tests/testthat/helper-mod_plot_rates.R b/tests/testthat/helper-mod_plot_rates.R new file mode 100644 index 0000000..fc7db37 --- /dev/null +++ b/tests/testthat/helper-mod_plot_rates.R @@ -0,0 +1,31 @@ +setup_mod_plot_rates_ui_tests <- function(.env = parent.frame()) { + setup_ui_test(.env) + + mocks <- list( + "mod_plot_rates_trend_ui" = mockery::mock("mod_plot_rates_trend"), + "mod_plot_rates_funnel_ui" = mockery::mock("mod_plot_rates_funnel"), + "mod_plot_rates_box_ui" = mockery::mock("mod_plot_rates_box") + ) + + do.call(testthat::local_mocked_bindings, c(mocks, .env = .env)) + + mocks +} + +server_mod_plot_rates_server_tests <- function(.env = parent.frame()) { + mocks <- list( + "mod_plot_rates_trend_server" = mockery::mock(), + "mod_plot_rates_funnel_server" = mockery::mock(), + "mod_plot_rates_box_server" = mockery::mock(), + "get_golem_config" = mockery::mock("strategies_config"), + "make_strategy_group_lookup" = mockery::mock("strategy_group_lookup"), + "get_peers_lookup" = mockery::mock("peers_lookup", cycle = TRUE), + "get_rates_data" = mockery::mock("rates"), + "get_rates_trend_data" = mockery::mock("rates_trend"), + "generate_rates_baseline_data" = mockery::mock("rates_baseline"), + "uprime_calculations" = mockery::mock("uprime") + ) + do.call(testthat::local_mocked_bindings, c(mocks, .env = .env)) + + mocks +} diff --git a/tests/testthat/helper-mod_select_strategy.R b/tests/testthat/helper-mod_select_strategy.R new file mode 100644 index 0000000..ca4623c --- /dev/null +++ b/tests/testthat/helper-mod_select_strategy.R @@ -0,0 +1,24 @@ +setup_mod_select_strategy_server <- function(.env = parent.frame()) { + strategies <- list( + ip = tibble::tibble( + name = c("Strategy A", "Strategy B"), + strategy = c("a", "b") + ), + op = tibble::tibble( + name = c("Strategy C", "Strategy D"), + strategy = c("c", "d") + ), + ae = tibble::tibble( + name = c("Strategy E", "Strategy F"), + strategy = c("e", "f") + ) + ) + m <- mockery::mock(strategies) + + testthat::local_mocked_bindings( + "mod_select_strategy_get_strategies" = m, + .env = .env + ) + + m +} diff --git a/tests/testthat/helper-sample_data.R b/tests/testthat/helper-sample_data.R new file mode 100644 index 0000000..9eb2388 --- /dev/null +++ b/tests/testthat/helper-sample_data.R @@ -0,0 +1,33 @@ +# nolint start +inputs_data_sample <- list( + "age_sex" = tibble::tribble( + ~provider , ~strategy , ~fyear , + "R00" , "a" , 1 , + "R00" , "a" , 2 , + "R00" , "b" , 1 , + "R00" , "b" , 2 , + "R01" , "a" , 1 , + "R01" , "a" , 2 , + "R01" , "b" , 1 , + "R01" , "b" , 2 , + ), + "diagnoses" = "diagnoses", + "procedures" = "procedures", + "rates" = tibble::tribble( + ~fyear , ~provider , ~strategy , ~crude_rate , ~std_rate , + 202223 , "a" , "Strategy A" , 1 , 2 , + 202223 , "b" , "Strategy A" , 3 , 4 , + 202223 , "national" , "Strategy A" , 5 , 6 , + 202324 , "A" , "Strategy A" , 7 , 8 , + 202324 , "B" , "Strategy A" , 9 , 10 , + 202324 , "national" , "Strategy A" , 10 , 12 , + + 202223 , "a" , "Strategy B" , 2 , 1 , + 202223 , "b" , "Strategy B" , 4 , 3 , + 202223 , "national" , "Strategy B" , 6 , 5 , + 202324 , "A" , "Strategy B" , 8 , 7 , + 202324 , "B" , "Strategy B" , 10 , 9 , + 202324 , "national" , "Strategy B" , 12 , 11 + ) +) +# nolint end diff --git a/tests/testthat/helper-ui.R b/tests/testthat/helper-ui.R new file mode 100644 index 0000000..4e0c76c --- /dev/null +++ b/tests/testthat/helper-ui.R @@ -0,0 +1,7 @@ +setup_ui_test <- function(.env = parent.frame()) { + testthat::local_mocked_bindings( + "p_randomInt" = \(...) "X", + .package = "shiny", + .env = .env + ) +} diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R new file mode 100644 index 0000000..c284c35 --- /dev/null +++ b/tests/testthat/setup.R @@ -0,0 +1,9 @@ +options( + shiny.launch.browser = FALSE, + shiny.testmode = TRUE +) + +Sys.setenv(TESTTHAT_PARALLEL = "false") + +library(mockery) +library(shiny) diff --git a/tests/testthat/test-add_external_resources.R b/tests/testthat/test-add_external_resources.R new file mode 100644 index 0000000..f8494d9 --- /dev/null +++ b/tests/testthat/test-add_external_resources.R @@ -0,0 +1,13 @@ +test_that("app_sys", { + # arrange + m <- mock("path/to/file") + stub(app_sys, "system.file", m) + + # act + actual <- app_sys("subdir", "file.txt") + + # assert + expect_equal(actual, "path/to/file") + expect_called(m, 1) + expect_args(m, 1, "subdir", "file.txt", package = "tpma.explorer") +}) diff --git a/tests/testthat/test-app_server.R b/tests/testthat/test-app_server.R new file mode 100644 index 0000000..3fb6835 --- /dev/null +++ b/tests/testthat/test-app_server.R @@ -0,0 +1,270 @@ +test_that("mod_select_geography", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_select_geography_server, 1) + expect_args(mocks$mod_select_geography_server, 1, "mod_select_geography") + } + ) +}) + +test_that("mod_select_provider", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_select_provider_server, 1) + expect_args( + mocks$mod_select_provider_server, + 1, + "mod_select_provider", + selected_geography + ) + } + ) +}) + +test_that("mod_select_strategy", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_select_strategy_server, 1) + expect_args( + mocks$mod_select_strategy_server, + 1, + "mod_select_strategy" + ) + } + ) +}) + +test_that("selected_year (env var not set)", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + withr::local_envvar("BASELINE_YEAR" = "") + expect_equal(selected_year(), 202324) + expect_called(mocks$get_all_geo_data, 1) + expect_args(mocks$get_all_geo_data, 1, "nhp") + } + ) +}) + + +test_that("selected_year (env var set)", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + withr::local_envvar("BASELINE_YEAR" = "3") + expect_equal(selected_year(), 3) + expect_called(mocks$get_all_geo_data, 0) + } + ) +}) + +test_that("inputs_data", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + withr::local_envvar("BASELINE_YEAR" = "") + expect_equal(inputs_data(), inputs_data_sample) + expect_called(mocks$get_all_geo_data, 1) + expect_args(mocks$get_all_geo_data, 1, "nhp") + + # test caching - not changing geography, so shouldn't call again + inputs_data() + expect_called(mocks$get_all_geo_data, 1) + + # test caching - changing geography, so should call again + selected_geography("la") + inputs_data() + expect_called(mocks$get_all_geo_data, 2) + expect_args(mocks$get_all_geo_data, 2, "la") + + # test caching - changing geography back, so shouldn't call again + selected_geography("nhp") + inputs_data() + expect_called(mocks$get_all_geo_data, 2) + } + ) +}) + +test_that("sidebar accordion opens", { + # arrange + mocks <- setup_app_server_tests() + + m <- mock() + mockery::stub(app_server, "bslib::accordion_panel_open", m) + # act + + shiny::testServer( + app_server, + { + session$flushReact() # trigger observer + expect_called(m, 1) + expect_args(m, 1, id = "sidebar_accordion", values = TRUE) + } + ) +}) + +test_that("mod_show_strategy_text_server", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_show_strategy_text_server, 1) + expect_args( + mocks$mod_show_strategy_text_server, + 1, + "mod_show_strategy_text", + selected_strategy + ) + } + ) +}) + +test_that("mod_plot_rates_server", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_plot_rates_server, 1) + expect_args( + mocks$mod_plot_rates_server, + 1, + "mod_plot_rates", + inputs_data, + selected_geography, + selected_provider, + selected_strategy, + selected_year + ) + } + ) +}) + +test_that("mod_table_procedures_server", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_table_procedures_server, 1) + expect_args( + mocks$mod_table_procedures_server, + 1, + "mod_table_procedures", + inputs_data, + selected_provider, + selected_strategy, + selected_year + ) + } + ) +}) + +test_that("mod_table_diagnoses_server", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_table_diagnoses_server, 1) + expect_args( + mocks$mod_table_diagnoses_server, + 1, + "mod_table_diagnoses", + inputs_data, + selected_provider, + selected_strategy, + selected_year + ) + } + ) +}) + +test_that("mod_plot_age_sex_pyramid_server", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_plot_age_sex_pyramid_server, 1) + expect_args( + mocks$mod_plot_age_sex_pyramid_server, + 1, + "mod_plot_age_sex_pyramid", + inputs_data, + selected_provider, + selected_strategy, + selected_year + ) + } + ) +}) + +test_that("mod_plot_nee_server", { + # arrange + mocks <- setup_app_server_tests() + + # act + shiny::testServer( + app_server, + { + # assert + expect_called(mocks$mod_plot_nee_server, 1) + expect_args( + mocks$mod_plot_nee_server, + 1, + "mod_plot_nee", + selected_strategy + ) + } + ) +}) diff --git a/tests/testthat/test-app_ui.R b/tests/testthat/test-app_ui.R new file mode 100644 index 0000000..4f0d78e --- /dev/null +++ b/tests/testthat/test-app_ui.R @@ -0,0 +1,120 @@ +test_that("ui", { + # arrange + setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_snapshot(ui) +}) + +test_that("calls mod_show_strategy_text_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_show_strategy_text_ui, 1) + expect_args(mocks$mod_show_strategy_text_ui, 1, "mod_show_strategy_text") +}) + +test_that("calls mod_plot_rates_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_plot_rates_ui, 1) + expect_args(mocks$mod_plot_rates_ui, 1, "mod_plot_rates") +}) + +test_that("calls mod_table_procedures_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_table_procedures_ui, 1) + expect_args(mocks$mod_table_procedures_ui, 1, "mod_table_procedures") +}) + + +test_that("calls mod_table_diagnoses_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_table_diagnoses_ui, 1) + expect_args(mocks$mod_table_diagnoses_ui, 1, "mod_table_diagnoses") +}) + + +test_that("calls mod_plot_age_sex_pyramid", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_plot_age_sex_pyramid_ui, 1) + expect_args(mocks$mod_plot_age_sex_pyramid_ui, 1, "mod_plot_age_sex_pyramid") +}) + +test_that("calls mod_plot_nee_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_plot_nee_ui, 1) + expect_args(mocks$mod_plot_nee_ui, 1, "mod_plot_nee") +}) + +test_that("calls mod_select_geography_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_select_geography_ui, 1) + expect_args(mocks$mod_select_geography_ui, 1, "mod_select_geography") +}) + +test_that("calls mod_select_provider_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_select_provider_ui, 1) + expect_args(mocks$mod_select_provider_ui, 1, "mod_select_provider") +}) + +test_that("calls mod_select_strategy_ui", { + # arrange + mocks <- setup_app_ui_tests() + + # act + ui <- app_ui("request") + + # assert + expect_called(mocks$mod_select_strategy_ui, 1) + expect_args(mocks$mod_select_strategy_ui, 1, "mod_select_strategy") +}) diff --git a/tests/testthat/test-fct_plots.R b/tests/testthat/test-fct_plots.R new file mode 100644 index 0000000..d8f11a6 --- /dev/null +++ b/tests/testthat/test-fct_plots.R @@ -0,0 +1,200 @@ +test_that("plot_rates_trend", { + # arrange + # nolint start + rates_trend_data <- tibble::tribble( + ~fyear , ~rate , + 201516 , 0.10 , + 201617 , 0.12 , + 201718 , 0.11 , + 201819 , 0.09 , + 201920 , 0.08 , + 202021 , 0.07 , + 202122 , 0.06 , + 202223 , 0.05 , + 202324 , 0.04 + ) + # nolint end + + selected_year <- 202324 + y_axis_limits <- c(0, 0.16) + x_axis_title <- "Financial year" + y_axis_title <- "Rate per 100,000 population" + y_labels <- scales::label_percent(accuracy = 0.1) + + # act + actual <- plot_rates_trend( + rates_trend_data, + selected_year, + y_axis_limits, + x_axis_title, + y_axis_title, + y_labels + ) + + # assert + vdiffr::expect_doppelganger("plot_rates_trend", actual) +}) + +test_that("plot_rates_funnel", { + # arrange + set.seed(1) + # nolint start + rates_funnel_data <- tibble::tribble( + ~rate , ~denominator , ~national_rate , ~is_peer , ~provider , + 0.10 , 1000 , 0.08 , TRUE , "a" , + 0.12 , 1200 , 0.08 , TRUE , "b" , + 0.11 , 1400 , 0.08 , FALSE , "c" , + 0.09 , 1600 , 0.08 , TRUE , "d" , + 0.08 , 1800 , 0.08 , NA , "e" , + 0.07 , 2000 , 0.08 , NA , "f" , + 0.06 , 2200 , 0.08 , NA , "g" , + 0.05 , 2400 , 0.08 , NA , "h" , + 0.04 , 2600 , 0.08 , TRUE , "i" + ) + # nolint end + + funnel_calculations <- uprime_calculations(rates_funnel_data) + y_axis_limits <- c(0, 0.16) + x_axis_title <- "Population size" + + # act + actual <- plot_rates_funnel( + rates_funnel_data, + funnel_calculations, + y_axis_limits, + x_axis_title + ) + + # assert + vdiffr::expect_doppelganger("plot_rates_funnel", actual) +}) + +test_that("plot_rates_box", { + # arrange + # nolint start + rates_box_data <- tibble::tribble( + ~rate , ~denominator , ~national_rate , ~is_peer , ~provider , + 0.10 , 1000 , 0.08 , TRUE , "a" , + 0.12 , 1200 , 0.08 , TRUE , "b" , + 0.11 , 1400 , 0.08 , FALSE , "c" , + 0.09 , 1600 , 0.08 , TRUE , "d" , + 0.08 , 1800 , 0.08 , NA , "e" , + 0.07 , 2000 , 0.08 , NA , "f" , + 0.06 , 2200 , 0.08 , NA , "g" , + 0.05 , 2400 , 0.08 , NA , "h" , + 0.04 , 2600 , 0.08 , TRUE , "i" + ) + # nolint end + + y_axis_limits <- c(0, 0.16) + + # act + actual <- plot_rates_box( + rates_box_data, + y_axis_limits + ) + + # assert + vdiffr::expect_doppelganger("plot_rates_box", actual) +}) + +test_that("theme_rates (has_y_axis = TRUE)", { + actual <- theme_rates(TRUE) + expect_snapshot(actual) +}) + +test_that("theme_rates (has_y_axis = FALSE)", { + actual <- theme_rates(FALSE) + expect_snapshot(actual) +}) + +test_that("plot_age_sex_pyramid", { + # arrange + age_sex_data <- tibble::tribble( + ~age_group, ~sex, ~n, + "0-4", "Males", -1, + "5-9", "Males", -2, + "10-14", "Males", -3, + "15-19", "Males", -4, + "20-24", "Males", -5, + "25-29", "Males", -6, + "30-34", "Males", -7, + "35-39", "Males", -8, + "40-44", "Males", -9, + "45-49", "Males", -10, + "50-54", "Males", -11, + "55-59", "Males", -12, + "60-64", "Males", -13, + "65-69", "Males", -14, + "70-74", "Males", -15, + "75-79", "Males", -16, + "80-84", "Males", -17, + "85-89", "Males", -18, + "90+", "Males", -19, + "0-4", "Females", 19, + "5-9", "Females", 18, + "10-14", "Females", 17, + "15-19", "Females", 16, + "20-24", "Females", 15, + "25-29", "Females", 14, + "30-34", "Females", 13, + "35-39", "Females", 12, + "40-44", "Females", 11, + "45-49", "Females", 10, + "50-54", "Females", 9, + "55-59", "Females", 8, + "60-64", "Females", 7, + "65-69", "Females", 6, + "70-74", "Females", 5, + "75-79", "Females", 4, + "80-84", "Females", 3, + "85-89", "Females", 2, + "90+", "Females", 1 + ) |> + dplyr::mutate( + age_group = factor( + age_group, + levels = c( + "0-4", + "5-9", + "10-14", + "15-19", + "20-24", + "25-29", + "30-34", + "35-39", + "40-44", + "45-49", + "50-54", + "55-59", + "60-64", + "65-69", + "70-74", + "75-79", + "80-84", + "85-89", + "90+" + ) + ) + ) + + # act + actual <- plot_age_sex_pyramid(age_sex_data) + + # assert + vdiffr::expect_doppelganger("plot_age_sex_pyramid", actual) +}) + +test_that("plot_nee", { + # arrange + nee_data <- tibble::tribble( + ~strategy, ~percentile10, ~mean, ~percentile90, + "Strategy A", 20, 50, 80 + ) + + # act + actual <- plot_nee(nee_data) + + # assert + vdiffr::expect_doppelganger("plot_nee", actual) +}) diff --git a/tests/testthat/test-fct_table.R b/tests/testthat/test-fct_table.R new file mode 100644 index 0000000..dfc0512 --- /dev/null +++ b/tests/testthat/test-fct_table.R @@ -0,0 +1,35 @@ +test_that("entable_encounters (diagnoses)", { + # arrange + set.seed(1) + df <- tibble::tribble( + ~diagnosis_description, ~n, ~pcnt, + "A", 100, 0.5, + "B", 50, 0.25, + "C", 25, 0.125, + "Other", 25, 0.125 + ) + + # act + actual <- entable_encounters(df) + + # assert + expect_snapshot(actual) +}) + +test_that("entable_encounters (procedures)", { + # arrange + set.seed(1) + df <- tibble::tribble( + ~procedures_description, ~n, ~pcnt, + "A", 100, 0.5, + "B", 50, 0.25, + "C", 25, 0.125, + "Other", 25, 0.125 + ) + + # act + actual <- entable_encounters(df) + + # assert + expect_snapshot(actual) +}) diff --git a/tests/testthat/test-mod_plot_age_sex_pyramid.R b/tests/testthat/test-mod_plot_age_sex_pyramid.R new file mode 100644 index 0000000..c15ea9f --- /dev/null +++ b/tests/testthat/test-mod_plot_age_sex_pyramid.R @@ -0,0 +1,99 @@ +# nolint start +test_that("ui", { + setup_ui_test() + + ui <- mod_plot_age_sex_pyramid_ui("test") + + expect_snapshot(ui) +}) + +test_that("age_sex_data", { + # arrange + m <- mock("age_sex_data") + testthat::local_mocked_bindings("prepare_age_sex_data" = m) + expected <- tibble::tibble(provider = "R00", strategy = "a", fyear = 2) + + # act + shiny::testServer( + mod_plot_age_sex_pyramid_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("a"), + selected_year = reactiveVal(2) + ), + { + actual <- age_sex_data() + + # assert + expect_equal(actual, "age_sex_data") + + expect_called(m, 1) + expect_args(m, 1, expected) + } + ) +}) + +test_that("age_sex_pyramid (no rows)", { + # arrange + testthat::local_mocked_bindings("prepare_age_sex_data" = \(...) { + tibble::tibble() + }) + + # act + shiny::testServer( + mod_plot_age_sex_pyramid_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("a"), + selected_year = reactiveVal(2) + ), + { + # assert + expect_error( + output$age_sex_pyramid, + "No data available for these selections." + ) + } + ) +}) + + +test_that("age_sex_pyramid (with rows)", { + # arrange + m <- mock("plot") + testthat::local_mocked_bindings( + "prepare_age_sex_data" = identity, + "plot_age_sex_pyramid" = m + ) + + # replace renderPlot to avoid actual plotting, replace with renderText so we + # can simply check the output + testthat::local_mocked_bindings( + "renderPlot" = shiny::renderText, + .package = "shiny" + ) + + expected <- tibble::tibble(provider = "R00", strategy = "a", fyear = 2) + + # act + shiny::testServer( + mod_plot_age_sex_pyramid_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("a"), + selected_year = reactiveVal(2) + ), + { + actual <- output$age_sex_pyramid + + # assert + expect_equal(actual, "plot") + + expect_called(m, 1) + expect_args(m, 1, expected) + } + ) +}) diff --git a/tests/testthat/test-mod_plot_nee.R b/tests/testthat/test-mod_plot_nee.R new file mode 100644 index 0000000..d33719f --- /dev/null +++ b/tests/testthat/test-mod_plot_nee.R @@ -0,0 +1,83 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_plot_nee_ui("test") + + expect_snapshot(ui) +}) + +test_that("selected_nee_data", { + # arrange + expected <- tibble::tibble( + param_name = "smoking", + mean = 84.3, + percentile10 = 98.9, + percentile90 = 60.0 + ) + + # act + shiny::testServer( + mod_plot_nee_server, + args = list( + selected_strategy = reactiveVal("smoking") + ), + { + actual <- selected_nee_data() + + # assert + expect_equal(actual, expected, tolerance = 1e-1) + } + ) +}) + +test_that("nee (no rows)", { + # arrange + testthat::local_mocked_bindings("prepare_age_sex_data" = \(...) { + tibble::tibble() + }) + + # act + shiny::testServer( + mod_plot_nee_server, + args = list( + selected_strategy = reactiveVal("X") + ), + { + # assert + expect_error(output$nee) + } + ) +}) + + +test_that("nee (with rows)", { + # arrange + m <- mock("plot") + testthat::local_mocked_bindings( + "plot_nee" = m + ) + + # replace renderPlot to avoid actual plotting, replace with renderText so we + # can simply check the output + testthat::local_mocked_bindings( + "renderPlot" = shiny::renderText, + .package = "shiny" + ) + + # act + shiny::testServer( + mod_plot_nee_server, + args = list( + selected_strategy = reactiveVal("smoking") + ), + { + actual <- output$nee + + # assert + expect_equal(actual, "plot") + + expect_called(m, 1) + expect_call(m, 1, plot_nee(df)) + } + ) +}) diff --git a/tests/testthat/test-mod_plot_rates.R b/tests/testthat/test-mod_plot_rates.R new file mode 100644 index 0000000..e5dc136 --- /dev/null +++ b/tests/testthat/test-mod_plot_rates.R @@ -0,0 +1,409 @@ +test_that("ui", { + # arrange + setup_mod_plot_rates_ui_tests() + + # act + ui <- mod_plot_rates_ui("test") + + # assert + expect_snapshot(ui) +}) + +test_that("ui calls mod_plot_rates_trend_ui", { + # arrange + mocks <- setup_mod_plot_rates_ui_tests() + + # act + ui <- mod_plot_rates_ui("test") + + # assert + expect_called(mocks$mod_plot_rates_trend_ui, 1) + expect_args(mocks$mod_plot_rates_trend_ui, 1, "test-mod_plot_rates_trend") +}) + +test_that("ui calls mod_plot_rates_funnel_ui", { + # arrange + mocks <- setup_mod_plot_rates_ui_tests() + + # act + ui <- mod_plot_rates_ui("test") + + # assert + expect_called(mocks$mod_plot_rates_funnel_ui, 1) + expect_args(mocks$mod_plot_rates_funnel_ui, 1, "test-mod_plot_rates_funnel") +}) + +test_that("ui calls mod_plot_rates_box_ui", { + # arrange + mocks <- setup_mod_plot_rates_ui_tests() + + # act + ui <- mod_plot_rates_ui("test") + + # assert + expect_called(mocks$mod_plot_rates_box_ui, 1) + expect_args(mocks$mod_plot_rates_box_ui, 1, "test-mod_plot_rates_box") +}) + +test_that("server sets up strategies_config", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + m <- mocks$get_golem_config + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(inputs_data_sample), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + # assert + expect_equal(strategies_config, "strategies_config") + expect_called(m, 1) + expect_args(m, 1, "mitigators_config") + } + ) +}) + +test_that("server sets up strategy_group_lookup", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + m <- mocks$get_golem_config + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(inputs_data_sample), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + # assert + expect_equal(strategy_group_lookup, "strategy_group_lookup") + expect_called(m, 1) + expect_args(m, 1, "mitigators_config") + } + ) +}) + +test_that("modules are correctly instantiated", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(inputs_data_sample), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + # assert + expect_called(mocks$mod_plot_rates_trend_server, 1) + expect_args( + mocks$mod_plot_rates_trend_server, + 1, + "mod_plot_rates_trend", + rates_trend_data, + y_axis_limits, + y_axis_title, + y_labels, + selected_year + ) + + expect_called(mocks$mod_plot_rates_funnel_server, 1) + expect_args( + mocks$mod_plot_rates_funnel_server, + 1, + "mod_plot_rates_funnel", + rates_baseline_data, + rates_funnel_calculations, + y_axis_limits, + funnel_x_title + ) + + expect_called(mocks$mod_plot_rates_box_server, 1) + expect_args( + mocks$mod_plot_rates_box_server, + 1, + "mod_plot_rates_box", + rates_baseline_data, + y_axis_limits + ) + } + ) +}) + +test_that("peers_lookup", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + m <- mocks$get_peers_lookup + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(inputs_data_sample), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + # assert + expect_equal(peers_lookup(), "peers_lookup") + + expect_called(m, 1) + expect_args(m, 1, "nhp") + + selected_geography("la") + peers_lookup() + expect_called(m, 2) + expect_args(m, 2, "la") + } + ) +}) + +test_that("rates_data", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + actual <- rates_data() + + # assert + expect_equal(actual, "rates") + expect_called(mocks$get_rates_data, 1) + expect_args(mocks$get_rates_data, 1, "sample_data", "Strategy A") + } + ) +}) + +test_that("rates_trend_data", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + actual <- rates_trend_data() + + # assert + expect_equal(actual, "rates_trend") + expect_called(mocks$get_rates_trend_data, 1) + expect_args(mocks$get_rates_trend_data, 1, "rates", "R00") + } + ) +}) + +test_that("rates_baseline", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + actual <- rates_baseline_data() + + # assert + expect_equal(actual, "rates_baseline") + expect_called(mocks$generate_rates_baseline_data, 1) + expect_args( + mocks$generate_rates_baseline_data, + 1, + "rates", + "R00", + "peers_lookup", + 202324 + ) + } + ) +}) + +test_that("rates_funnel_calculations", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + actual <- rates_funnel_calculations() + + # assert + expect_equal(actual, "uprime") + expect_called(mocks$uprime_calculations, 1) + expect_args( + mocks$uprime_calculations, + 1, + "rates_baseline" + ) + } + ) +}) + +test_that("y_axis_limits (funnel values are max)", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + trends_df <- tibble::tibble( + rate = 1:10 + ) + + baseline_df <- tibble::tibble( + denominator = c(1, 10, 15, 100), + rate = c(50, 40, 30, 20) + ) + + uprime <- list( + z_i = c(2, 10, 2, 2) + ) + + local_mocked_bindings( + "get_rates_trend_data" = mock(trends_df), + "generate_rates_baseline_data" = mock(baseline_df), + "uprime_calculations" = mock(uprime), + ) + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + actual <- y_axis_limits() + + # assert + expect_equal(actual, c(0, 30)) + } + ) +}) + +test_that("y_axis_limits (trend values are max)", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + trends_df <- tibble::tibble( + rate = 300 + ) + + baseline_df <- tibble::tibble( + denominator = c(1, 10, 15, 100), + rate = c(50, 40, 30, 20) + ) + + uprime <- list( + z_i = c(2, 10, 2, 2) + ) + + local_mocked_bindings( + "get_rates_trend_data" = mock(trends_df), + "generate_rates_baseline_data" = mock(baseline_df), + "uprime_calculations" = mock(uprime), + ) + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + actual <- y_axis_limits() + + # assert + expect_equal(actual, c(0, 300)) + } + ) +}) + +test_that("strategy_config", { + # arrange + mocks <- server_mod_plot_rates_server_tests() + + strategy_config <- list( + "group a" = list( + y_axis_title = "y axis title", + number_type = "y labels", + funnel_x_title = "funnel x title" + ) + ) + strategy_group_lookup <- list( + "Strategy A" = "group a" + ) + + local_mocked_bindings( + "get_golem_config" = mock(strategy_config), + "make_strategy_group_lookup" = mock(strategy_group_lookup) + ) + + # act + shiny::testServer( + mod_plot_rates_server, + args = list( + inputs_data = shiny::reactiveVal(list(rates = "sample_data")), + selected_geography = shiny::reactiveVal("nhp"), + selected_provider = shiny::reactiveVal("R00"), + selected_strategy = shiny::reactiveVal("Strategy A"), + selected_year = shiny::reactiveVal(202324) + ), + { + # assert + expect_equal(y_axis_title(), "y axis title") + expect_equal(y_labels(), "y labels") + expect_equal(funnel_x_title(), "funnel x title") + } + ) +}) diff --git a/tests/testthat/test-mod_plot_rates_box.R b/tests/testthat/test-mod_plot_rates_box.R new file mode 100644 index 0000000..9909e15 --- /dev/null +++ b/tests/testthat/test-mod_plot_rates_box.R @@ -0,0 +1,64 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_plot_rates_box_ui("test") + + expect_snapshot(ui) +}) + + +test_that("rates_box_plot (no rows)", { + # arrange + + # act + shiny::testServer( + mod_plot_rates_box_server, + args = list( + rates = \() tibble::tibble(), + y_axis_limits = \() c(0, 100) + ), + { + # assert + expect_error( + output$rates_box_plot, + "No data available for these selections." + ) + } + ) +}) + + +test_that("rates_box_plot (with rows)", { + # arrange + m <- mock("plot") + testthat::local_mocked_bindings( + "plot_rates_box" = m + ) + + # replace renderPlot to avoid actual plotting, replace with renderText so we + # can simply check the output + testthat::local_mocked_bindings( + "renderPlot" = shiny::renderText, + .package = "shiny" + ) + + sample_data <- tibble::tibble(x = 1, y = 2) + + # act + shiny::testServer( + mod_plot_rates_box_server, + args = list( + rates = \() sample_data, + y_axis_limits = \() c(0, 100) + ), + { + actual <- output$rates_box_plot + + # assert + expect_equal(actual, "plot") + + expect_called(m, 1) + expect_args(m, 1, sample_data, c(0, 100)) + } + ) +}) diff --git a/tests/testthat/test-mod_plot_rates_funnel.R b/tests/testthat/test-mod_plot_rates_funnel.R new file mode 100644 index 0000000..2b7c27c --- /dev/null +++ b/tests/testthat/test-mod_plot_rates_funnel.R @@ -0,0 +1,68 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_plot_rates_funnel_ui("test") + + expect_snapshot(ui) +}) + + +test_that("rates_funnel_plot (no rows)", { + # arrange + + # act + shiny::testServer( + mod_plot_rates_funnel_server, + args = list( + rates = \() tibble::tibble(), + funnel_calculations = \() "funnel calculations", + y_axis_limits = \() c(0, 100), + x_axis_title = \() "X Axis" + ), + { + # assert + expect_error( + output$rates_funnel_plot, + "No data available for these selections." + ) + } + ) +}) + + +test_that("rates_funnel_plot (with rows)", { + # arrange + m <- mock("plot") + testthat::local_mocked_bindings( + "plot_rates_funnel" = m + ) + + # replace renderPlot to avoid actual plotting, replace with renderText so we + # can simply check the output + testthat::local_mocked_bindings( + "renderPlot" = shiny::renderText, + .package = "shiny" + ) + + sample_data <- tibble::tibble(x = 1, y = 2) + + # act + shiny::testServer( + mod_plot_rates_funnel_server, + args = list( + rates = \() sample_data, + funnel_calculations = \() "funnel calculations", + y_axis_limits = \() c(0, 100), + x_axis_title = \() "X Axis" + ), + { + actual <- output$rates_funnel_plot + + # assert + expect_equal(actual, "plot") + + expect_called(m, 1) + expect_args(m, 1, sample_data, "funnel calculations", c(0, 100), "X Axis") + } + ) +}) diff --git a/tests/testthat/test-mod_plot_rates_trend.R b/tests/testthat/test-mod_plot_rates_trend.R new file mode 100644 index 0000000..eb7f3ae --- /dev/null +++ b/tests/testthat/test-mod_plot_rates_trend.R @@ -0,0 +1,70 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_plot_rates_trend_ui("test") + + expect_snapshot(ui) +}) + + +test_that("rates_trend_plot (no rows)", { + # arrange + + # act + shiny::testServer( + mod_plot_rates_trend_server, + args = list( + rates = \() tibble::tibble(), + y_axis_limits = \() c(0, 100), + y_axis_title = \() "Y Axis", + y_labels = \() "Y Labels", + selected_year = \() 202324 + ), + { + # assert + expect_error( + output$rates_trend_plot, + "No data available for these selections." + ) + } + ) +}) + + +test_that("rates_trend_plot (with rows)", { + # arrange + m <- mock("plot") + testthat::local_mocked_bindings( + "plot_rates_trend" = m + ) + + # replace renderPlot to avoid actual plotting, replace with renderText so we + # can simply check the output + testthat::local_mocked_bindings( + "renderPlot" = shiny::renderText, + .package = "shiny" + ) + + sample_data <- tibble::tibble(x = 1, y = 2) + + # act + shiny::testServer( + mod_plot_rates_trend_server, + args = list( + rates = \() sample_data, + y_axis_limits = \() c(0, 100), + y_axis_title = \() "Y Axis", + y_labels = \() "Y Labels", + selected_year = \() 202324 + ), + { + actual <- output$rates_trend_plot + + # assert + expect_equal(actual, "plot") + + expect_called(m, 1) + expect_args(m, 1, sample_data, 202324, c(0, 100), "Y Axis", "Y Labels") + } + ) +}) diff --git a/tests/testthat/test-mod_select_geography.R b/tests/testthat/test-mod_select_geography.R new file mode 100644 index 0000000..3684c74 --- /dev/null +++ b/tests/testthat/test-mod_select_geography.R @@ -0,0 +1,23 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_select_geography_ui("test") + + expect_snapshot(ui) +}) + +test_that("server returns reactive", { + # arrange + test_server <- function(input, output, session) { + selected_geography <- mod_select_geography_server("test") + } + + # act + shiny::testServer(test_server, { + session$setInputs("test-geography_select" = "nhp") + expect_equal(selected_geography(), "nhp") + + session$setInputs("test-geography_select" = "la") + expect_equal(selected_geography(), "la") + }) +}) diff --git a/tests/testthat/test-mod_select_provider.R b/tests/testthat/test-mod_select_provider.R new file mode 100644 index 0000000..43b1658 --- /dev/null +++ b/tests/testthat/test-mod_select_provider.R @@ -0,0 +1,122 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_select_provider_ui("test") + + expect_snapshot(ui) +}) + +test_that("server returns reactive", { + # arrange + test_server <- function(input, output, session) { + selected_provider <- mod_select_provider_server("test", reactiveVal("nhp")) + } + + # act + shiny::testServer(test_server, { + session$setInputs("test-provider_select" = "a") + expect_equal(selected_provider(), "a") + + session$setInputs("test-provider_select" = "b") + expect_equal(selected_provider(), "b") + }) +}) + +test_that("providers reactive", { + # arrange + m <- mock("providers nhp", "providers la") + + testthat::local_mocked_bindings( + "read_json" = m, + .package = "jsonlite" + ) + testthat::local_mocked_bindings( + "app_sys" = \(...) file.path("inst", ...), + ) + + # act + shiny::testServer( + mod_select_provider_server, + args = list( + selected_geography = reactiveVal() + ), + { + # assert + selected_geography("nhp") + expect_equal(providers(), "providers nhp") + + selected_geography("la") + expect_equal(providers(), "providers la") + + selected_geography("other") + expect_error(providers()) + + expect_called(m, 2) + expect_args( + m, + 1, + "inst/app/data/nhp-datasets.json", + simplify_vector = TRUE + ) + expect_args( + m, + 2, + "inst/app/data/la-datasets.json", + simplify_vector = TRUE + ) + } + ) +}) + + +test_that("it updates the select input", { + # arrange + m <- mock() + testthat::local_mocked_bindings( + "updateSelectInput" = m, + .package = "shiny" + ) + + # mock what will happen to providers as we change the selected geography + testthat::local_mocked_bindings( + "read_json" = mock( + list("A" = "a", "B" = "b"), + list("C" = "c", "D" = "d") + ), + .package = "jsonlite" + ) + + # act + shiny::testServer( + mod_select_provider_server, + args = list( + selected_geography = reactiveVal() + ), + { + # assert + selected_geography("nhp") + session$private$flush() + expect_called(m, 1) + expect_args( + m, + 1, + session, + "provider_select", + label = "Choose a trust:", + choices = c("a" = "A", "b" = "B") + ) + + selected_geography("la") + session$private$flush() + expect_called(m, 2) + expect_args( + m, + 2, + session, + "provider_select", + label = "Choose an LA:", + choices = c("c" = "C", "d" = "D") + ) + } + ) +}) diff --git a/tests/testthat/test-mod_select_strategy.R b/tests/testthat/test-mod_select_strategy.R new file mode 100644 index 0000000..0e6b5b0 --- /dev/null +++ b/tests/testthat/test-mod_select_strategy.R @@ -0,0 +1,137 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_select_strategy_ui("test") + + expect_snapshot(ui) +}) + + +test_that("mod_select_strategy_get_strategies works", { + # arrange + m <- mock( + list( + "a" = "Strategy A (IP-AA-001)", + "b" = "Strategy B (IP-AA-002)", + "c" = "Strategy C (IP-EF-001)", + "d" = "Strategy D (OP-AA-001)", + "e" = "Strategy E (OP-AA-002)" + ) + ) + local_mocked_bindings( + "read_json" = m, + .package = "jsonlite" + ) + # nolint start + expected <- list( + "ip" = tibble::tribble( + ~strategy , ~name , + "a" , "Strategy A (IP-AA-001)" , + "b" , "Strategy B (IP-AA-002)" , + "c" , "Strategy C (IP-EF-001)" + ), + op = tibble::tribble( + ~strategy , ~name , + "d" , "Strategy D (OP-AA-001)" , + "e" , "Strategy E (OP-AA-002)" + ) + ) |> + dplyr::bind_rows(.id = "category") |> + dplyr::group_nest(.data$category) |> + tibble::deframe() + # nolint end + + # act + actual <- mod_select_strategy_get_strategies() + + # assert + expect_equal(actual, expected) + expect_called(m, 1) + expect_call( + m, + 1, + jsonlite::read_json( + app_sys("app", "data", "mitigators.json"), + simplify_vector = TRUE + ) + ) +}) + +test_that("server returns reactive", { + # arrange + setup_mod_select_strategy_server() + + test_server <- function(input, output, session) { + selected_strategy <- mod_select_strategy_server("test") + } + + # act + shiny::testServer(test_server, { + session$setInputs("test-strategy_select" = "a") + expect_equal(selected_strategy(), "a") + + session$setInputs("test-strategy_select" = "b") + expect_equal(selected_strategy(), "b") + }) +}) + +test_that("it calls mod_select_strategy_get_strategies", { + # arrange + m <- setup_mod_select_strategy_server() + + # act + shiny::testServer(mod_select_strategy_server, { + # assert + expect_called(m, 1) + expect_args(m, 1) + }) +}) + +test_that("selected_category", { + # arrange + setup_mod_select_strategy_server() + + # act + shiny::testServer(mod_select_strategy_server, { + session$setInputs("strategy_category_select" = "ip") + actual <- selected_category() + + # assert + expect_equal(actual, "ip") + }) +}) + +test_that("it updates the strategy_select choices", { + # arrange + setup_mod_select_strategy_server() + m <- mock() + local_mocked_bindings( + "updateSelectInput" = m, + .package = "shiny" + ) + + # act + shiny::testServer(mod_select_strategy_server, { + # assert + session$setInputs("strategy_category_select" = "ip") + expect_called(m, 1) + expect_args( + m, + 1, + session, + "strategy_select", + choices = c("Strategy A" = "a", "Strategy B" = "b") + ) + + # assert + session$setInputs("strategy_category_select" = "op") + expect_called(m, 2) + expect_args( + m, + 2, + session, + "strategy_select", + choices = c("Strategy C" = "c", "Strategy D" = "d") + ) + }) +}) diff --git a/tests/testthat/test-mod_show_strategy_text.R b/tests/testthat/test-mod_show_strategy_text.R new file mode 100644 index 0000000..0e4ece2 --- /dev/null +++ b/tests/testthat/test-mod_show_strategy_text.R @@ -0,0 +1,134 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_show_strategy_text_ui("test") + + expect_snapshot(ui) +}) + +test_that("mod_show_strategy_text_get_descriptions_lookup", { + # arrange + sample_descriptions_lookup <- c( + "strategy_a", + "strategy_b" + ) + m <- mock(sample_descriptions_lookup) + local_mocked_bindings( + "read_json" = m, + .package = "jsonlite" + ) + + # act + actual <- mod_show_strategy_text_get_descriptions_lookup() + + # assert + expect_equal(actual, sample_descriptions_lookup) +}) + +test_that("strategy_stub", { + # arrange + local_mocked_bindings( + "mod_show_strategy_text_get_descriptions_lookup" = \() { + c( + "strategy_a", + "strategy_b" + ) + } + ) + + # act + shiny::testServer( + mod_show_strategy_text_server, + args = list(selected_strategy = reactiveVal("a")), + { + # assert + selected_strategy("strategy_a_acute") + actual1 <- strategy_stub() + + selected_strategy("strategy_a_chronic") + actual2 <- strategy_stub() + + selected_strategy("strategy_b") + actual3 <- strategy_stub() + + expect_equal(actual1, "strategy_a") + expect_equal(actual2, "strategy_a") + expect_equal(actual3, "strategy_b") + } + ) +}) + +test_that("strategy_text", { + # arrange + m <- mock("text_a", "text_b") + local_mocked_bindings( + "mod_show_strategy_text_get_descriptions_lookup" = \() { + c( + "strategy_a", + "strategy_b" + ) + }, + "fetch_strategy_text" = m + ) + + # act + shiny::testServer( + mod_show_strategy_text_server, + args = list(selected_strategy = reactiveVal("a")), + { + # act + selected_strategy("strategy_a_acute") + actual1 <- strategy_text() + + selected_strategy("strategy_b") + actual2 <- strategy_text() + + # validate caching: this should not call fetch_strategy_text again + selected_strategy("strategy_a_chronic") + actual3 <- strategy_text() + + # assert + expect_equal(actual1, "text_a") + expect_equal(actual2, "text_b") + expect_equal(actual3, "text_a") + + expect_called(m, 2) + expect_args(m, 1, "strategy_a") + expect_args(m, 2, "strategy_b") + } + ) +}) + +test_that("strategy_text is rendered", { + # arrange + m <- mock("html") + local_mocked_bindings( + "mod_show_strategy_text_get_descriptions_lookup" = \() { + c( + "strategy_a", + "strategy_b" + ) + }, + "fetch_strategy_text" = \(...) "strategy text", + "md_string_to_html" = m + ) + + # act + shiny::testServer( + mod_show_strategy_text_server, + args = list(selected_strategy = reactiveVal("strategy_a")), + { + # assert + actual <- output$strategy_text + + expect_equal(actual, "html") + + expect_called(m, 1) + expect_args( + m, + 1, + "strategy text" + ) + } + ) +}) diff --git a/tests/testthat/test-mod_table_diagnoses.R b/tests/testthat/test-mod_table_diagnoses.R new file mode 100644 index 0000000..cdcadc0 --- /dev/null +++ b/tests/testthat/test-mod_table_diagnoses.R @@ -0,0 +1,151 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_table_diagnoses_ui("test") + + expect_snapshot(ui) +}) + +test_that("it loads the diagnoses csv", { + # arrange + m <- mock("diagnoses_lookup") + testthat::local_mocked_bindings("read_csv" = m, .package = "readr") + + # act + shiny::testServer( + mod_table_diagnoses_server, + args = list( + inputs_data = reactiveVal(), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + # assert + expect_equal(diagnoses_lookup, "diagnoses_lookup") + expect_called(m, 1) + expect_call( + m, + 1, + readr::read_csv( + app_sys("app", "data", "diagnoses.csv"), + col_types = "c" + ) + ) + } + ) +}) + +test_that("diagnoses_data", { + # arrange + + # act + shiny::testServer( + mod_table_diagnoses_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + actual <- diagnoses_data() + + # assert + expect_equal(actual, "diagnoses") + } + ) +}) + + +test_that("diagnoses_prepared", { + # arrange + testthat::local_mocked_bindings( + "read_csv" = \(...) "diagnoses_lookup", + .package = "readr" + ) + + m <- mock("diagnoses_prepared") + testthat::local_mocked_bindings( + "prepare_diagnoses_data" = m + ) + + # act + shiny::testServer( + mod_table_diagnoses_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + actual <- diagnoses_prepared() + + # assert + expect_equal(actual, "diagnoses_prepared") + expect_called(m, 1) + expect_args(m, 1, "diagnoses", "diagnoses_lookup", "R00", "strategy", 1) + } + ) +}) + +test_that("diagnoses_table (no rows)", { + # arrange + testthat::local_mocked_bindings("prepare_diagnoses_data" = \(...) { + tibble::tibble() + }) + + # act + shiny::testServer( + mod_table_diagnoses_server, + args = list( + inputs_data = reactiveVal(list(diagnoses = "diagnoses")), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + # assert + expect_error( + output$diagnoses_table, + "No diagnoses to display." + ) + } + ) +}) + +test_that("diagnoses_table (with rows)", { + # arrange + sample_prepared_data <- tibble::tibble(a = 1, b = 2) + + m <- mock("entabled") + testthat::local_mocked_bindings( + "prepare_diagnoses_data" = \(...) sample_prepared_data, + "entable_encounters" = m + ) + + testthat::local_mocked_bindings( + "render_gt" = shiny::renderText, + .package = "gt" + ) + + # act + shiny::testServer( + mod_table_diagnoses_server, + args = list( + inputs_data = reactiveVal(list(diagnoses = "diagnoses")), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + actual <- output$diagnoses_table + + # assert + expect_equal(actual, "entabled") + expect_called(m, 1) + expect_args(m, 1, sample_prepared_data) + } + ) +}) diff --git a/tests/testthat/test-mod_table_procedures.R b/tests/testthat/test-mod_table_procedures.R new file mode 100644 index 0000000..b3eb4c5 --- /dev/null +++ b/tests/testthat/test-mod_table_procedures.R @@ -0,0 +1,151 @@ +test_that("ui", { + setup_ui_test() + + ui <- mod_table_procedures_ui("test") + + expect_snapshot(ui) +}) + +test_that("it loads the procedures csv", { + # arrange + m <- mock("procedures_lookup") + testthat::local_mocked_bindings("read_csv" = m, .package = "readr") + + # act + shiny::testServer( + mod_table_procedures_server, + args = list( + inputs_data = reactiveVal(), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + # assert + expect_equal(procedures_lookup, "procedures_lookup") + expect_called(m, 1) + expect_call( + m, + 1, + readr::read_csv( + app_sys("app", "data", "procedures.csv"), + col_types = "c" + ) + ) + } + ) +}) + +test_that("procedures_data", { + # arrange + + # act + shiny::testServer( + mod_table_procedures_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + actual <- procedures_data() + + # assert + expect_equal(actual, "procedures") + } + ) +}) + + +test_that("procedures_prepared", { + # arrange + testthat::local_mocked_bindings( + "read_csv" = \(...) "procedures_lookup", + .package = "readr" + ) + + m <- mock("procedures_prepared") + testthat::local_mocked_bindings( + "prepare_procedures_data" = m + ) + + # act + shiny::testServer( + mod_table_procedures_server, + args = list( + inputs_data = reactiveVal(inputs_data_sample), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + actual <- procedures_prepared() + + # assert + expect_equal(actual, "procedures_prepared") + expect_called(m, 1) + expect_args(m, 1, "procedures", "procedures_lookup", "R00", "strategy", 1) + } + ) +}) + +test_that("procedures_table (no rows)", { + # arrange + testthat::local_mocked_bindings("prepare_procedures_data" = \(...) { + tibble::tibble() + }) + + # act + shiny::testServer( + mod_table_procedures_server, + args = list( + inputs_data = reactiveVal(list(procedures = "procedures")), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + # assert + expect_error( + output$procedures_table, + "No procedures to display." + ) + } + ) +}) + +test_that("procedures_table (with rows)", { + # arrange + sample_prepared_data <- tibble::tibble(a = 1, b = 2) + + m <- mock("entabled") + testthat::local_mocked_bindings( + "prepare_procedures_data" = \(...) sample_prepared_data, + "entable_encounters" = m + ) + + testthat::local_mocked_bindings( + "render_gt" = shiny::renderText, + .package = "gt" + ) + + # act + shiny::testServer( + mod_table_procedures_server, + args = list( + inputs_data = reactiveVal(list(procedures = "procedures")), + selected_provider = reactiveVal("R00"), + selected_strategy = reactiveVal("strategy"), + selected_year = reactiveVal(1) + ), + { + actual <- output$procedures_table + + # assert + expect_equal(actual, "entabled") + expect_called(m, 1) + expect_args(m, 1, sample_prepared_data) + } + ) +}) diff --git a/tests/testthat/test-run_app.R b/tests/testthat/test-run_app.R new file mode 100644 index 0000000..7ff39f6 --- /dev/null +++ b/tests/testthat/test-run_app.R @@ -0,0 +1,37 @@ +test_that("run_app", { + # arrange + m1 <- mock() + m2 <- mock("app") + m3 <- mock("cache") + + local_mocked_bindings( + "shinyOptions" = m1, + "shinyApp" = m2, + .package = "shiny" + ) + local_mocked_bindings( + "cache_disk" = m3, + .package = "cachem" + ) + + # act + app <- run_app() + + # assert + expect_equal(app, "app") + + expect_called(m1, 1) + expect_args(m1, 1, cache = "cache") + + expect_called(m2, 1) + expect_args( + m2, + 1, + ui = app_ui, + server = app_server, + enableBookmarking = "server" + ) + + expect_called(m3, 1) + expect_args(m3, 1, ".cache") +}) diff --git a/tests/testthat/test-utils_data.R b/tests/testthat/test-utils_data.R new file mode 100644 index 0000000..59ba32f --- /dev/null +++ b/tests/testthat/test-utils_data.R @@ -0,0 +1,156 @@ +test_that("prepare_age_sex_data", { + # arrange + # nolint start + age_sex_data <- tibble::tribble( + ~age_group , ~sex , ~n , + "0-4" , 1 , 5 , + "5-9" , 1 , 10 , + "10-14" , 1 , 20 , + "0-4" , 2 , 7 , + "5-9" , 2 , 12 , + "10-14" , 2 , 22 , + ) + # nolint end + expected <- structure( + list( + age_group = structure( + c(1L, 3L, 2L, 1L, 3L, 2L), + levels = c("0-4", "10-14", "5-9"), + class = "factor" + ), + sex = structure( + c(1L, 1L, 1L, 2L, 2L, 2L), + levels = c("Males", "Females"), + class = "factor" + ), + n = c(-5, -10, -20, 7, 12, 22) + ), + row.names = c(NA, -6L), + class = c("tbl_df", "tbl", "data.frame") + ) + + # act + actual <- prepare_age_sex_data(age_sex_data) + + # assert + expect_equal(actual, expected) +}) + +test_that("get_golem_config", { + # arrange + m <- mock("config") + local_mocked_bindings( + "get" = m, + .package = "config" + ) + + local_mocked_bindings( + "app_sys" = \(...) file.path(...) + ) + + # act + actual <- get_golem_config("value", "config") + + # assert + expect_equal(actual, "config") + + expect_called(m, 1) + expect_args( + m, + 1, + value = "value", + config = "config", + file = "golem-config.yml", + use_parent = TRUE + ) +}) + +test_that("make_strategy_group_lookup", { + # arrange + config <- list( + "a" = list( + strategy_subset = c("s1" = "S1", "s2" = "S2") + ), + b = list( + strategy_subset = c("s3" = "S3") + ) + ) + expected <- list( + "s1" = "a", + "s2" = "a", + "s3" = "b" + ) + + # act + actual <- make_strategy_group_lookup(config) + + # assert + expect_equal(actual, expected) +}) + +test_that("md_file_to_html returns NULL if file doesn't exist", { + # act + actual <- md_file_to_html("nonexistent_file.md") + + # assert + expect_null(actual) +}) + +test_that("md_file_to_html reads valid file", { + # arrange + local_mocked_bindings( + "app_sys" = \(...) file.path(...) + ) + + stub(md_file_to_html, "file.exists", TRUE) + + m1 <- mock("content") + m2 <- mock("html") + local_mocked_bindings( + "mark_html" = m1, + .package = "markdown" + ) + local_mocked_bindings( + "HTML" = m2, + .package = "shiny" + ) + + # act + actual <- md_file_to_html("file.md") + + # assert + expect_equal(actual, "html") + + expect_called(m1, 1) + expect_args(m1, 1, "file.md", output = FALSE, template = FALSE) + + expect_called(m2, 1) + expect_args(m2, 1, "content") +}) + + +test_that("md_string_to_html", { + # arrange + m1 <- mock("content") + m2 <- mock("html") + local_mocked_bindings( + "mark_html" = m1, + .package = "markdown" + ) + local_mocked_bindings( + "HTML" = m2, + .package = "shiny" + ) + + # act + actual <- md_string_to_html("text") + + # assert + expect_equal(actual, "html") + + expect_called(m1, 1) + expect_args(m1, 1, "text", output = FALSE, template = FALSE) + + expect_called(m2, 1) + expect_args(m2, 1, "content") +}) diff --git a/tests/testthat/test-utils_plot.R b/tests/testthat/test-utils_plot.R new file mode 100644 index 0000000..58d13b1 --- /dev/null +++ b/tests/testthat/test-utils_plot.R @@ -0,0 +1,108 @@ +test_that("isolate_provider_peers", { + # arrange + # nolint start + peers <- tibble::tribble( + ~procode , ~peer , + "A" , "B" , + "A" , "C" , + "B" , "A" , + "B" , "C" + ) + # nolint end + expected <- c("B", "C") + + # act + actual <- isolate_provider_peers("A", peers) + + # assert + expect_equal(actual, expected) +}) + +test_that("generate_rates_baseline_data", { + # arrange + m <- mock(c("B", "C")) + local_mocked_bindings("isolate_provider_peers" = m) + + # nolint start + rates <- tibble::tribble( + ~provider , ~fyear , + "A" , 202223 , + "B" , 202223 , + "C" , 202223 , + "D" , 202223 , + "A" , 202324 , + "B" , 202324 , + "C" , 202324 , + "D" , 202324 , + ) + provider <- "A" + selected_year <- 202324 + + expected <- tibble::tribble( + ~provider , ~fyear , ~is_peer , + "B" , 202324 , TRUE , + "C" , 202324 , TRUE , + "A" , 202324 , FALSE , + "D" , 202324 , NA + ) + # nolint end + + # act + actual <- generate_rates_baseline_data( + rates, + provider, + "peers_lookup", + selected_year + ) + + # assert + expect_equal(actual, expected) + + expect_called(m, 1) + expect_args(m, 1, "A", "peers_lookup") +}) + +test_that("uprime_calculations", { + # arrange + # nolint start + df <- tibble::tribble( + ~denominator , ~rate , ~national_rate , + 1000 , 2.0 , 1.9 , + 2000 , 1.5 , 1.9 , + 1500 , 2.5 , 1.9 , + 2500 , 1.8 , 1.9 + ) + # nolint end + + # act + actual <- uprime_calculations(df) + + # assert + expect_equal(actual$cl, 1.9) + expect_equal( + actual$z_i, + c(0.1444332, 1.0613633, -0.8170378, -0.2283690), + tolerance = 1e-6 + ) + + expect_equal( + actual$lcl3(c(1000, 1500)), + c(-0.1770841, 0.2040680), + tolerance = 1e-6 + ) + expect_equal( + actual$lcl2(c(1000, 1500)), + c(0.5152773, 0.7693786), + tolerance = 1e-6 + ) + expect_equal( + actual$ucl2(c(1000, 1500)), + c(3.284723, 3.030621), + tolerance = 1e-6 + ) + expect_equal( + actual$ucl3(c(1000, 1500)), + c(3.977084, 3.595932), + tolerance = 1e-6 + ) +}) diff --git a/tests/testthat/test-utils_plot_rates.R b/tests/testthat/test-utils_plot_rates.R new file mode 100644 index 0000000..0fc7302 --- /dev/null +++ b/tests/testthat/test-utils_plot_rates.R @@ -0,0 +1,93 @@ +test_that("get_peers_lookup", { + # arrange + m <- mock("peers", cycle = TRUE) + local_mocked_bindings( + "read_csv" = m, + .package = "readr" + ) + local_mocked_bindings("app_sys" = file.path) + + # act + actual_nhp <- get_peers_lookup("nhp") + actual_la <- get_peers_lookup("la") + + # assert + expect_equal(actual_nhp, "peers") + expect_equal(actual_la, "peers") + + expect_called(m, 2) + expect_args(m, 1, "app/data/nhp-peers.csv", "col_types" = "c") + expect_args(m, 2, "app/data/la-peers.csv", "col_types" = "c") + + expect_error(get_peers_lookup("other")) +}) + +test_that("get_rates_data", { + # arrange + # nolint start + inputs_data_sample <- tibble::tribble( + ~fyear , ~provider , ~strategy , ~crude_rate , ~std_rate , + 202223 , "a" , "Strategy A" , 1 , 2 , + 202223 , "b" , "Strategy A" , 3 , 4 , + 202223 , "national" , "Strategy A" , 5 , 6 , + 202324 , "a" , "Strategy A" , 7 , 8 , + 202324 , "b" , "Strategy A" , 9 , 10 , + 202324 , "national" , "Strategy A" , 10 , 12 , + 202223 , "a" , "Strategy B" , 2 , 1 , + 202223 , "b" , "Strategy B" , 4 , 3 , + 202223 , "national" , "Strategy B" , 6 , 5 , + 202324 , "a" , "Strategy B" , 8 , 7 , + 202324 , "b" , "Strategy B" , 10 , 9 , + 202324 , "national" , "Strategy B" , 12 , 11 + ) + + expected_a <- tibble::tribble( + ~fyear , ~provider , ~strategy , ~rate , ~national_rate , + 202223 , "a" , "Strategy A" , 2 , 6 , + 202223 , "b" , "Strategy A" , 4 , 6 , + 202324 , "a" , "Strategy A" , 8 , 12 , + 202324 , "b" , "Strategy A" , 10 , 12 + ) + + expected_b <- tibble::tribble( + ~fyear , ~provider , ~strategy , ~rate , ~national_rate , + 202223 , "a" , "Strategy B" , 1 , 5 , + 202223 , "b" , "Strategy B" , 3 , 5 , + 202324 , "a" , "Strategy B" , 7 , 11 , + 202324 , "b" , "Strategy B" , 9 , 11 + ) + # nolint end + + # act + actual_a <- get_rates_data(inputs_data_sample, "Strategy A") + actual_b <- get_rates_data(inputs_data_sample, "Strategy B") + + # assert + expect_equal(actual_a, expected_a) + expect_equal(actual_b, expected_b) +}) + +test_that("get_rates_trend_data", { + # arrange + # nolint start + df <- tibble::tribble( + ~fyear , ~provider , ~strategy , ~rate , ~national_rate , + 202223 , "a" , "Strategy A" , 2 , 6 , + 202223 , "b" , "Strategy A" , 4 , 6 , + 202324 , "a" , "Strategy A" , 8 , 12 , + 202324 , "b" , "Strategy A" , 10 , 12 + ) + + expected <- tibble::tribble( + ~fyear , ~provider , ~strategy , ~rate , ~national_rate , + 202223 , "a" , "Strategy A" , 2 , 6 , + 202324 , "a" , "Strategy A" , 8 , 12 + ) + # nolint end + + # act + actual <- get_rates_trend_data(df, "a") + + # assert + expect_equal(actual, expected) +}) diff --git a/tests/testthat/test-utils_server.R b/tests/testthat/test-utils_server.R new file mode 100644 index 0000000..ae60f17 --- /dev/null +++ b/tests/testthat/test-utils_server.R @@ -0,0 +1,216 @@ +test_that("get_container uses get_azure_token when not in a managed environment", { + # arrange + m_get_managed_token <- \() stop("expected error") + m_get_azure_token <- mock("token") + m_blob_endpoint <- mock("ep") + m_storage_container <- mock("container") + + stub(get_container, "AzureAuth::get_managed_token", m_get_managed_token) + stub(get_container, "AzureAuth::get_azure_token", m_get_azure_token) + stub(get_container, "AzureStor::blob_endpoint", m_blob_endpoint) + stub(get_container, "AzureStor::storage_container", m_storage_container) + + # act + actual <- get_container("ep_uri", "container_name") + + # assert + expect_called(m_get_azure_token, 1) + expect_args( + m_get_azure_token, + 1, + resource = "https://storage.azure.com", + tenant = "common", + app = "04b07795-8ddb-461a-bbee-02f9e1bf7b46", + use_cache = TRUE + ) + + expect_called(m_blob_endpoint, 1) + expect_args(m_blob_endpoint, 1, "ep_uri", token = "token") + + expect_called(m_storage_container, 1) + expect_args(m_storage_container, 1, "ep", "container_name") + + expect_equal(actual, "container") +}) + +test_that("get_container uses get_managed_token when in a managed environment", { + # arrange + m_get_managed_token <- mock("token") + m_get_azure_token <- mock() + m_blob_endpoint <- mock("ep") + m_storage_container <- mock("container") + + stub(get_container, "AzureAuth::get_managed_token", m_get_managed_token) + stub(get_container, "AzureAuth::get_azure_token", m_get_azure_token) + stub(get_container, "AzureStor::blob_endpoint", m_blob_endpoint) + stub(get_container, "AzureStor::storage_container", m_storage_container) + + # act + actual <- get_container("ep_uri", "container_name") + + # assert + expect_called(m_get_managed_token, 1) + expect_args(m_get_managed_token, 1, "https://storage.azure.com/") + + expect_called(m_get_azure_token, 0) + + expect_called(m_blob_endpoint, 1) + expect_args(m_blob_endpoint, 1, "ep_uri", token = "token") + + expect_called(m_storage_container, 1) + expect_args(m_storage_container, 1, "ep", "container_name") + + expect_equal(actual, "container") +}) + +test_that("get_all_geo_data works for nhp geography", { + # arrange + data_types <- c( + "age_sex", + "diagnoses", + "procedures", + "rates" + ) + + mock_age_sex <- data.frame(provider = c("P1", "P2"), age = c(30, 40)) + mock_diagnoses <- data.frame( + provider = c("P1", "P2"), + diagnosis = c("D1", "D2") + ) + mock_procedures <- data.frame( + provider = c("P1", "P2"), + procedure = c("PR1", "PR2") + ) + mock_rates <- data.frame(provider = c("P1", "P2"), rate = c(0.1, 0.2)) + + m_get_container <- mock("container") + m_read_azure_parquet <- mock( + mock_age_sex, + mock_diagnoses, + mock_procedures, + mock_rates + ) + + withr::local_envvar("DATA_VERSION" = "dev") + + local_mocked_bindings("get_container" = m_get_container) + local_mocked_bindings( + "read_azure_parquet" = m_read_azure_parquet, + .package = "azkit" + ) + + # act + result <- get_all_geo_data("nhp") + + # assert + expect_type(result, "list") + expect_length(result, 4) + expect_named(result, data_types) + + # verify get_container was called correctly + expect_called(m_get_container, 1) + expect_args(m_get_container, 1) + + # verify read_azure_parquet was called 4 times with correct arguments + expect_called(m_read_azure_parquet, 4) + + for (i in seq_along(data_types)) { + expect_args( + m_read_azure_parquet, + i, + "container", + data_types[i], + "dev/provider" + ) + } + + # verify the data is returned correctly + expect_equal(result$age_sex, mock_age_sex) + expect_equal(result$diagnoses, mock_diagnoses) + expect_equal(result$procedures, mock_procedures) + expect_equal(result$rates, mock_rates) +}) + +test_that("get_all_geo_data works for la geography and renames lad23cd to provider", { + # arrange + data_types <- c( + "age_sex", + "diagnoses", + "procedures", + "rates" + ) + + mock_age_sex <- data.frame(lad23cd = c("P1", "P2"), age = c(30, 40)) + mock_diagnoses <- data.frame( + lad23cd = c("P1", "P2"), + diagnosis = c("D1", "D2") + ) + mock_procedures <- data.frame( + lad23cd = c("P1", "P2"), + procedure = c("PR1", "PR2") + ) + mock_rates <- data.frame(lad23cd = c("P1", "P2"), rate = c(0.1, 0.2)) + + expected_age_sex <- dplyr::rename(mock_age_sex, provider = lad23cd) + expected_diagnoses <- dplyr::rename(mock_diagnoses, provider = lad23cd) + expected_procedures <- dplyr::rename(mock_procedures, provider = lad23cd) + expected_rates <- dplyr::rename(mock_rates, provider = lad23cd) + + m_get_container <- mock("container") + m_read_azure_parquet <- mock( + mock_age_sex, + mock_diagnoses, + mock_procedures, + mock_rates + ) + + withr::local_envvar("DATA_VERSION" = "dev") + + local_mocked_bindings("get_container" = m_get_container) + local_mocked_bindings( + "read_azure_parquet" = m_read_azure_parquet, + .package = "azkit" + ) + + # act + result <- get_all_geo_data("la") + + # assert + expect_type(result, "list") + expect_length(result, 4) + expect_named(result, data_types) + + # verify get_container was called correctly + expect_called(m_get_container, 1) + expect_args(m_get_container, 1) + + # verify read_azure_parquet was called 4 times with correct arguments + expect_called(m_read_azure_parquet, 4) + + for (i in seq_along(data_types)) { + expect_args( + m_read_azure_parquet, + i, + "container", + data_types[i], + "dev/lad23cd" + ) + } + + # verify lad23cd column was renamed to provider + expect_equal(result$age_sex, expected_age_sex) + expect_equal(result$diagnoses, expected_diagnoses) + expect_equal(result$procedures, expected_procedures) + expect_equal(result$rates, expected_rates) +}) + +test_that("get_all_geo_data throws error for unknown geography", { + # arrange + local_mocked_bindings("get_container" = mock()) + + # act and assert + expect_error( + get_all_geo_data("unknown_geography"), + "Unknown geography" + ) +}) diff --git a/tests/testthat/test-utils_show_strategy_text.R b/tests/testthat/test-utils_show_strategy_text.R new file mode 100644 index 0000000..b31dc2f --- /dev/null +++ b/tests/testthat/test-utils_show_strategy_text.R @@ -0,0 +1,32 @@ +test_that("fetch_strategy_text works", { + # arrange + m <- function(req) { + httr2::response(status_code = 200, body = charToRaw("strategy text")) + } + httr2::local_mocked_responses(m) + + # act + text <- fetch_strategy_text("stub") + + # assert + expect_equal(text, "strategy text") +}) + +test_that("fetch_strategy_text calls correct url", { + # arrange + local_mocked_bindings( + "req_perform" = identity, + "resp_body_string" = identity, + .package = "httr2" + ) + + # act + req <- fetch_strategy_text("stub") + + # assert + + expect_equal( + req$url, + "https://raw.githubusercontent.com/The-Strategy-Unit/nhp_inputs/refs/heads/main/inst/app/strategy_text/stub.md" # nolint + ) +}) diff --git a/tests/testthat/test-utils_table.R b/tests/testthat/test-utils_table.R new file mode 100644 index 0000000..4728484 --- /dev/null +++ b/tests/testthat/test-utils_table.R @@ -0,0 +1,353 @@ +# Tests for prepare_procedures_data ---- + +test_that("prepare_procedures_data returns NULL when no data matches filter", { + # arrange + procedures_data <- data.frame( + provider = c("ABC", "DEF"), + strategy = c("strategy1", "strategy2"), + fyear = c(202324, 202324), + procedure_code = c("P1", "P2"), + n = c(100, 200), + pcnt = c(0.5, 0.5) + ) + + procedures_lookup <- data.frame( + code = c("P1", "P2"), + description = c("Procedure 1", "Procedure 2") + ) + + # act + result <- prepare_procedures_data( + procedures_data, + procedures_lookup, + provider = "XYZ", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_null(result) +}) + +test_that("prepare_procedures_data filters and joins data correctly", { + # arrange + procedures_data <- data.frame( + provider = c("RCF", "RCF", "ABC"), + strategy = c("strategy1", "strategy1", "strategy1"), + fyear = c(202324, 202324, 202324), + procedure_code = c("P1", "P2", "P3"), + n = c(100, 200, 50), + pcnt = c(0.4, 0.6, 0.5) + ) + + procedures_lookup <- data.frame( + code = c("P1", "P2", "P3"), + description = c("Procedure 1", "Procedure 2", "Procedure 3") + ) + + # act + result <- prepare_procedures_data( + procedures_data, + procedures_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_equal(colnames(result), c("procedure_description", "n", "pcnt")) + expect_equal(result$procedure_description, c("Procedure 1", "Procedure 2")) + expect_equal(result$n, c(100, 200)) + expect_equal(result$pcnt, c(0.4, 0.6)) +}) + +test_that("prepare_procedures_data handles unknown procedure codes", { + # arrange + procedures_data <- data.frame( + provider = c("RCF", "RCF"), + strategy = c("strategy1", "strategy1"), + fyear = c(202324, 202324), + procedure_code = c("P1", "UNKNOWN"), + n = c(100, 50), + pcnt = c(0.6, 0.4) + ) + + procedures_lookup <- data.frame( + code = c("P1"), + description = c("Procedure 1") + ) + + # act + result <- prepare_procedures_data( + procedures_data, + procedures_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_equal( + result$procedure_description, + c("Procedure 1", "Unknown/Invalid Procedure Code") + ) +}) + +test_that("prepare_procedures_data adds 'Other' row when pcnt_total < 1", { + # arrange + procedures_data <- data.frame( + provider = c("RCF", "RCF"), + strategy = c("strategy1", "strategy1"), + fyear = c(202324, 202324), + procedure_code = c("P1", "P2"), + n = c(100, 50), + pcnt = c(0.4, 0.2) + ) + + procedures_lookup <- data.frame( + code = c("P1", "P2"), + description = c("Procedure 1", "Procedure 2") + ) + + # act + result <- prepare_procedures_data( + procedures_data, + procedures_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 3) + expect_equal( + result$procedure_description, + c("Procedure 1", "Procedure 2", "Other") + ) + expect_equal(result$pcnt[3], 0.4) + expect_equal(result$n[3], 150 * 0.4 / 0.6) +}) + +test_that("prepare_procedures_data does not add 'Other' row when pcnt_total = 1", { + # arrange + procedures_data <- data.frame( + provider = c("RCF", "RCF"), + strategy = c("strategy1", "strategy1"), + fyear = c(202324, 202324), + procedure_code = c("P1", "P2"), + n = c(100, 50), + pcnt = c(0.6, 0.4) + ) + + procedures_lookup <- data.frame( + code = c("P1", "P2"), + description = c("Procedure 1", "Procedure 2") + ) + + # act + result <- prepare_procedures_data( + procedures_data, + procedures_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_false("Other" %in% result$procedure_description) +}) + +# Tests for prepare_diagnoses_data ---- + +test_that("prepare_diagnoses_data returns NULL when no data matches filter", { + # arrange + diagnoses_data <- data.frame( + provider = c("ABC", "DEF"), + strategy = c("strategy1", "strategy2"), + fyear = c(202324, 202324), + diagnosis = c("D1", "D2"), + n = c(100, 200), + pcnt = c(0.5, 0.5) + ) + + diagnoses_lookup <- data.frame( + diagnosis_code = c("D1", "D2"), + diagnosis_description = c("Diagnosis 1", "Diagnosis 2") + ) + + # act + result <- prepare_diagnoses_data( + diagnoses_data, + diagnoses_lookup, + provider = "XYZ", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_null(result) +}) + +test_that("prepare_diagnoses_data filters and joins data correctly", { + # arrange + diagnoses_data <- data.frame( + provider = c("RCF", "RCF", "ABC"), + strategy = c("strategy1", "strategy1", "strategy1"), + fyear = c(202324, 202324, 202324), + diagnosis = c("D1", "D2", "D3"), + n = c(100, 200, 50), + pcnt = c(0.4, 0.6, 0.5) + ) + + diagnoses_lookup <- data.frame( + diagnosis_code = c("D1", "D2", "D3"), + diagnosis_description = c("Diagnosis 1", "Diagnosis 2", "Diagnosis 3") + ) + + # act + result <- prepare_diagnoses_data( + diagnoses_data, + diagnoses_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_equal(colnames(result), c("diagnosis_description", "n", "pcnt")) + expect_equal(result$diagnosis_description, c("Diagnosis 1", "Diagnosis 2")) + expect_equal(result$n, c(100, 200)) + expect_equal(result$pcnt, c(0.4, 0.6)) +}) + +test_that("prepare_diagnoses_data handles unknown diagnosis codes", { + # arrange + diagnoses_data <- data.frame( + provider = c("RCF", "RCF"), + strategy = c("strategy1", "strategy1"), + fyear = c(202324, 202324), + diagnosis = c("D1", "UNKNOWN"), + n = c(100, 50), + pcnt = c(0.6, 0.4) + ) + + diagnoses_lookup <- data.frame( + diagnosis_code = c("D1"), + diagnosis_description = c("Diagnosis 1") + ) + + # act + result <- prepare_diagnoses_data( + diagnoses_data, + diagnoses_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_equal( + result$diagnosis_description, + c("Diagnosis 1", "Unknown/Invalid Diagnosis Code") + ) +}) + +test_that("prepare_diagnoses_data adds 'Other' row when pcnt_total < 1", { + # arrange + diagnoses_data <- data.frame( + provider = c("RCF", "RCF"), + strategy = c("strategy1", "strategy1"), + fyear = c(202324, 202324), + diagnosis = c("D1", "D2"), + n = c(100, 50), + pcnt = c(0.4, 0.2) + ) + + diagnoses_lookup <- data.frame( + diagnosis_code = c("D1", "D2"), + diagnosis_description = c("Diagnosis 1", "Diagnosis 2") + ) + + # act + result <- prepare_diagnoses_data( + diagnoses_data, + diagnoses_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 3) + expect_equal( + result$diagnosis_description, + c("Diagnosis 1", "Diagnosis 2", "Other") + ) + expect_equal(result$pcnt[3], 0.4) + expect_equal(result$n[3], 150 * 0.4 / 0.6) +}) + +test_that("prepare_diagnoses_data does not add 'Other' row when pcnt_total = 1", { + # arrange + diagnoses_data <- data.frame( + provider = c("RCF", "RCF"), + strategy = c("strategy1", "strategy1"), + fyear = c(202324, 202324), + diagnosis = c("D1", "D2"), + n = c(100, 50), + pcnt = c(0.6, 0.4) + ) + + diagnoses_lookup <- data.frame( + diagnosis_code = c("D1", "D2"), + diagnosis_description = c("Diagnosis 1", "Diagnosis 2") + ) + + # act + result <- prepare_diagnoses_data( + diagnoses_data, + diagnoses_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_false("Other" %in% result$diagnosis_description) +}) + +test_that("prepare_diagnoses_data filters by correct year", { + # arrange + diagnoses_data <- data.frame( + provider = c("RCF", "RCF", "RCF"), + strategy = c("strategy1", "strategy1", "strategy1"), + fyear = c(202324, 202425, 202324), + diagnosis = c("D1", "D2", "D3"), + n = c(100, 200, 50), + pcnt = c(0.5, 0.5, 0.5) + ) + + diagnoses_lookup <- data.frame( + diagnosis_code = c("D1", "D2", "D3"), + diagnosis_description = c("Diagnosis 1", "Diagnosis 2", "Diagnosis 3") + ) + + # act + result <- prepare_diagnoses_data( + diagnoses_data, + diagnoses_lookup, + provider = "RCF", + strategy = "strategy1", + selected_year = 202324 + ) + + # assert + expect_equal(nrow(result), 2) + expect_equal(result$diagnosis_description, c("Diagnosis 1", "Diagnosis 3")) +})