Add option to label limits and mean using secondary y axis

.lintr

@@ -1,9 +1,11 @@
 linters: linters_with_defaults(
-  line_length_linter(120),
+  line_length_linter(92),
   cyclocomp_linter(20),
+  indentation_linter(hanging_indent_style = "tidy"),
   object_name_linter("snake_case"))
-exclusions: list()
-exclude: "# Exclude Linting"
-exclude_start: "# Begin Exclude Linting"
-exclude_end: "# End Exclude Linting"
+exclusions: list(
+  "R/ptd_spc_colours.R" = 5)
+exclude: "# Exclude Linting|#\\s?nolint"
+exclude_start: "# Begin Exclude Linting|#\\s?nolint-start"
+exclude_end: "# End Exclude Linting|#\\s?nolint-end"
 encoding: "ISO-8859-1"

DESCRIPTION

@@ -25,30 +25,34 @@ Encoding: UTF-8
 RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)
 Imports: 
-    ggplot2,
-    scales,
+    assertthat,
+    base64enc,
+    crayon,
     dplyr,
+    ggplot2,
+    grid,
+    magrittr,
+    plotly,
     rlang,
-    crayon,
-    stringr,
-    assertthat,
     rsvg,
-    tidyselect (>= 1.2.0),
-    plotly,
-    base64enc
+    scales,
+    stringr,
+    tidyselect (>= 1.2.0)
 Suggests: 
     covr,
-    lintr (>= 3.0.0),
-    testthat (>= 3.0.0),
-    rmarkdown,
+    hexSticker,
     knitr,
+    lintr (>= 3.0.0),
     mockery,
-    withr,
+    NHSRdatasets,
+    pillar,
+    rmarkdown,
     spelling,
+    testthat (>= 3.0.0),
+    tibble,
     utils,
-    NHSRdatasets,
-    grid,
-    hexSticker
+    withr
+Depends: R (>= 4.1.0)
 VignetteBuilder: knitr
 Config/testthat/edition: 3
 Language: en-US

NAMESPACE

@@ -14,6 +14,16 @@ export(ptd_rebase)
 export(ptd_spc)
 export(ptd_spc_colours)
 export(ptd_target)
+importFrom(dplyr,across)
+importFrom(dplyr,if_all)
+importFrom(dplyr,if_any)
+importFrom(dplyr,pick)
+importFrom(ggplot2,aes)
+importFrom(magrittr,"%>%")
+importFrom(rlang,.data)
+importFrom(rlang,as_name)
+importFrom(rlang,enquo)
+importFrom(tidyselect,all_of)
 import(rlang)
 importFrom(dplyr,"%>%")
 importFrom(tidyselect,any_of)

R/NHSRplotthedots-package.R

@@ -0,0 +1,11 @@
+#' @keywords internal
+"_PACKAGE"
+
+## usethis namespace: start
+#' @importFrom dplyr across if_all if_any pick
+#' @importFrom ggplot2 aes
+#' @importFrom magrittr %>%
+#' @importFrom rlang as_name enquo
+#' @importFrom tidyselect all_of any_of
+## usethis namespace: end
+NULL

R/ZZZ.R

@@ -29,12 +29,13 @@ NULL
 }
 # End Exclude Linting
 
-#' checks if a vector is a date
+#' Checks if a vector is a date
 #'
-#' validates a vector is a date by checking to see if it is either a Date or POSIXt class
+#' Validates a vector is a date by checking to see if it is either a Date or
+#' POSIXt class
 #'
 #' @param x a vector to check
-#' @return `TRUE` if `x` is a date, `FALSE` otherwise
+#' @returns `TRUE` if `x` is a date, `FALSE` otherwise
 #' @noRd
 is_date <- function(x) {
   inherits(x, c("Date", "POSIXt"))

R/geom_ptd_icon.R

@@ -1,18 +1,25 @@
-geom_ptd_icon_draw_panel <- function(self, data, panel_params, coord,
-                                     icons_size = 8,
-                                     icons_position = c("top right", "bottom right", "bottom left", "top left")) {
+geom_ptd_icon_draw_panel <- function(
+    self,
+    data,
+    panel_params,
+    coord,
+    icons_size = 8,
+    icons_position = c("top right", "bottom right", "bottom left", "top left")) {
   icons_position <- match.arg(icons_position)
-  # match the icons_position to x,y coordinates. either {0, 1}, but shift in by 0.01 so icons don't clip
+  # match the icons_position to x,y coordinates. either {0, 1}, but shift in by
+  # 0.01 so icons don't clip
   icons_position_x <- abs(as.numeric(grepl("right$", icons_position)) - 0.01)
   icons_position_y <- abs(as.numeric(grepl("^top", icons_position)) - 0.01)
 
-  # figure out how to justify the icons viewport, this should be two strings like c("right", "top")
+  # figure out how to justify the icons viewport, this should be two strings
+  # like c("right", "top")
   just <- rev(strsplit(icons_position, " ")[[1]])
 
   # icons_size defines the font size, radius needs to be smaller than that
   radius <- icons_size / 16
 
-  # use the coord transformation for the colours, but then set the x, y coordinates manually (inside the viewport)
+  # use the coord transformation for the colours, but then set the x, y
+  # coordinates manually (inside the viewport)
   d <- coord$transform(data, panel_params) %>%
     dplyr::mutate(
       x = ifelse(.data$type == "variation", 3.5 * radius, radius),
@@ -74,17 +81,19 @@ GeomPTDIcon <- ggplot2::ggproto( # Exclude Linting
 #' @param ... currently unused
 #'
 #' @export
-geom_ptd_icon <- function(data = NULL,
-                          icons_size = 8L,
-                          icons_position = c("top right", "bottom right", "bottom left", "top left"),
-                          ...) {
+geom_ptd_icon <- function(
+    data = NULL,
+    icons_size = 8L,
+    icons_position = c("top right", "bottom right", "bottom left", "top left"),
+    ...) {
   icons_position <- match.arg(icons_position)
 
-  # set's up the layer: this is a little unusual for ggplot as we fix the mapping, data argument etc. As this geom is
-  # not-exported it's not intended to be used in any other way
+  # sets up the layer: this is a little unusual for ggplot as we fix the
+  # mapping, data argument etc. As this geom is not exported it's not intended
+  # to be used in any other way
   ggplot2::layer(
     geom = GeomPTDIcon,
-    mapping = ggplot2::aes(type = .data$type, icon = .data$icon),
+    mapping = aes(type = .data$type, icon = .data$icon),
     data = if (is.null(data)) ptd_get_icons else ptd_get_icons(data),
     stat = "identity",
     position = "identity",
@@ -94,7 +103,8 @@ geom_ptd_icon <- function(data = NULL,
   )
 }
 
-# function to transform the data: this takes the raw ptd spc data and returns two rows per facet:
+# function to transform the data: this takes the raw ptd spc data and returns
+# two rows per facet:
 #  - one row for the variation icon
 #  - one row for the assurance icon (if applicable)
 ptd_get_icons <- function(.x) {

R/ptd_add_rebase_column.R

@@ -1,33 +1,33 @@
-# adds a column named rebase
-# with 1's in any row corresponding to a rebase date
-# and 0's everywhere else
-
-ptd_add_rebase_column <- function(.data, date_field, facet_field, rebase) {
-  if (is.list(rebase)) {
-    rebase_table <- dplyr::bind_rows(
-      lapply(
-        seq_along(rebase),
-        function(i) {
-          data.frame(
-            d = to_datetime(rebase[[i]]),
-            f = names(rebase)[[i]], rebase = 1
-          )
-        }
-      )
-    )
-    colnames(rebase_table) <- c(date_field, facet_field, "rebase")
-
-    .data <- .data %>%
-      dplyr::left_join(rebase_table, by = c(date_field, facet_field)) %>%
-      dplyr::mutate(
-        dplyr::across(rebase, ~ ifelse(is.na(.x), 0, 1))
-      )
-  } else if (!is.null(rebase)) {
-    # in with NULL returns FALSE, so this is suitable even if rebase isn't provided
-    .data$rebase <- as.numeric(.data[[date_field]] %in% to_datetime(rebase))
-  } else {
-    .data$rebase <- 0
-  }
-
-  .data
-}
+# adds a column named rebase
+# with 1's in any row corresponding to a rebase date
+# and 0's everywhere else
+
+ptd_add_rebase_column <- function(.data, date_field, facet_field, rebase) {
+  if (is.list(rebase)) {
+    rebase_table <- dplyr::bind_rows(
+      lapply(
+        seq_along(rebase),
+        function(i) {
+          data.frame(
+            d = to_datetime(rebase[[i]]),
+            f = names(rebase)[[i]], rebase = 1
+          )
+        }
+      )
+    )
+    colnames(rebase_table) <- c(date_field, facet_field, "rebase")
+
+    .data <- .data %>%
+      dplyr::left_join(rebase_table, by = c(date_field, facet_field)) %>%
+      dplyr::mutate(
+        dplyr::across(rebase, ~ ifelse(is.na(.x), 0, 1))
+      )
+  } else if (!is.null(rebase)) {
+    # in with NULL returns FALSE, so this is suitable even if rebase isn't provided
+    .data$rebase <- as.numeric(.data[[date_field]] %in% to_datetime(rebase))
+  } else {
+    .data$rebase <- 0
+  }
+
+  .data
+}

R/ptd_add_short_group_warnings.R

@@ -10,14 +10,16 @@
 #'
 #' @param .data A data frame containing the information to be plotted.
 #' @param warning_threshold An integer signifying the number of points that will
-#' trigger a warning.
-#' @return The original data frame with added column
+#'  trigger a warning.
+#' @returns The original data frame with added column
 #'
-#' @details to override the `warning_threshold` you can set the option `ptd_spc.warning_threshold`, e.g.
-#' `options(ptd_spc.warning_threshold = 10)`. The default, if the option is not set, is 12.
+#' @details To override the `warning_threshold` you can set the option
+#'  `ptd_spc.warning_threshold`, e.g. `options(ptd_spc.warning_threshold = 10)`.
+#'  The default, if the option is not set, is 12.
 #' @noRd
-#'
-ptd_add_short_group_warnings <- function(.data, warning_threshold = getOption("ptd_spc.warning_threshold", 13)) {
+ptd_add_short_group_warnings <- function(
+    .data,
+    warning_threshold = getOption("ptd_spc.warning_threshold", 13)) {
   .data <- .data %>%
     dplyr::group_by(
       dplyr::across(

R/ptd_add_target_column.R

@@ -1,13 +1,13 @@
-ptd_add_target_column <- function(.data, target) {
-  if (is.null(target)) {
-    .data$target <- as.double(NA)
-  } else if (is.numeric(target)) {
-    .data$target <- target
-  } else {
-    t <- data.frame(f = names(target), target = as.numeric(target))
-
-    .data <- dplyr::left_join(.data, t, by = "f")
-  }
-
-  .data
-}
+ptd_add_target_column <- function(.data, target) {
+  if (is.null(target)) {
+    .data$target <- as.double(NA)
+  } else if (is.numeric(target)) {
+    .data$target <- target
+  } else {
+    t <- data.frame(f = names(target), target = as.numeric(target))
+
+    .data <- dplyr::left_join(.data, t, by = "f")
+  }
+
+  .data
+}

R/ptd_calculate_assurance_type.R

@@ -1,34 +1,34 @@
-#' Calculate assurance type (internal function)
-#'
-#' Performs calculations to identify whether the SPC calculations indicate whether we will consistently pass the
-#' target, consistently fail the target, or inconsistently pass/fail the target.
-#'
-#' @param .data A data frame containing the information to be plotted.
-#' @return The calculated data frame
-#'
-#' @noRd
-#'
-ptd_calculate_assurance_type <- function(.data) {
-  d <- .data %>%
-    dplyr::group_by(.data$f) %>%
-    dplyr::slice_tail(n = 1)
-
-  options <- attr(.data, "options")
-
-  if (is.null(options$target) || options$improvement_direction == "neutral") {
-    return(dplyr::summarise(d, assurance_type = as.character(NA), .groups = "drop"))
-  }
-
-  # linting reports this is assigned by not used, so excluding line from linting as it is used
-  is_increasing <- options$improvement_direction == "increase" # Exclude Linting
-
-  d %>%
-    dplyr::summarise(
-      assurance_type = dplyr::case_when(
-        target > upl ~ ifelse(is_increasing, "consistent_fail", "consistent_pass"),
-        target < lpl ~ ifelse(is_increasing, "consistent_pass", "consistent_fail"),
-        TRUE ~ "inconsistent"
-      ),
-      .groups = "drop"
-    )
-}
+#' Calculate assurance type (internal function)
+#'
+#' Performs calculations to identify whether the SPC calculations indicate whether we will consistently pass the
+#' target, consistently fail the target, or inconsistently pass/fail the target.
+#'
+#' @param .data A data frame containing the information to be plotted.
+#' @return The calculated data frame
+#'
+#' @noRd
+#'
+ptd_calculate_assurance_type <- function(.data) {
+  d <- .data %>%
+    dplyr::group_by(.data$f) %>%
+    dplyr::slice_tail(n = 1)
+
+  options <- attr(.data, "options")
+
+  if (is.null(options$target) || options$improvement_direction == "neutral") {
+    return(dplyr::summarise(d, assurance_type = as.character(NA), .groups = "drop"))
+  }
+
+  # linting reports this is assigned by not used, so excluding line from linting as it is used
+  is_increasing <- options$improvement_direction == "increase" # Exclude Linting
+
+  d %>%
+    dplyr::summarise(
+      assurance_type = dplyr::case_when(
+        target > upl ~ ifelse(is_increasing, "consistent_fail", "consistent_pass"),
+        target < lpl ~ ifelse(is_increasing, "consistent_pass", "consistent_fail"),
+        TRUE ~ "inconsistent"
+      ),
+      .groups = "drop"
+    )
+}

R/ptd_calculate_point_type.R

@@ -1,16 +1,14 @@
 #' Calculate point highlighting (internal function)
 #'
-#' Performs calculations to identify which data points should be highlighted in the final plot
-#'   based on points outside process limits, trends, shifts, etc.
+#' Performs calculations to identify which data points should be highlighted in
+#'  the final plot based on points outside process limits, trends, shifts, etc.
 #'
 #' @param .data A data frame containing the information to be plotted.
-#' @param improvement_direction An integer signifying whether improvement is represented by increasing or decreasing
-#'     values
-#' @return The calculated data frame
+#' @param improvement_direction An integer signifying whether improvement is
+#'  represented by increasing or decreasing values.
+#' @returns The calculated data frame
 #'
 #' @noRd
-#'
-
 ptd_calculate_point_type <- function(.data, improvement_direction) {
   # Begin plot the dots logical tests
   .data %>%
@@ -103,7 +101,7 @@
 
   dplyr::case_when(
     outside_limits != 0 ~ ifelse(relative_to_mean == 1, "Above UCL", "Below LCL"),
     part_seven_point_trend != 0 ~ paste0("7 Point Trend (", ifelse(sdy == 1, "In", "De"), "creasing)"),
     part_two_in_three != 0 ~ paste0("2 in 3 ", above_or_below, " CL"),
     part_seven_point_one_side_mean != 0 ~ paste0("7 Points ", above_or_below, " CL"),
     .default = "Common Cause"