Merge branch 'main' into secondary-axis

NAMESPACE

@@ -24,4 +24,6 @@ importFrom(rlang,.data)
 importFrom(rlang,as_name)
 importFrom(rlang,enquo)
 importFrom(tidyselect,all_of)
+import(rlang)
+importFrom(dplyr,"%>%")
 importFrom(tidyselect,any_of)

R/ZZZ.R

@@ -1,3 +1,8 @@
+#' @importFrom tidyselect any_of
+#' @importFrom dplyr %>%
+#' @import rlang
+NULL
+
 #' null replacement
 #'
 #' if `a` is null, choose `b`.

R/geom_ptd_icon.R

@@ -64,7 +64,7 @@ GeomPTDIcon <- ggplot2::ggproto( # Exclude Linting
   "GeomPTDIcon",
   ggplot2::Geom,
   required_aes = c("type", "icon"),
-  default_aes = aes(),
+  default_aes = ggplot2::aes(),
   extra_params = c("na.rm", "icons_size", "icons_position"),
   draw_key = ggplot2::draw_key_point,
   draw_panel = geom_ptd_icon_draw_panel

R/ptd_add_rebase_column.R

@@ -5,15 +5,23 @@
 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)
-      })
+      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(across(rebase, ~ ifelse(is.na(.x), 0, 1)))
+      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))

R/ptd_add_short_group_warnings.R

@@ -21,7 +21,11 @@ ptd_add_short_group_warnings <- function(
     .data,
     warning_threshold = getOption("ptd_spc.warning_threshold", 13)) {
   .data <- .data %>%
-    dplyr::group_by(pick(c("f", "rebase_group"))) %>%
+    dplyr::group_by(
+      dplyr::across(
+        c("f", "rebase_group")
+      )
+    ) %>%
     dplyr::mutate(
       short_group_warning = dplyr::n() < warning_threshold,
       .after = "rebase_group"

R/ptd_calculate_assurance_type.R

@@ -1,11 +1,10 @@
 #' 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.
+#' 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.
-#' @returns The calculated data frame
+#' @return The calculated data frame
 #'
 #' @noRd
 #'
@@ -20,14 +19,16 @@ ptd_calculate_assurance_type <- function(.data) {
     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
+  # 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")
+    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

@@ -14,18 +14,14 @@ ptd_calculate_point_type <- function(.data, improvement_direction) {
   .data %>%
     dplyr::group_by(.data$f, .data$rebase_group) %>%
     dplyr::mutate(
-      special_cause_flag = ptd_special_cause_flag(
+      special_cause_type = ptd_special_cause_type(
         .data$y,
         .data$relative_to_mean,
         .data$close_to_limits,
         .data$outside_limits
       ),
-      point_type = dplyr::case_when(
-        special_cause_flag == 0 ~ "common_cause",
-        improvement_direction == 0 ~ paste0("special_cause_neutral_", ifelse(relative_to_mean > 0, "high", "low")), # nolint
-        relative_to_mean == improvement_direction ~ "special_cause_improvement",
-        TRUE ~ "special_cause_concern" # nolint
-      )
+      special_cause_flag = .data[["special_cause_type"]] != "Common Cause",
+      point_type = ptd_point_type(.data[["special_cause_type"]], improvement_direction)
     ) %>%
     dplyr::ungroup()
 }
@@ -87,15 +83,52 @@ ptd_part_of_two_in_three <- function(v, x) {
   as.numeric(v == 1 & abs(x) == 1)
 }
 
-ptd_special_cause_flag <- function(y, relative_to_mean, close_to_limits, outside_limits) {
-  part_seven_point_one_side_mean <- ptd_part_of_seven_trend(ptd_seven_point_one_side_mean(relative_to_mean)) # nolint
-  part_seven_point_trend <- ptd_part_of_seven_trend(ptd_seven_point_trend(y))
-  part_two_in_three <- ptd_part_of_two_in_three(ptd_two_in_three(close_to_limits, relative_to_mean), close_to_limits) # nolint
+ptd_special_cause_type <- function(y, relative_to_mean, close_to_limits, outside_limits) {
+  part_seven_point_trend <- ptd_part_of_seven_trend(ptd_seven_point_trend(y)) # Exclude Linting
+  part_two_in_three <- ptd_part_of_two_in_three(ptd_two_in_three(close_to_limits, relative_to_mean), close_to_limits) # Exclude Linting
+  part_seven_point_one_side_mean <- ptd_part_of_seven_trend(ptd_seven_point_one_side_mean(relative_to_mean)) # Exclude Linting
 
-  as.numeric(
-    abs(outside_limits) == 1 |
-      abs(part_seven_point_one_side_mean) == 1 |
-      abs(part_seven_point_trend) == 1 |
-      part_two_in_three == 1
+  # calculate the sign of difference of points in y
+  sdy <- sign(diff(y))
+  # if a point is part of a trend either side, use right side
+  sdy <- ifelse(
+    c(part_seven_point_trend[-1], 0) & part_seven_point_trend,
+    c(sdy, utils::tail(sdy, 1)),
+    c(0, sdy)
   )
+
+  above_or_below <- ifelse(relative_to_mean > 0, "Above", "Below") # Exclude Linting
+
+  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"
+  )
+}
+
+ptd_point_type <- function(special_cause_type, improvement_direction) {
+  v <- dplyr::case_when(
+    stringr::str_detect(special_cause_type, "Above|Increasing") ~ 1,
+    stringr::str_detect(special_cause_type, "Below|Decreasing") ~ -1,
+    .default = 0
+  )
+
+  if (improvement_direction == 0) {
+    dplyr::case_when(
+      v > 0 ~ "special_cause_neutral_high",
+      v < 0 ~ "special_cause_neutral_low",
+      .default = "common_cause"
+    )
+  } else {
+    # orient based on improvement direction
+    v <- v * improvement_direction
+
+    dplyr::case_when(
+      v > 0 ~ "special_cause_improvement",
+      v < 0 ~ "special_cause_concern",
+      .default = "common_cause"
+    )
+  }
 }

R/ptd_create_ggplot.R

@@ -142,7 +142,10 @@ ptd_create_ggplot <- function(
   break_limits <- break_lines %in% c("both", "limits")
   break_process <- break_lines %in% c("both", "process")
 
-  plot <- ggplot2::ggplot(.data, aes(x = .data$x, y = .data$y)) +
+  plot <- ggplot2::ggplot(
+    .data,
+    ggplot2::aes(x = .data$x, y = .data$y)
+  ) +
     ggplot2::geom_line(
       aes(y = .data$upl, group = if (break_limits) .data$rebase_group else 0),
       linetype = "dashed",

R/ptd_create_plotly.R

@@ -2,39 +2,52 @@
 #'
 #' Creates a plotly object using the parameters passed in.
 #'
-#' @param point_size Specify the plotting point size for the plotly output.
-#'  The default is 4.
-#' @param icons_size The size of the icons, defined in terms of font size.
-#'  The default is 0.15.
-#' @inheritParams ptd_create_ggplot
-#' @returns A plotly object
+#' @param x an object created by [ptd_spc()]
+#' @param point_size Specify the plotting point size for the ggplot output. Default is 2.5.
+#' @param percentage_y_axis Specify whether the y axis values are percentages. Accepted values are TRUE for percentage y
+#'     axis, FALSE for integer y axis. Defaults to FALSE.
+#' @param main_title Specify a character string value for the ggplot title.
+#' @param x_axis_label Specify a character string value for the x axis title.
+#' @param y_axis_label Specify a character string value for the y axis title.
+#' @param fixed_x_axis_multiple Specify whether, if producing a faceted spc, x axis should be fixed for all facet plots.
+#'     Accepted values are TRUE for fixed x axes or FALSE for individual x axes.
+#' @param fixed_y_axis_multiple Specify whether, if producing a faceted spc, y axis should be fixed for all facet plots.
+#'     Accepted values are TRUE for fixed y axes or FALSE for individual y axes.
+#' @param x_axis_date_format Specify how dates on the x axis should be displayed. Format should be provided
+#'     as a character string using 'd m Y' etc syntax.
+#' @param x_axis_breaks Specify an interval value for breaks on the x axis. Value should be a character string
+#'     expressing interval length and type, e.g. "3 months", "7 days".
+#' @param y_axis_breaks Specify an interval value for breaks on the y axis. Value should be a numeric vector of length
+#'     1, either an integer for integer scales or a decimal value for percentage scales. This option is ignored if
+#'     faceting is in use.
+#' @param icons_size The size of the icons, defined in terms of font size. Defaults to 0.15.
+#' @param icons_position Where to show the icons, either "top right" (default), "bottom right", "bottom left",
+#'     "top left", or "none".
+#' @param colours Specify the colours to use in the plot, use the [ptd_spc_colours()] function to change defaults.
+#' @param theme_override Specify a list containing ggplot theme elements which can be used to override the default
+#'     appearance of the plot.
+#' @param break_lines whether to break lines when a rebase happens. Defaults to "both", but can break just "limits"
+#'     lines, "process" lines, or "none".
+#' @param ... currently ignored
+#' @return The plotly object
 #' @export
-ptd_create_plotly <- function(
-    x,
-    point_size = 4,
-    percentage_y_axis = FALSE,
-    main_title,
-    x_axis_label,
-    y_axis_label,
-    fixed_x_axis_multiple = TRUE,
-    fixed_y_axis_multiple = TRUE,
-    x_axis_date_format = "%d/%m/%y",
-    x_axis_breaks = NULL,
-    y_axis_breaks = NULL,
-    icons_size = 0.15,
-    icons_position = c("top right", "bottom right", "bottom left", "top left", "none"),
-    colours = ptd_spc_colours(),
-    theme_override = NULL,
-    break_lines = c("both", "limits", "process", "none"),
-    ...) {
-  dots <- list(...)
-  if (length(dots) > 0) {
-    warning(
-      "Unknown arguments provided by plot: ",
-      paste(names(dots), collapse = ", "),
-      ".\nCheck for common spelling mistakes in arguments."
-    )
-  }
+ptd_create_plotly <- function(x,
+                              point_size = 4,
+                              percentage_y_axis = FALSE,
+                              main_title,
+                              x_axis_label,
+                              y_axis_label,
+                              fixed_x_axis_multiple = TRUE,
+                              fixed_y_axis_multiple = TRUE,
+                              x_axis_date_format = "%d/%m/%y",
+                              x_axis_breaks = NULL,
+                              y_axis_breaks = NULL,
+                              icons_size = 0.15,
+                              icons_position = c("top right", "bottom right", "bottom left", "top left", "none"),
+                              colours = ptd_spc_colours(),
+                              theme_override = NULL,
+                              break_lines = c("both", "limits", "process", "none"),
+                              ...) {
   ggplot <- ptd_create_ggplot(
     x,
     point_size = point_size,
@@ -60,17 +73,14 @@ ptd_create_plotly <- function(
 
   if (!is.null(options$facet_field)) {
     if (icons_position != "none") {
-      warning(
-        paste(
-          "Facetted plots do not support showing the icons.",
-          "Setting `icons_position` to \"none\"."
-        )
-      )
+      warning("Facetted plots do not support showing the icons, setting `icons_position` to \"none\"")
     }
     icons_position <- "none"
   }
 
-  plot <- plotly::ggplotly(ggplot)
+  plot <- ggplot |>
+    plotly::ggplotly() |>
+    ptd_plotly_fix_tooltips()
 
   annotations <- if (any(ggplot$data$short_group_warning)) {
     list(
@@ -122,10 +132,11 @@ ptd_create_plotly <- function(
 
   plotly::layout(
     plot,
-    # put legend in centre of x-axis
+    hovermode = "x unified",
+    # put legend in center of x-axis
     legend = list(
       orientation = "h", # show entries horizontally
-      xanchor = "center", # use centre of legend as anchor
+      xanchor = "center", # use center of legend as anchor
       x = 0.5,
       y = -0.6
     ),
@@ -142,3 +153,23 @@ read_svg_as_b64 <- function(filename) {
     base64enc::base64encode(img)
   )
 }
+
+ptd_plotly_fix_tooltips <- function(plot) {
+  # "fix" the tooltips. this could do with being improved upon, but for now it's better than nothing
+  # each "layer" has it's own text which contains the x value, a new line, then the y value (and sometimes more stuff
+  # on futher new lines)
+  # what we want to do is remove the x value from all but the first item, then only keep the second line's value
+  plot$x$data[[1]]$text <- plot$x$data[[1]]$text |>
+    stringr::str_replace_all(
+      "^(.*?)(<br />)(.*?)(?:<br />.*$)",
+      "\\1\\2\\2\\3"
+    )
+
+  for (i in seq_along(plot$x$data)[-1]) {
+    plot$x$data[[i]]$text <- plot$x$data[[i]]$text |>
+      stringr::str_remove("^.*?(<br />)") |>
+      stringr::str_remove("<br />.*$")
+  }
+
+  plot
+}

R/ptd_spc.R

@@ -111,23 +111,22 @@ ptd_spc.SharedData <- function(.data, ...) { # Exclude Linting
 }
 
 #' @export
-ptd_spc.data.frame <- function(
-    .data, # Exclude Linting
-    value_field,
-    date_field,
-    facet_field,
-    rebase = ptd_rebase(),
-    fix_after_n_points = NULL,
-    improvement_direction = "increase",
-    target = ptd_target(),
-    trajectory,
-    screen_outliers = TRUE) {
-  value_field <- as_name(enquo(value_field))
-  date_field <- as_name(enquo(date_field))
-  facet_field <- if (!missing(facet_field)) as_name(enquo(facet_field))
-  trajectory <- if (!missing(trajectory)) as_name(enquo(trajectory))
-
-  # Validate all inputs. Validation problems will generate an error and stop code execution.
+ptd_spc.data.frame <- function(.data, # Exclude Linting
+                               value_field,
+                               date_field,
+                               facet_field,
+                               rebase = ptd_rebase(),
+                               fix_after_n_points = NULL,
+                               improvement_direction = "increase",
+                               target = ptd_target(),
+                               trajectory,
+                               screen_outliers = TRUE) {
+  value_field <- rlang::quo_name(rlang::enquo(value_field))
+  date_field <- rlang::quo_name(rlang::enquo(date_field))
+  facet_field <- if (!missing(facet_field)) rlang::quo_name(rlang::enquo(facet_field))
+  trajectory <- if (!missing(trajectory)) rlang::quo_name(rlang::enquo(trajectory))
+
+  # validate all inputs.  Validation problems will generate an error and stop code execution.
   options <- ptd_spc_options(
     value_field, date_field, facet_field, rebase, fix_after_n_points,
     improvement_direction, target, trajectory, screen_outliers