diff --git a/.lintr b/.lintr index 63d3f034..93bb6d65 100644 --- a/.lintr +++ b/.lintr @@ -1,6 +1,6 @@ linters: linters_with_defaults( - line_length_linter(92), - cyclocomp_linter(20), + line_length_linter(120), + cyclocomp_linter(23), indentation_linter(hanging_indent_style = "tidy"), object_name_linter("snake_case")) exclusions: list( diff --git a/R/ptd_validate_spc_options.R b/R/ptd_validate_spc_options.R index 228874d4..c708cec7 100644 --- a/R/ptd_validate_spc_options.R +++ b/R/ptd_validate_spc_options.R @@ -22,15 +22,7 @@ ptd_validate_spc_options <- function(options, .data) { check("facet_field") check("trajectory") - pulled_counts <- .data |> - dplyr::group_by( - pick(c(options[["date_field"]], options[["facet_field"]])) - ) |> - dplyr::count() |> - dplyr::pull("n") - assertthat::assert_that( - all( dplyr::count( dplyr::group_by_at( diff --git a/tests/testthat/_snaps/ptd_spc.md b/tests/testthat/_snaps/ptd_spc.md index 918220b4..231133fe 100644 --- a/tests/testthat/_snaps/ptd_spc.md +++ b/tests/testthat/_snaps/ptd_spc.md @@ -14,7 +14,7 @@ -------------------------------- # A tibble: 1 x 8 mean_col lpl upl n common_cause special_cause_improvement - + 1 0.142 -3.01 3.29 20 20 0 # i 2 more variables: special_cause_concern , variation_type @@ -34,7 +34,7 @@ -------------------------------- # A tibble: 1 x 9 rebase_group mean_col lpl upl n common_cause special_cause_improvement - + 1 0 0.142 -3.01 3.29 20 20 0 # i 2 more variables: special_cause_concern , variation_type @@ -54,7 +54,7 @@ -------------------------------- # A tibble: 2 x 9 f mean_col lpl upl n common_cause special_cause_improvement - + 1 0 0.0746 -2.60 2.75 10 10 0 2 1 0.209 -3.28 3.70 10 10 0 # i 2 more variables: special_cause_concern , variation_type @@ -75,7 +75,7 @@ -------------------------------- # A tibble: 2 x 10 f rebase_group mean_col lpl upl n common_cause - + 1 0 0 0.0746 -2.60 2.75 10 10 2 1 0 0.209 -3.28 3.70 10 10 # i 3 more variables: special_cause_improvement , @@ -97,7 +97,7 @@ -------------------------------- # A tibble: 1 x 9 mean_col lpl upl n common_cause special_cause_improvement - + 1 0.142 -3.01 3.29 20 20 0 # i 3 more variables: special_cause_concern , variation_type , # assurance_type @@ -118,7 +118,7 @@ -------------------------------- # A tibble: 1 x 9 mean_col lpl upl n common_cause special_cause_improvement - + 1 0.142 -3.01 3.29 20 20 0 # i 3 more variables: special_cause_concern , variation_type , # assurance_type diff --git a/tests/testthat/test-ptd_create_ggplot.R b/tests/testthat/test-ptd_create_ggplot.R index 49cc6f5c..c2767aba 100644 --- a/tests/testthat/test-ptd_create_ggplot.R +++ b/tests/testthat/test-ptd_create_ggplot.R @@ -1,447 +1,444 @@ -library(testthat) -library(mockery) -library(ggplot2, warn.conflicts = FALSE) - -# ptd_create_ggplot() ---- -test_that("it raises an error if unknown arguments are passed", { - expect_warning( - try( - ptd_create_ggplot(NULL, X = 1, Y = 2), - silent = TRUE - ), - paste0( - "Unknown arguments provided by plot: X, Y.\n", - "Check for common spelling mistakes in arguments." - ), - fixed = TRUE - ) -}) - -test_that("it raises an error is x is not a ptd_spc_df object", { - expect_error( - ptd_create_ggplot(data.frame(x = 1, y = 2)), - "x argument must be an 'ptd_spc_df' object, created by ptd_spc()." - ) -}) - -test_that("it calls ptd_validate_plot_options", { - m <- mock(stop()) - stub(ptd_create_ggplot, "ptd_validate_plot_options", m) - stub(ptd_create_ggplot, "match.arg", identity) - - try( - ptd_create_ggplot( - ptd_spc(data.frame(x = Sys.Date() + 1:20, y = rnorm(20)), "y", "x"), - "point_size", - "percentage_y_axis", - "main_title", - "x_axis_label", - "y_axis_label", - "fixed_x_axis_multiple", - "fixed_y_axis_multiple", - "x_axis_date_format", - "x_axis_breaks", - "y_axis_breaks", - "limit_annotations", - "icons_size", - "icons_position", - "colours", - "theme_override", - "break_lines" - ), - silent = TRUE - ) - - expect_called(m, 1) - expect_args( - m, 1, - "point_size", - "percentage_y_axis", - "main_title", - "x_axis_label", - "y_axis_label", - "fixed_x_axis_multiple", - "fixed_y_axis_multiple", - "x_axis_date_format", - "x_axis_breaks", - "y_axis_breaks", - "limit_annotations", - "icons_size", - "icons_position", - "colours", - "theme_override", - "break_lines" - ) -}) - -test_that("it returns a ggplot object", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - p <- ptd_create_ggplot(s) - - expect_s3_class(p, c("gg", "ggplot")) - expect_length(p$layers, 8) - expect_equal( - p$labels, - list( - x = "X", - y = "Y", - group = NULL, - title = "SPC Chart of Y, starting 02/01/2020", - caption = NULL, - colour = "point_colour", - type = "type", - icon = "icon" - ) - ) -}) - -test_that("it facets the plot if facet_field is set", { - set.seed(123) - d <- data.frame( - x = as.Date("2020-01-01") + 1:20, - y = rnorm(20), - g = rep(c(1, 2), each = 10) - ) - - withr::with_options(list(ptd_spc.warning_threshold = 10), { - s1 <- ptd_spc(d, "y", "x") - p1 <- ptd_create_ggplot(s1) - expect_equal(p1$facet$vars(), character()) - - s2 <- ptd_spc(d, "y", "x", facet_field = "g") - p2 <- ptd_create_ggplot(s2) - expect_equal(p2$facet$vars(), "f") - }) -}) - -test_that("it sets the x_axis_breaks correctly", { - m <- mock() - stub(ptd_create_ggplot, "ggplot2::scale_x_datetime", m) - - set.seed(123) - d <- data.frame(x = as.POSIXct("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - attr(d$x, "tzone") <- "" - - # no breaks set - p1 <- ptd_create_ggplot(s) - p2 <- ptd_create_ggplot(s, x_axis_breaks = "3 days") - p3 <- ptd_create_ggplot(s, x_axis_date_format = "%Y-%m-%d") - p4 <- ptd_create_ggplot(s, x_axis_breaks = "3 days", x_axis_date_format = "%Y-%m-%d") - - expect_called(m, 4) - expect_args(m, 1, breaks = d$x, date_labels = "%d/%m/%y") - expect_args(m, 2, date_breaks = "3 days", date_labels = "%d/%m/%y") - expect_args(m, 3, breaks = d$x, date_labels = "%Y-%m-%d") - expect_args(m, 4, date_breaks = "3 days", date_labels = "%Y-%m-%d") -}) - -test_that("it sets x_axis_label correctly", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - p1 <- ptd_create_ggplot(s) - expect_equal(p1$labels$x, "X") - - p2 <- ptd_create_ggplot(s, x_axis_label = "X Axis Label") - expect_equal(p2$labels$x, "X Axis Label") -}) - -test_that("it sets y_axis_label correctly", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - p1 <- ptd_create_ggplot(s) - expect_equal(p1$labels$y, "Y") - - p2 <- ptd_create_ggplot(s, y_axis_label = "Y Axis Label") - expect_equal(p2$labels$y, "Y Axis Label") -}) - -test_that("it sets scales correctly in a faceted plot", { - set.seed(123) - d <- data.frame( - x = as.Date("2020-01-01") + 1:20, - y = rnorm(20), - g = rep(c(1, 2), each = 10) - ) - - withr::with_options(list(ptd_spc.warning_threshold = 10), { - s <- ptd_spc(d, "y", "x", facet_field = "g") - }) - - p1 <- ptd_create_ggplot(s) - expect_false(p1$facet$params$free$x) - expect_false(p1$facet$params$free$y) - - p2 <- ptd_create_ggplot(s, fixed_x_axis_multiple = FALSE) - expect_true(p2$facet$params$free$x) - expect_false(p2$facet$params$free$y) - - p3 <- ptd_create_ggplot(s, fixed_y_axis_multiple = FALSE) - expect_false(p3$facet$params$free$x) - expect_true(p3$facet$params$free$y) - - p4 <- ptd_create_ggplot(s, fixed_x_axis_multiple = FALSE, fixed_y_axis_multiple = FALSE) - expect_true(p4$facet$params$free$x) - expect_true(p4$facet$params$free$y) - - p5 <- ptd_create_ggplot(s, fixed_x_axis_multiple = TRUE, fixed_y_axis_multiple = TRUE) - expect_false(p5$facet$params$free$x) - expect_false(p5$facet$params$free$y) -}) - -test_that("it creates a secondary y axis with percentage scales", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - sec_breaks <- s |> - dplyr::select(all_of(c("lpl", "mean_col", "upl"))) |> - dplyr::slice_head(n = 1) |> - unlist() |> - unname() - - p1 <- s |> - ptd_create_ggplot(percentage_y_axis = TRUE, label_limits = TRUE) - expect_equal( - round(sec_breaks, 3), - round(p1$scales$scales[[3]]$secondary.axis$breaks, 3) - ) - p2 <- s |> - ptd_create_ggplot(percentage_y_axis = TRUE, y_axis_breaks = 0.5, label_limits = TRUE) - expect_equal( - round(sec_breaks, 3), - round(p2$scales$scales[[3]]$secondary.axis$breaks, 3) - ) - - -}) - -test_that("it creates a secondary y axis with integer scales", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - sec_breaks <- s |> - dplyr::select(all_of(c("lpl", "mean_col", "upl"))) |> - dplyr::slice_head(n = 1) |> - unlist() |> - unname() - - p1 <- ptd_create_ggplot(s, percentage_y_axis = FALSE, label_limits = TRUE) - expect_equal(p1$scales$scales[[3]]$secondary.axis$breaks, sec_breaks) - - p2 <- ptd_create_ggplot(s, y_axis_breaks = 1, label_limits = TRUE) - expect_equal(p2$scales$scales[[3]]$secondary.axis$breaks, sec_breaks) - -}) - -test_that("it sets the y-axis to percentages if percentage_y_axis is TRUE", { - set.seed(123) - - m <- mock() - stub(ptd_create_ggplot, "scales::label_percent", m) - - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - p1 <- ptd_create_ggplot(s, percentage_y_axis = TRUE) - p2 <- ptd_create_ggplot(s, percentage_y_axis = TRUE, y_axis_breaks = 0.2) - - expect_called(m, 2) - expect_args(m, 1, accuracy = NULL) - expect_args(m, 2, accuracy = 0.2) -}) - -test_that("it sets the y-axis if y_axis_breaks is provided", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - p1 <- ptd_create_ggplot(s, y_axis_breaks = 1) - expect_true(all(diff(p1$scales$scales[[3]]$breaks) == 1)) - - p2 <- ptd_create_ggplot(s, y_axis_breaks = 0.5) - expect_true(all(diff(p2$scales$scales[[3]]$breaks) == 0.5)) -}) - -test_that("it adds theme_override to the plot", { - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - p1 <- ptd_create_ggplot(s) - expect_equal(p1$theme$panel.background$fill, NULL) - - p2 <- s |> - ptd_create_ggplot( - theme_override = ggplot2::theme(panel.background = ggplot2::element_rect("black")) # nolint - ) - expect_equal(p2$theme$panel.background$fill, "black") -}) - -test_that("it breaks lines", { - set.seed(123) - - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) - withr::with_options(list(ptd_spc.warning_threshold = 10), { - s <- ptd_spc(d, "y", "x", rebase = as.Date("2020-01-01") + 11) - }) - - p1 <- ptd_create_ggplot(s) - expect_null(p1$mapping$group) - expect_equal(rlang::eval_tidy(p1$layers[[1]]$mapping$group), rep(0:1, each = 10)) - expect_equal(rlang::eval_tidy(p1$layers[[2]]$mapping$group), rep(0:1, each = 10)) - expect_equal(rlang::eval_tidy(p1$layers[[5]]$mapping$group), rep(0:1, each = 10)) - expect_equal(rlang::eval_tidy(p1$layers[[6]]$mapping$group), rep(0:1, each = 10)) - - p2 <- ptd_create_ggplot(s, break_lines = "limits") - expect_equal(rlang::eval_tidy(p2$layers[[1]]$mapping$group), rep(0:1, each = 10)) - expect_equal(rlang::eval_tidy(p2$layers[[2]]$mapping$group), rep(0:1, each = 10)) - expect_equal(rlang::eval_tidy(p2$layers[[5]]$mapping$group), rep(0:1, each = 10)) - expect_equal(rlang::eval_tidy(p2$layers[[6]]$mapping$group), 0) - - p3 <- ptd_create_ggplot(s, break_lines = "process") - expect_equal(rlang::eval_tidy(p3$layers[[1]]$mapping$group), 0) - expect_equal(rlang::eval_tidy(p3$layers[[2]]$mapping$group), 0) - expect_equal(rlang::eval_tidy(p3$layers[[5]]$mapping$group), 0) - expect_equal(rlang::eval_tidy(p3$layers[[6]]$mapping$group), rep(0:1, each = 10)) - - p4 <- ptd_create_ggplot(s, break_lines = "none") - expect_equal(rlang::eval_tidy(p4$layers[[1]]$mapping$group), 0) - expect_equal(rlang::eval_tidy(p4$layers[[2]]$mapping$group), 0) - expect_equal(rlang::eval_tidy(p4$layers[[5]]$mapping$group), 0) - expect_equal(rlang::eval_tidy(p4$layers[[6]]$mapping$group), 0) -}) - -test_that("it sets the colour of the points based on the type", { - m <- mock() - - stub(ptd_create_ggplot, "ggplot2::scale_colour_manual", m) - - set.seed(123) - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) |> - # introduce some special cause variation! - dplyr::mutate( - across("y", \(y) dplyr::case_when( - x > "2020-01-15" ~ y + 0.5, - TRUE ~ y - )) - ) - - colours_neutral <- list( - common_cause = "#7b7d7d", # grey - special_cause_neutral = "#361475" # purple - ) - - colours_otherwise <- list( - common_cause = "#7b7d7d", # grey - special_cause_improvement = "#289de0", # blue - special_cause_concern = "#fab428" # orange - ) - - # case 1: improvement_direction = neutral - s1 <- ptd_spc(d, "y", "x", improvement_direction = "neutral") - p1 <- ptd_create_ggplot(s1) - # case 2: improvement_direction = "increase" - s2 <- ptd_spc(d, "y", "x", improvement_direction = "increase") - p2 <- ptd_create_ggplot(s2) - # case 3: improvement_direction = "decrease" - s3 <- ptd_spc(d, "y", "x", improvement_direction = "decrease") - p3 <- ptd_create_ggplot(s3) - - expect_called(m, 3) - expect_args(m, 1, values = colours_neutral, labels = ptd_title_case) - expect_args(m, 2, values = colours_otherwise, labels = ptd_title_case) -}) - -test_that("it sets the main title correctly", { - d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20), z = rnorm(20)) - s <- ptd_spc(d, "y", "x") - - p1 <- ptd_create_ggplot(s) - expect_equal(p1$labels$title, "SPC Chart of Y, starting 02/01/2020") - - p2 <- ptd_create_ggplot(s, main_title = "Thing") - expect_equal(p2$labels$title, "Thing") -}) - -test_that("a plot with short rebase group has a warning caption", { - d <- data.frame(x = as.Date("2020-01-01") + 1:40, y = rnorm(40)) - # rebase at midpoint, no short groups - s1 <- ptd_spc(d, "y", "x", rebase = as.Date("2020-01-20")) - # rebase close to end of points - s2 <- suppressWarnings(ptd_spc(d, "y", "x", rebase = as.Date("2020-02-02"))) - - p1 <- ptd_create_ggplot(s1) - expect_equal(p1$labels$caption, NULL) - - p2 <- ptd_create_ggplot(s2) - expect_equal( - p2$labels$caption, - paste0( - "Some trial limits created by groups of fewer than 12 points exist.\n", - "These will become more reliable as more data is added." - ) - ) -}) - -test_that("it doesn't add icons if icons_position is 'none'", { - m <- mock() - stub(ptd_create_ggplot, "geom_ptd_icon", m) - - set.seed(123) - d <- data.frame( - x = as.Date("2020-01-01") + 1:20, - y = rnorm(20) - ) - - s1 <- ptd_spc(d, "y", "x", target = 0.5) - p1 <- ptd_create_ggplot(s1, icons_position = "top right") - p2 <- ptd_create_ggplot(s1, icons_position = "none") - - expect_called(m, 1) -}) - -# plot() ---- -test_that("it calls ptd_create_ggplot()", { - set.seed(123) - s <- ptd_spc( - data.frame( - x = Sys.Date() + 1:20, - y = rnorm(20) - ), - "y", "x" - ) - - m <- mock() - stub(plot.ptd_spc_df, "ptd_create_ggplot", m) - stub(plot.ptd_spc_df, "ptd_spc_colours", "colours") - plot(s, main_title = "a", x_axis_label = "b", y_axis_label = "c") - - expect_called(m, 1) - expect_args(m, 1, s, - point_size = 4, - percentage_y_axis = FALSE, - main_title = "a", - x_axis_label = "b", - y_axis_label = "c", - 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, - limit_annotations = FALSE, - icons_size = 8L, - icons_position = c("top right", "bottom right", "bottom left", "top left", "none"), - colours = "colours", - theme_override = NULL, - break_lines = "both" - ) -}) +library(testthat) +library(mockery) +library(ggplot2, warn.conflicts = FALSE) + +# ptd_create_ggplot() ---- +test_that("it raises an error if unknown arguments are passed", { + expect_warning( + try( + ptd_create_ggplot(NULL, X = 1, Y = 2), + silent = TRUE + ), + paste0( + "Unknown arguments provided by plot: X, Y.\n", + "Check for common spelling mistakes in arguments." + ), + fixed = TRUE + ) +}) + +test_that("it raises an error is x is not a ptd_spc_df object", { + expect_error( + ptd_create_ggplot(data.frame(x = 1, y = 2)), + "x argument must be an 'ptd_spc_df' object, created by ptd_spc()." + ) +}) + +test_that("it calls ptd_validate_plot_options", { + m <- mock(stop()) + stub(ptd_create_ggplot, "ptd_validate_plot_options", m) + stub(ptd_create_ggplot, "match.arg", identity) + + try( + ptd_create_ggplot( + ptd_spc(data.frame(x = Sys.Date() + 1:20, y = rnorm(20)), "y", "x"), + "point_size", + "percentage_y_axis", + "main_title", + "x_axis_label", + "y_axis_label", + "fixed_x_axis_multiple", + "fixed_y_axis_multiple", + "x_axis_date_format", + "x_axis_breaks", + "y_axis_breaks", + "limit_annotations", + "icons_size", + "icons_position", + "colours", + "theme_override", + "break_lines" + ), + silent = TRUE + ) + + expect_called(m, 1) + expect_args( + m, 1, + "point_size", + "percentage_y_axis", + "main_title", + "x_axis_label", + "y_axis_label", + "fixed_x_axis_multiple", + "fixed_y_axis_multiple", + "x_axis_date_format", + "x_axis_breaks", + "y_axis_breaks", + "limit_annotations", + "icons_size", + "icons_position", + "colours", + "theme_override", + "break_lines" + ) +}) + +test_that("it returns a ggplot object", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + p <- ptd_create_ggplot(s) + + expect_s3_class(p, c("gg", "ggplot")) + expect_length(p$layers, 8) + expect_equal( + p$labels, + list( + x = "X", + y = "Y", + group = NULL, + title = "SPC Chart of Y, starting 02/01/2020", + caption = NULL, + colour = "point_colour", + type = "type", + icon = "icon" + ) + ) +}) + +test_that("it facets the plot if facet_field is set", { + set.seed(123) + d <- data.frame( + x = as.Date("2020-01-01") + 1:20, + y = rnorm(20), + g = rep(c(1, 2), each = 10) + ) + + withr::with_options(list(ptd_spc.warning_threshold = 10), { + s1 <- ptd_spc(d, "y", "x") + p1 <- ptd_create_ggplot(s1) + expect_equal(p1$facet$vars(), character()) + + s2 <- ptd_spc(d, "y", "x", facet_field = "g") + p2 <- ptd_create_ggplot(s2) + expect_equal(p2$facet$vars(), "f") + }) +}) + +test_that("it sets the x_axis_breaks correctly", { + m <- mock() + stub(ptd_create_ggplot, "ggplot2::scale_x_datetime", m) + + set.seed(123) + d <- data.frame(x = as.POSIXct("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + attr(d$x, "tzone") <- "" + + # no breaks set + p1 <- ptd_create_ggplot(s) + p2 <- ptd_create_ggplot(s, x_axis_breaks = "3 days") + p3 <- ptd_create_ggplot(s, x_axis_date_format = "%Y-%m-%d") + p4 <- ptd_create_ggplot(s, x_axis_breaks = "3 days", x_axis_date_format = "%Y-%m-%d") + + expect_called(m, 4) + expect_args(m, 1, breaks = d$x, date_labels = "%d/%m/%y") + expect_args(m, 2, date_breaks = "3 days", date_labels = "%d/%m/%y") + expect_args(m, 3, breaks = d$x, date_labels = "%Y-%m-%d") + expect_args(m, 4, date_breaks = "3 days", date_labels = "%Y-%m-%d") +}) + +test_that("it sets x_axis_label correctly", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + p1 <- ptd_create_ggplot(s) + expect_equal(p1$labels$x, "X") + + p2 <- ptd_create_ggplot(s, x_axis_label = "X Axis Label") + expect_equal(p2$labels$x, "X Axis Label") +}) + +test_that("it sets y_axis_label correctly", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + p1 <- ptd_create_ggplot(s) + expect_equal(p1$labels$y, "Y") + + p2 <- ptd_create_ggplot(s, y_axis_label = "Y Axis Label") + expect_equal(p2$labels$y, "Y Axis Label") +}) + +test_that("it sets scales correctly in a faceted plot", { + set.seed(123) + d <- data.frame( + x = as.Date("2020-01-01") + 1:20, + y = rnorm(20), + g = rep(c(1, 2), each = 10) + ) + + withr::with_options(list(ptd_spc.warning_threshold = 10), { + s <- ptd_spc(d, "y", "x", facet_field = "g") + }) + + p1 <- ptd_create_ggplot(s) + expect_false(p1$facet$params$free$x) + expect_false(p1$facet$params$free$y) + + p2 <- ptd_create_ggplot(s, fixed_x_axis_multiple = FALSE) + expect_true(p2$facet$params$free$x) + expect_false(p2$facet$params$free$y) + + p3 <- ptd_create_ggplot(s, fixed_y_axis_multiple = FALSE) + expect_false(p3$facet$params$free$x) + expect_true(p3$facet$params$free$y) + + p4 <- ptd_create_ggplot(s, fixed_x_axis_multiple = FALSE, fixed_y_axis_multiple = FALSE) + expect_true(p4$facet$params$free$x) + expect_true(p4$facet$params$free$y) + + p5 <- ptd_create_ggplot(s, fixed_x_axis_multiple = TRUE, fixed_y_axis_multiple = TRUE) + expect_false(p5$facet$params$free$x) + expect_false(p5$facet$params$free$y) +}) + +test_that("it creates a secondary y axis with percentage scales", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + sec_breaks <- s |> + dplyr::select(all_of(c("lpl", "mean_col", "upl"))) |> + dplyr::slice_head(n = 1) |> + unlist() |> + unname() + + p1 <- s |> + ptd_create_ggplot(percentage_y_axis = TRUE, label_limits = TRUE) + expect_equal( + round(sec_breaks, 3), + round(p1$scales$scales[[3]]$secondary.axis$breaks, 3) + ) + p2 <- s |> + ptd_create_ggplot(percentage_y_axis = TRUE, y_axis_breaks = 0.5, label_limits = TRUE) + expect_equal( + round(sec_breaks, 3), + round(p2$scales$scales[[3]]$secondary.axis$breaks, 3) + ) +}) + +test_that("it creates a secondary y axis with integer scales", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + sec_breaks <- s |> + dplyr::select(all_of(c("lpl", "mean_col", "upl"))) |> + dplyr::slice_head(n = 1) |> + unlist() |> + unname() + + p1 <- ptd_create_ggplot(s, percentage_y_axis = FALSE, label_limits = TRUE) + expect_equal(p1$scales$scales[[3]]$secondary.axis$breaks, sec_breaks) + + p2 <- ptd_create_ggplot(s, y_axis_breaks = 1, label_limits = TRUE) + expect_equal(p2$scales$scales[[3]]$secondary.axis$breaks, sec_breaks) +}) + +test_that("it sets the y-axis to percentages if percentage_y_axis is TRUE", { + set.seed(123) + + m <- mock() + stub(ptd_create_ggplot, "scales::label_percent", m) + + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + p1 <- ptd_create_ggplot(s, percentage_y_axis = TRUE) + p2 <- ptd_create_ggplot(s, percentage_y_axis = TRUE, y_axis_breaks = 0.2) + + expect_called(m, 2) + expect_args(m, 1, accuracy = NULL) + expect_args(m, 2, accuracy = 0.2) +}) + +test_that("it sets the y-axis if y_axis_breaks is provided", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + p1 <- ptd_create_ggplot(s, y_axis_breaks = 1) + expect_true(all(diff(p1$scales$scales[[3]]$breaks) == 1)) + + p2 <- ptd_create_ggplot(s, y_axis_breaks = 0.5) + expect_true(all(diff(p2$scales$scales[[3]]$breaks) == 0.5)) +}) + +test_that("it adds theme_override to the plot", { + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + p1 <- ptd_create_ggplot(s) + expect_equal(p1$theme$panel.background$fill, NULL) + + p2 <- s |> + ptd_create_ggplot( + theme_override = ggplot2::theme(panel.background = ggplot2::element_rect("black")) # nolint + ) + expect_equal(p2$theme$panel.background$fill, "black") +}) + +test_that("it breaks lines", { + set.seed(123) + + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) + withr::with_options(list(ptd_spc.warning_threshold = 10), { + s <- ptd_spc(d, "y", "x", rebase = as.Date("2020-01-01") + 11) + }) + + p1 <- ptd_create_ggplot(s) + expect_null(p1$mapping$group) + expect_equal(rlang::eval_tidy(p1$layers[[1]]$mapping$group), rep(0:1, each = 10)) + expect_equal(rlang::eval_tidy(p1$layers[[2]]$mapping$group), rep(0:1, each = 10)) + expect_equal(rlang::eval_tidy(p1$layers[[5]]$mapping$group), rep(0:1, each = 10)) + expect_equal(rlang::eval_tidy(p1$layers[[6]]$mapping$group), rep(0:1, each = 10)) + + p2 <- ptd_create_ggplot(s, break_lines = "limits") + expect_equal(rlang::eval_tidy(p2$layers[[1]]$mapping$group), rep(0:1, each = 10)) + expect_equal(rlang::eval_tidy(p2$layers[[2]]$mapping$group), rep(0:1, each = 10)) + expect_equal(rlang::eval_tidy(p2$layers[[5]]$mapping$group), rep(0:1, each = 10)) + expect_equal(rlang::eval_tidy(p2$layers[[6]]$mapping$group), 0) + + p3 <- ptd_create_ggplot(s, break_lines = "process") + expect_equal(rlang::eval_tidy(p3$layers[[1]]$mapping$group), 0) + expect_equal(rlang::eval_tidy(p3$layers[[2]]$mapping$group), 0) + expect_equal(rlang::eval_tidy(p3$layers[[5]]$mapping$group), 0) + expect_equal(rlang::eval_tidy(p3$layers[[6]]$mapping$group), rep(0:1, each = 10)) + + p4 <- ptd_create_ggplot(s, break_lines = "none") + expect_equal(rlang::eval_tidy(p4$layers[[1]]$mapping$group), 0) + expect_equal(rlang::eval_tidy(p4$layers[[2]]$mapping$group), 0) + expect_equal(rlang::eval_tidy(p4$layers[[5]]$mapping$group), 0) + expect_equal(rlang::eval_tidy(p4$layers[[6]]$mapping$group), 0) +}) + +test_that("it sets the colour of the points based on the type", { + m <- mock() + + stub(ptd_create_ggplot, "ggplot2::scale_colour_manual", m) + + set.seed(123) + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20)) |> + # introduce some special cause variation! + dplyr::mutate( + across("y", \(y) dplyr::case_when( + x > "2020-01-15" ~ y + 0.5, + TRUE ~ y + )) + ) + + colours_neutral <- list( + common_cause = "#7b7d7d", # grey + special_cause_neutral = "#361475" # purple + ) + + colours_otherwise <- list( + common_cause = "#7b7d7d", # grey + special_cause_improvement = "#289de0", # blue + special_cause_concern = "#fab428" # orange + ) + + # case 1: improvement_direction = neutral + s1 <- ptd_spc(d, "y", "x", improvement_direction = "neutral") + p1 <- ptd_create_ggplot(s1) + # case 2: improvement_direction = "increase" + s2 <- ptd_spc(d, "y", "x", improvement_direction = "increase") + p2 <- ptd_create_ggplot(s2) + # case 3: improvement_direction = "decrease" + s3 <- ptd_spc(d, "y", "x", improvement_direction = "decrease") + p3 <- ptd_create_ggplot(s3) + + expect_called(m, 3) + expect_args(m, 1, values = colours_neutral, labels = ptd_title_case) + expect_args(m, 2, values = colours_otherwise, labels = ptd_title_case) +}) + +test_that("it sets the main title correctly", { + d <- data.frame(x = as.Date("2020-01-01") + 1:20, y = rnorm(20), z = rnorm(20)) + s <- ptd_spc(d, "y", "x") + + p1 <- ptd_create_ggplot(s) + expect_equal(p1$labels$title, "SPC Chart of Y, starting 02/01/2020") + + p2 <- ptd_create_ggplot(s, main_title = "Thing") + expect_equal(p2$labels$title, "Thing") +}) + +test_that("a plot with short rebase group has a warning caption", { + d <- data.frame(x = as.Date("2020-01-01") + 1:40, y = rnorm(40)) + # rebase at midpoint, no short groups + s1 <- ptd_spc(d, "y", "x", rebase = as.Date("2020-01-20")) + # rebase close to end of points + s2 <- suppressWarnings(ptd_spc(d, "y", "x", rebase = as.Date("2020-02-02"))) + + p1 <- ptd_create_ggplot(s1) + expect_equal(p1$labels$caption, NULL) + + p2 <- ptd_create_ggplot(s2) + expect_equal( + p2$labels$caption, + paste0( + "Some trial limits created by groups of fewer than 12 points exist.\n", + "These will become more reliable as more data is added." + ) + ) +}) + +test_that("it doesn't add icons if icons_position is 'none'", { + m <- mock() + stub(ptd_create_ggplot, "geom_ptd_icon", m) + + set.seed(123) + d <- data.frame( + x = as.Date("2020-01-01") + 1:20, + y = rnorm(20) + ) + + s1 <- ptd_spc(d, "y", "x", target = 0.5) + p1 <- ptd_create_ggplot(s1, icons_position = "top right") + p2 <- ptd_create_ggplot(s1, icons_position = "none") + + expect_called(m, 1) +}) + +# plot() ---- +test_that("it calls ptd_create_ggplot()", { + set.seed(123) + s <- ptd_spc( + data.frame( + x = Sys.Date() + 1:20, + y = rnorm(20) + ), + "y", "x" + ) + + m <- mock() + stub(plot.ptd_spc_df, "ptd_create_ggplot", m) + stub(plot.ptd_spc_df, "ptd_spc_colours", "colours") + plot(s, main_title = "a", x_axis_label = "b", y_axis_label = "c") + + expect_called(m, 1) + expect_args(m, 1, s, + point_size = 4, + percentage_y_axis = FALSE, + main_title = "a", + x_axis_label = "b", + y_axis_label = "c", + 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, + limit_annotations = FALSE, + icons_size = 8L, + icons_position = c("top right", "bottom right", "bottom left", "top left", "none"), + colours = "colours", + theme_override = NULL, + break_lines = "both" + ) +}) diff --git a/tests/testthat/test-ptd_create_plotly.R b/tests/testthat/test-ptd_create_plotly.R index 4756dbd0..eaf3cfcb 100644 --- a/tests/testthat/test-ptd_create_plotly.R +++ b/tests/testthat/test-ptd_create_plotly.R @@ -1,19 +1,5 @@ library(mockery) -test_that("it raises an error if unknown arguments are passed", { - expect_warning( - try( - ptd_create_plotly(NULL, X = 1, Y = 2), - silent = TRUE - ), - paste0( - "Unknown arguments provided by plot: X, Y.\n", - "Check for common spelling mistakes in arguments." - ), - fixed = TRUE - ) -}) - test_that("ptd_create_plotly returns a plotly object", { mock_plot <- list( data = list( diff --git a/tests/testthat/test-ptd_validate_plot_options.R b/tests/testthat/test-ptd_validate_plot_options.R index b15f5d25..51fa6a98 100644 --- a/tests/testthat/test-ptd_validate_plot_options.R +++ b/tests/testthat/test-ptd_validate_plot_options.R @@ -8,7 +8,7 @@ test_that("it handles point_size correctly", { ptd_validate_plot_options(point_size = 5) # these will error - em <- "point_size must be a single number greater than 0 and less than or equal to 10." + em <- "point_size argument must be a single number greater than 0 and less than or equal to 10." expect_error(ptd_validate_plot_options(point_size = "a"), em) expect_error(ptd_validate_plot_options(point_size = 0), em) expect_error(ptd_validate_plot_options(point_size = 11), em) @@ -130,7 +130,7 @@ test_that("it handles icons_size correctly", { ptd_validate_plot_options(icons_size = 5.2) # these will error - em <- "icons_size must be an integer of length 1." + em <- "icons_size argument must be an integer of length 1." expect_error(ptd_validate_plot_options(icons_size = "a"), em, fixed = TRUE) expect_error(ptd_validate_plot_options(icons_size = c(8, 2)), em, fixed = TRUE) }) @@ -154,7 +154,7 @@ test_that("it handles colours correctly", { ptd_validate_plot_options(colours = ptd_spc_colours()) # these will error - em <- "colours must be an object created by ptd_spc_colours()." + em <- "colours argument must be an object created by ptd_spc_colours()." expect_error(ptd_validate_plot_options(colours = list()), em) }) @@ -163,7 +163,7 @@ test_that("it handles theme_override correctly", { ptd_validate_plot_options(theme_override = ggplot2::theme()) # these will error - em <- "theme_override must be an object created by theme()." + em <- "theme_override argument must be an object created by theme()." expect_error(ptd_validate_plot_options(theme_override = list()), em) }) @@ -175,7 +175,7 @@ test_that("it handles break_lines correctly", { ptd_validate_plot_options(break_lines = "none") # these will error - em <- "break_lines must be one of 'both', 'limits', 'process', or 'none'." + em <- "break_lines argument must be one of 'both', 'limits', 'process', or 'none'." expect_error(ptd_validate_plot_options(break_lines = list()), em) expect_error(ptd_validate_plot_options(break_lines = 1), em) expect_error(ptd_validate_plot_options(break_lines = c("both", "limits")), em)