show all points in funnel chart

NAMESPACE

@@ -4,7 +4,6 @@ export(convert_md_to_html)
 export(entable_encounters)
 export(fetch_strategy_text)
 export(generate_rates_baseline_data)
-export(generate_rates_funnel_data)
 export(get_all_geo_data)
 export(get_container)
 export(get_golem_config)
@@ -20,6 +19,7 @@ export(prepare_diagnoses_data)
 export(prepare_procedures_data)
 export(run_app)
 export(theme_rates)
+export(uprime_calculations)
 importFrom(rlang,":=")
 importFrom(rlang,.data)
 importFrom(rlang,.env)

R/fct_plots.R

@@ -35,40 +35,65 @@ plot_rates_trend <- function(
 }
 
 #' Plot Rates Funnel with Peers
-#' @param rates_funnel_data A data.frame. Rates data read in from Azure and
-#'     processed with [generate_rates_baseline_data] to filter for provider,
-#'     strategy and year, followed by [generate_rates_funnel_data] to generate
-#'     values for funnel structure.
+#' @param rates_funnel_data A data.frame. Rates data read in from Azure.
+#' @param funnel_calculations A list. Output from [uprime_calculations] used to
+#'     plot U-Prime lines.
 #' @param y_axis_limits Numeric vector. Min and max values for the y axis.
 #' @param x_axis_title Character. Title for the x-axis.
 #' @return A 'ggplot2' object.
 #' @export
-plot_rates_funnel <- function(rates_funnel_data, y_axis_limits, x_axis_title) {
-  lines_data <- rates_funnel_data |>
-    dplyr::select(
-      "denominator",
-      tidyselect::matches("^(lower|upper)"),
-      "mean"
-    ) |>
-    tidyr::pivot_longer(-"denominator", values_to = "rate")
+plot_rates_funnel <- function(
+  rates_funnel_data,
+  funnel_calculations,
+  y_axis_limits,
+  x_axis_title
+) {
+  cl2_colour <- "black"
+  cl3_colour <- "black"
+  cl_line_type <- "dashed"
 
   rates_funnel_data |>
     ggplot2::ggplot(ggplot2::aes(.data$denominator, .data$rate)) +
-    ggplot2::geom_line(
-      data = lines_data,
-      ggplot2::aes(group = .data$name),
-      linetype = "dashed",
-      na.rm = TRUE
+    ggplot2::geom_hline(
+      yintercept = funnel_calculations$cl,
+      linetype = cl_line_type
+    ) +
+    ggplot2::geom_function(
+      fun = funnel_calculations$lcl2,
+      colour = cl2_colour,
+      linetype = cl_line_type
+    ) +
+    ggplot2::geom_function(
+      fun = funnel_calculations$ucl2,
+      colour = cl2_colour,
+      linetype = cl_line_type
+    ) +
+    ggplot2::geom_function(
+      fun = funnel_calculations$lcl3,
+      colour = cl3_colour,
+      linetype = cl_line_type
     ) +
-    ggplot2::geom_point(ggplot2::aes(colour = .data$is_peer)) +
+    ggplot2::geom_function(
+      fun = funnel_calculations$ucl3,
+      colour = cl3_colour,
+      linetype = cl_line_type
+    ) +
+    ggplot2::geom_point(ggplot2::aes(
+      colour = .data$is_peer,
+      alpha = .data$is_peer
+    )) +
     ggrepel::geom_text_repel(
       data = dplyr::filter(rates_funnel_data, !is.na(.data$is_peer)),
       ggplot2::aes(label = .data$provider, colour = .data$is_peer),
       max.overlaps = Inf # include all labels
     ) +
     ggplot2::scale_colour_manual(
       values = c("TRUE" = "black", "FALSE" = "red"),
-      na.value = "lightgrey"
+      na.value = "black"
+    ) +
+    ggplot2::scale_alpha_manual(
+      values = c("TRUE" = 1, "FALSE" = 1),
+      na.value = 0.2
     ) +
     ggplot2::theme(legend.position = "none") +
     ggplot2::scale_x_continuous(labels = scales::comma_format()) +
@@ -88,10 +113,21 @@ plot_rates_box <- function(rates_box_data, y_axis_limits) {
   rates_box_data |>
     ggplot2::ggplot(ggplot2::aes(x = "", y = .data$rate)) +
     ggplot2::geom_boxplot(alpha = 0.2, outlier.shape = NA) +
-    ggbeeswarm::geom_quasirandom(ggplot2::aes(colour = .data$is_peer)) +
+    ggbeeswarm::geom_quasirandom(
+      # just show peers/selected provider
+      data = \(.x) dplyr::filter(.x, !is.na(.data$is_peer)),
+      ggplot2::aes(
+        colour = .data$is_peer,
+        alpha = .data$is_peer
+      )
+    ) +
     ggplot2::scale_colour_manual(
       values = c("TRUE" = "black", "FALSE" = "red"),
-      na.value = "lightgrey"
+      na.value = "black"
+    ) +
+    ggplot2::scale_alpha_manual(
+      values = c("TRUE" = 1, "FALSE" = 1),
+      na.value = 0.2
     ) +
     ggplot2::coord_cartesian(ylim = y_axis_limits) +
     ggplot2::labs(x = "") +

R/mod_plot_rates.R

@@ -71,23 +71,28 @@ mod_plot_rates_server <- function(
         )
     })
 
-    rates_funnel_data <- shiny::reactive({
-      shiny::req(rates_baseline_data())
-      rates_baseline_data() |> generate_rates_funnel_data()
+    rates_funnel_calculations <- shiny::reactive({
+      df <- shiny::req(rates_baseline_data())
+
+      uprime_calculations(df)
     })
 
     # Prepare variables ----
 
     y_axis_limits <- shiny::reactive({
-      shiny::req(rates_trend_data())
-      shiny::req(rates_funnel_data())
-      range(c(
-        rates_trend_data()[["rate"]],
-        rates_funnel_data()[["rate"]],
-        rates_funnel_data()[["lower3"]],
-        rates_funnel_data()[["upper3"]]
-      )) |>
-        pmax(0)
+      td_rate <- shiny::req(rates_trend_data())$rate
+
+      bd <- shiny::req(rates_baseline_data())
+      bd$z <- rates_funnel_calculations()$z_i
+
+      fd_rate <- bd |>
+        dplyr::filter(
+          .data$denominator >= 0.05 * max(.data$denominator),
+          abs(.data$z) < 4
+        ) |>
+        dplyr::pull("rate")
+
+      c(0, max(c(td_rate, fd_rate)))
     })
 
     strategy_config <- shiny::reactive({
@@ -127,7 +132,8 @@ mod_plot_rates_server <- function(
     )
     mod_plot_rates_funnel_server(
       "mod_plot_rates_funnel",
-      rates_funnel_data,
+      rates_baseline_data,
+      rates_funnel_calculations,
       y_axis_limits,
       funnel_x_title
     )

R/mod_plot_rates_funnel.R

@@ -18,12 +18,15 @@ mod_plot_rates_funnel_ui <- function(id) {
 #' @param id Internal parameter for `shiny`.
 #' @param rates A data.frame. Annual rate values for combinations of provider
 #'     and strategy
+#' @param funnel_calculations A list. Output from [uprime_calculations] used to
+#'     plot U-Prime lines.
 #' @param y_axis_limits Numeric vector. Min and max values for the y axis.
 #' @param x_axis_title Character. Title for the x-axis.
 #' @noRd
 mod_plot_rates_funnel_server <- function(
   id,
   rates,
+  funnel_calculations,
   y_axis_limits,
   x_axis_title
 ) {
@@ -39,6 +42,7 @@ mod_plot_rates_funnel_server <- function(
 
       plot_rates_funnel(
         rates,
+        funnel_calculations(),
         y_axis_limits(),
         x_axis_title = x_axis_title()
       )

R/utils_plot.R

@@ -39,27 +39,36 @@ generate_rates_baseline_data <- function(
         .default = NA # if scheme is neither focal nor a peer
       )
     ) |>
-    dplyr::filter(!is.na(.data$is_peer)) |> # only focal scheme and peers
     dplyr::arrange(dplyr::desc(.data$is_peer)) # to plot focal scheme last
 }
 
-#' Generate Data for the Funnel Plot
-#' @param rates_baseline_data A data.frame. Rates data read in from Azure and
+#' Generate Function to Calculate U-Prime values
+#' @param df A data.frame. Rates data read in from Azure and
 #'     processed [generate_rates_baseline_data].
-#' @return A data.frame.
+#' @return A list containing items to produce a U-Prime funnel chart.
 #' @export
-generate_rates_funnel_data <- function(rates_baseline_data) {
-  rates_baseline_data |>
-    dplyr::mutate(
-      mean = rates_baseline_data$national_rate,
-      sdev_pop_i = sqrt(abs(.data$mean) / .data$denominator),
-      z = (.data$rate - .data$mean) / .data$sdev_pop_i,
-      sigz = stats::sd(.data$z, na.rm = TRUE),
-      cl2 = 2 * .data$sdev_pop_i * .data$sigz,
-      cl3 = 3 * .data$sdev_pop_i * .data$sigz,
-      lower2 = .data$mean - .data$cl2,
-      lower3 = .data$mean - .data$cl3,
-      upper2 = .data$mean + .data$cl2,
-      upper3 = .data$mean + .data$cl3
-    )
+uprime_calculations <- function(df) {
+  df <- dplyr::arrange(df, .data$denominator)
+
+  cl <- df$national_rate[[1]]
+  stdev <- sqrt(cl / df$denominator)
+  z_i <- (df$rate - cl) / stdev
+
+  mr <- abs(diff(z_i))
+  ulmr <- 3.267 * mean(mr, na.rm = TRUE)
+  amr <- mean(mr[mr < ulmr], na.rm = TRUE)
+
+  sigma_z <- amr / 1.128
+
+  sd_fn <- \(x) sqrt(cl / x) * sigma_z
+  cl_fn <- \(s) \(x) cl + s * sd_fn(x)
+
+  list(
+    cl = cl,
+    z_i = (df$rate - cl) / sd_fn(df$denominator),
+    lcl3 = cl_fn(-3),
+    ucl3 = cl_fn(3),
+    lcl2 = cl_fn(-2),
+    ucl2 = cl_fn(2)
+  )
 }