Update validation function to new endpoint types

Author: Monika-H

R/aaa.R

@@ -52,3 +52,4 @@ utils::globalVariables("TOTAL")
 utils::globalVariables("WIN_A")
 utils::globalVariables("WIN_P")
 utils::globalVariables("TIE_A")
+utils::globalVariables("linetype")

R/internal.R

@@ -692,10 +692,75 @@
   return(tte_data)
 }
 
+.create_validation_binary_step <- function(layers, x, arms) {
+
+  binary_layers <- which(layers == "GeomSegment")
+
+  if (length(binary_layers) != 0) {
+    binary_step_data <-
+      do.call("rbind",
+              lapply(binary_layers,
+                     function(i) {
+                       dat <- ggplot2::layer_data(plot = x,
+                                                  i = i)[, c("x", "y",
+                                                             "yend",
+                                                             "group",
+                                                             "linetype")]
+                       return(dat)
+                     }))
+
+    binary_step_data <- binary_step_data %>%
+      dplyr::filter(linetype == 2) %>%
+      dplyr::mutate(proportion = yend - y) %>%
+      dplyr::select(x, y, proportion, group)
+
+    binary_step_data$group <- factor(binary_step_data$group, labels = arms)
+
+  } else {
+    binary_step_data <- NULL
+  }
+
+  return(binary_step_data)
+}
+
+.create_validation_binary_last <- function(layers, x, arms) {
+
+  polygon_layers <- which(layers == "GeomPolygon")
+  point_layers <- which(layers == "GeomPoint")
+
+    if (length(polygon_layers) == 1 &&
+          length(point_layers) == 1) {
+
+      point_data <- ggplot2::layer_data(x, point_layers) %>%
+        dplyr::select(x, y, group)
+
+      polygon_data <- unique(ggplot2::layer_data(x, polygon_layers))
+      polygon_data <- polygon_data %>%
+        dplyr::filter(y %in% point_data$y) %>%
+        dplyr::group_by(group) %>%
+        dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE),
+                         "upper_se" = base::max(x, na.rm = TRUE))
+
+      binary_data <- dplyr::left_join(point_data, polygon_data,
+                                      by = "group")
+      binary_data$se <- binary_data$x - binary_data$lower_se
+      binary_data$group <- factor(binary_data$group, labels = arms)
+
+    } else {
+
+      binary_data <- NULL
+
+    }
+
+  return(binary_data)
+}
+
+
+
 .create_validation_scatter <- function(layers, x, arms) {
   scatter_data <- do.call("rbind", lapply(which(layers == "GeomPoint"),
                                           ggplot2::layer_data, plot = x))
-  if (!is.null(scatter_data)) {
+  if (!is.null(scatter_data) && nrow(scatter_data) > 2) {
     scatter_data <- scatter_data[, c("group", "x", "y")]
     scatter_data$group <- factor(scatter_data$group, labels = arms)
   }

R/maraca.R

@@ -485,7 +485,8 @@ plot_maraca <- function(
       ) +
       ggplot2::geom_segment(
         data = tmp2,
-        aes(x = x, y = y, xend = x, yend = yend),
+        aes(x = x, y = y, xend = x, yend = yend,
+            group = arm),
         color = "darkgrey", linetype = 2
       )
   }
@@ -662,6 +663,8 @@ validate_maraca_plot <- function(x,  ...) {
   arms <- levels(pb$plot$data[, pb$plot$labels$colour])
 
   tte_data <- .create_validation_tte(layers, x, arms)
+  binary_step_data <- .create_validation_binary_step(layers, x, arms)
+  binary_last_data <- .create_validation_binary_last(layers, x, arms)
   scatter_data <- .create_validation_scatter(layers, x, arms)
   boxstat_data <- .create_validation_box(layers, x, arms)
   violin_data <- .create_validation_violin(layers, x, arms)
@@ -685,6 +688,8 @@ validate_maraca_plot <- function(x,  ...) {
       plot_type = plot_type,
       proportions = proportions,
       tte_data = tte_data,
+      binary_step_data = binary_step_data,
+      binary_last_data = binary_last_data,
       scatter_data = scatter_data,
       boxstat_data = boxstat_data,
       violin_data = violin_data,

tests/testthat/test_maraca.R

@@ -940,7 +940,8 @@ test_that("validationFunction", {
   expect_type(val_res_scatter, "list")
 
   expected_names <- c("plot_type", "proportions",
-                      "tte_data", "scatter_data",
+                      "tte_data", "binary_step_data",
+                      "binary_last_data", "scatter_data",
                       "boxstat_data", "violin_data",
                       "wo_stats")
   expect_named(val_res_def, expected_names, ignore.order = TRUE)