Merge pull request #96 from pharmaverse/bug/individual-plots-grouping

Enhancement: allow to color by multiple variables individual plots

R/filter_breaks.R

@@ -0,0 +1,75 @@
+
+#' Filter Breaks for X-Axis
+#'
+#' Filters X-axis for consecutive breaks with at least the specified distance.
+#'
+#' @param x_breaks A numeric vector of x-axis breaks.
+#' @param plot A ggplot object used to extract plot dimensions and scales.
+#' @param min_cm_distance A numeric of the minimum distance between breaks.
+#' @return A numeric vector of filtered x-axis breaks.
+#' @importFrom ggplot2 ggplot_build ggplot_gtable
+#' @importFrom grid convertUnit
+#' @author Gerardo Rodriguez
+#' @export
+
+filter_breaks <- function(breaks = NA,
+                          plot = plot,
+                          min_cm_distance = 0.5,
+                          axis = "x") {
+
+  breaks <- unique(na.omit(sort(breaks)))
+  plot_build <- ggplot_build(plot)
+  plot_table <- ggplot_gtable(plot_build)
+
+  # Extract axis scale information
+  if (axis == "x") {
+    scale_range <- plot_build$layout$panel_params[[1]]$x.range
+  } else if (axis == "y") {
+    scale_range <- plot_build$layout$panel_params[[1]]$y.range
+  } else {
+    stop("Error: Invalid axis specified. Use 'x' or 'y'.")
+  }
+
+  # Identify the panel grob
+  panel_index <- which(sapply(plot_table$grobs,
+                              function(x) grepl("panel", x$name)))
+
+  if (length(panel_index) == 0) {
+    stop("Error: Panel grob not found.")
+  }
+  panel <- plot_table$grobs[[panel_index]]
+
+  # Extract the panel border grob to get the width or height
+  panel_border <- panel$children[[which(sapply(panel$children,
+                                               function(x) {
+                                                 grepl("panel.border", x$name)}))]]
+
+  # Convert panel width or height to cm
+  if (axis == "x") {
+    panel_size_cm <- grid::convertUnit(panel_border$width,
+                                       unitTo =  "cm",
+                                       valueOnly = TRUE)
+  } else {
+    panel_size_cm <- grid::convertUnit(panel_border$height,
+                                       unitTo =  "cm",
+                                       valueOnly = TRUE)
+  }
+
+  # Calculate the distance between breaks in cm
+  break_distances <- diff(breaks) / diff(scale_range) * panel_size_cm
+
+  # Filter only breaks that satisfy the minimum distance
+  filt_breaks <- breaks[1]
+
+  for (i in 2:length(breaks)) {
+
+    # Take latest selected break and calculate its distance
+    b0 <- filt_breaks[length(filt_breaks)]
+    bdist <- (breaks[i] - b0) / diff(scale_range) * panel_size_cm
+
+    if (bdist >= min_cm_distance) {
+      filt_breaks <- c(filt_breaks, breaks[i])
+    }
+  }
+  return(filt_breaks)
+}

R/general_lineplot.R

@@ -52,24 +52,27 @@
 general_lineplot <- function(
   data, selected_analytes, selected_usubjids, colorby_var, time_scale, xaxis_scale, cycle = NULL
 ) {
+
+  # Check if the data is empty
+  if (nrow(data) == 0) {
+    return(ggplot() + ggtitle("No data available"))
+  }
+
   # preprocess data according to user selection
   preprocessed_data <- data %>%
     filter(
       USUBJID %in% selected_usubjids,
       ANALYTE %in% selected_analytes,
       if ("EVID" %in% names(data)) EVID == 0 else TRUE
     ) %>%
-    # filter only the ones where time conc are na, use columns names
-    select(
-      ARRLT, PCSPEC, AVAL, DOSEA, DOSNO, AFRLT, NRRLT, USUBJID, ANALYTE, STUDYID, AVALU, RRLTU
-    ) %>%
     filter(!is.na(AVAL)) %>%
     mutate(
       USUBJID = factor(USUBJID),
       DOSNO = factor(DOSNO),
-      DOSEA = factor(DOSEA)
+      DOSEA = factor(DOSEA),
+      id_var = interaction(!!!syms(colorby_var), sep = ", ")
     )
-
+  
   # If there are predose records duplicate them in the previous line so they are considered
   if ("ARRLT" %in% names(preprocessed_data) &&
         any(preprocessed_data$ARRLT < 0 & preprocessed_data$AFRLT > 0)) {
@@ -102,22 +105,23 @@ general_lineplot <- function(
 
   if (xaxis_scale == "Log") {
     preprocessed_data <- preprocessed_data %>%
-      mutate(AVAL = ifelse(AVAL == 0, 0.001, AVAL))
+      mutate(AVAL = ifelse(AVAL < 1e-3, 1e-3, AVAL))
   }
-  
+
   time <- if (time_scale == "By Cycle") {
     "ARRLT"
   } else {
     "AFRLT"
   }
-
-  plt <- g_ipp(
+
+
+  plt <- tern::g_ipp(
     df = preprocessed_data,
     xvar = time,
     yvar = "AVAL",
     xlab = paste0("Time [", unique(preprocessed_data$RRLTU), "]"),
     ylab = paste0("Concentration [", unique(preprocessed_data$AVALU), "]"),
-    id_var = colorby_var,
+    id_var = "id_var",
     title = "Plot of PK Concentration - Time Profile",
     subtitle = paste0(
       "Subjects: ",
@@ -130,13 +134,27 @@ general_lineplot <- function(
     yvar_baseline = "AVAL",
     ggtheme = nestcolor::theme_nest(),
     col = NULL
-  )
+  ) +
+    labs(color = paste(colorby_var, collapse = ", "))
 
   if (xaxis_scale == "Log") {
     plt <- plt +
-      scale_y_log10(breaks = c(0.001, 0.01, 0.1, 1, 10), label = c(0.001, 0.01, 0.1, 1, 10)) +
-      annotation_logticks(sides = "l")
+      scale_y_continuous(trans = scales::pseudo_log_trans(base = 10, sigma = 1)) +   
+      labs(y = paste0("Log 10 - ", plt$labels$y))
+
+    custom_label <- function(x) {
+
+      ifelse(x == 1e-3, 0, scales::trans_format("log10", scales::math_format(10^x)))
+    }
+
+    plt <- plt %+% dplyr::mutate(preprocessed_data, AVAL = ifelse(AVAL == 1e-3, 0, AVAL)) %>% 
+      + 
+      scale_y_continuous(
+        trans = scales::pseudo_log_trans(base = 10, sigma = 1),
+        breaks = c(-Inf, 10^seq(from = -3, to = ceiling(log10(max(plt$data["AVAL"], na.rm = T))))) %>% 
+          filter_breaks(plot = plt, min_cm_distance = 20, axis = "y"),
+        labels = scales::trans_format("log10", scales::math_format(10^.x))
+        )
   }
-
   return(plt)
 }

inst/shiny/tabs/outputs.R

@@ -49,13 +49,13 @@ output$generalplot_usubjid <- renderUI({
 # select which variable to color the general lineplot by
 output$generalplot_colorby <- renderUI({
   # deselect choices that are no pp parameters
-  param_choices <- c("STUDYID", "PCSPEC", "ANALYTE", "USUBJID", "DOSEA", "DOSNO")
+  param_choices <- sort(c("STUDYID", "PCSPEC", "ANALYTE", "DOSEA", "DOSNO", "USUBJID"))
   pickerInput(
     "generalplot_colorby",
     "Choose the variables to color by",
     choices = param_choices,
-    selected = param_choices[1],
-    multiple = FALSE,
+    selected = param_choices[length(param_choices)],
+    multiple = TRUE,
     options = list(`actions-box` = TRUE)
   )
 })

tests/testthat/test-general_lineplot.R

@@ -0,0 +1,78 @@
+# Sample data for testing
+sample_data <- data.frame(
+  STUDYID = rep("Study1", 24),
+  USUBJID = rep(c("Subject1", "Subject2", "Subject3", "Subject4"), each = 6),
+  ANALYTE = rep("Analyte1", 24),
+  DOSNO = rep(1, 24),
+  EVID = rep(0, 24),
+  NRRLT = rep(1:6, 4),
+  ARRLT = rep(1:6, 4),
+  ARRLT = rep(1:6, 4),
+  AVAL = runif(24, 1, 100),
+  RRLTU = rep("hours", 24),
+  AVALU = rep("ng/mL", 24),
+  DOSEA = rep(35, 24)
+)
+# testthat::test_file("tests/testhat/test-general_lineplot.R")
+describe("general_lineplot functions correctly", {
+  it("returns a ggplot object", {
+    p <- general_lineplot(
+      data = sample_data,
+      selected_analytes = "Analyte1",
+      selected_usubjids = c("Subject1", "Subject2"),
+      colorby_var = "DOSNO",
+      time_scale = "By Cycle",
+      xaxis_scale = "Linear",
+      cycle = 1
+    )
+    expect_s3_class(p, "ggplot")
+  })
+
+  it("handles empty data gracefully", {
+    empty_data <- sample_data[0, ]
+    p <- general_lineplot(
+      data = empty_data,
+      selected_analytes = "Analyte1",
+      selected_usubjids = c("Subject1", "Subject2"),
+      colorby_var = "DOSNO",
+      time_scale = "By Cycle",
+      xaxis_scale = "Linear",
+      cycle = 1
+    )
+    expect_s3_class(p, "ggplot")
+    expect_true(length(p$layers) == 0)
+  })
+
+  it("handles missing columns gracefully", {
+    incomplete_data <- sample_data %>% select(-AVAL)
+    expect_error(
+      general_lineplot(
+        data = incomplete_data,
+        selected_analytes = "Analyte1",
+        selected_usubjids = c("Subject1", "Subject2"),
+        colorby_var = "DOSNO",
+        time_scale = "By Cycle",
+        xaxis_scale = "Linear",
+        cycle = 1
+      ),
+      "object 'AVAL' not found"
+    )
+  })
+
+  it("can plot with logarithmic scale", {
+    p <- general_lineplot(
+      data = sample_data,
+      selected_analytes = "Analyte1",
+      selected_usubjids = c("Subject1", "Subject2"),
+      colorby_var = "DOSNO",
+      time_scale = "By Cycle",
+      xaxis_scale = "Log",
+      cycle = 1
+    )
+    expect_s3_class(p, "ggplot")
+
+    # Check for logarithmic scale in the plot
+    is_log_scale <- grepl("log", p$scales$scales[[1]]$trans$name)
+    expect_true(is_log_scale)
+  })
+})