7 enable user to customize hover label variables for outliers

R/boxly.R

@@ -23,6 +23,7 @@
 #' @param hover_summary_var A character vector of statistics to be displayed
 #'   on hover label of box.
 #' @param hover_outlier_label A character vector of hover label for outlier.
+#'   A label from an input data is used if `NA` for a variable is specified.
 #' @param x_label x-axis label.
 #' @param y_label y-axis label.
 #' @param heading_select_list Select list menu label.
@@ -54,13 +55,14 @@
 boxly <- function(outdata,
                   color = NULL,
                   hover_summary_var = c("n", "min", "q1", "median", "mean", "q3", "max"),
-                  hover_outlier_label = c("Participant Id", "Parameter value"),
+                  hover_outlier_label = c("Participant ID", "Parameter value"),
                   x_label = "Visit",
                   y_label = "Change",
                   heading_select_list = "Lab parameter",
                   heading_summary_table = "Number of Participants") {
   x_var <- outdata$x_var
   y_var <- outdata$y_var
+  id_var <- outdata$id_var
   group_var <- outdata$group_var
   param_var <- outdata$param_var
   hover_var_outlier <- outdata$hover_var_outlier
@@ -94,13 +96,44 @@ boxly <- function(outdata,
   }
 
   # paste multiple hover_outlier_labels
-  tbl$text <- ifelse(!is.na(tbl$outlier),
-    paste0(
-      hover_outlier_label[1], ": ", tbl[["USUBJID"]],
-      "\n", hover_outlier_label[2], ": ", tbl[["outlier"]]
-    ),
-    NA
-  )
+  # Check length of variables and labels
+  if (length(hover_outlier_label) > 0) {
+    if (!length(hover_var_outlier) == length(hover_outlier_label)) {
+      warning("The Length of hover labels should be same as that of hover variables.")
+    }
+  }
+
+  # Set labels
+  label <- vapply(tbl, function(x) {
+    if (is.null(attr(x, "label"))) {
+      return(NA_character_)
+    } else {
+      attr(x, "label")
+    }
+  }, FUN.VALUE = character(1))
+  listing_label <- ifelse(is.na(label), names(tbl), label)
+
+  tbl$text <- apply(tbl, 1, function(x) {
+    text <- NULL
+    var <- NULL
+    if (!is.na(x[["outlier"]])) {
+      for (i in seq(hover_var_outlier)) {
+        var <- hover_var_outlier[i]
+        if (!is.null(hover_outlier_label)) {
+          label <- ifelse(!is.na(hover_outlier_label[i]), hover_outlier_label[i], listing_label[var])
+        } else {
+          label <- listing_label[var]
+        }
+        text <- ifelse(i == 1,
+          paste0(text, label, ": ", x[[var]]),
+          paste0(text, "\n", label, ": ", x[[var]])
+        )
+      }
+    } else {
+      text <- NA
+    }
+    return(text)
+  })
 
   # implement color
   if (is.null(color)) {

R/prepare_boxly.R

@@ -25,6 +25,7 @@
 #'   The term name is used as key to link information.
 #' @param analysis A character value of analysis term name.
 #'   The term name is used as key to link information.
+#' @param hover_var_outlier A character vector of hover variables for outlier.
 #'
 #' @return Metadata list with plotting dataset.
 #'
@@ -46,7 +47,8 @@
 prepare_boxly <- function(meta,
                           population = NULL,
                           observation = NULL,
-                          analysis = NULL) {
+                          analysis = NULL,
+                          hover_var_outlier = c("USUBJID", metalite::collect_adam_mapping(meta, analysis)$y)) {
   if (is.null(population)) {
     if (length(meta$population) == 1) {
       population <- meta$population[[1]]$name
@@ -78,7 +80,6 @@ prepare_boxly <- function(meta,
   pop_var <- metalite::collect_adam_mapping(meta, population)$var
   y <- metalite::collect_adam_mapping(meta, analysis)$y
   x <- metalite::collect_adam_mapping(meta, analysis)$x
-  # hover_outlier <- collect_adam_mapping(meta, analysis)$hover_outlier
 
   # Obtain Data
   pop <- metalite::collect_population_record(meta, population, var = pop_var)
@@ -89,7 +90,7 @@ prepare_boxly <- function(meta,
       function(s) {
         metalite::collect_observation_record(meta, population, observation,
           parameter = s,
-          var = unique(c(obs_var, y, x))
+          var = unique(c(obs_var, y, x, hover_var_outlier))
         )
       }
     )
@@ -170,10 +171,34 @@ prepare_boxly <- function(meta,
   plotds <- do.call(rbind, plotds)
   rownames(plotds) <- NULL
 
+  # Get all labels from the un-subset data
+  label <- vapply(obs, function(x) {
+    if (is.null(attr(x, "label"))) {
+      return(NA_character_)
+    } else {
+      attr(x, "label")
+    }
+  }, FUN.VALUE = character(1))
+  listing_label <- ifelse(is.na(label), names(obs), label)
+
+  name <- names(plotds)
+  var <- names(plotds)
+  label <- listing_label[match(names(plotds), names(listing_label))]
+  diff <- setdiff(name, names(plotds))
+  if (length(diff) > 0) {
+    var <- c(var, diff)
+    label <- c(label, diff)
+  }
+
+  # Assign label
+  for (i in seq(name)) {
+    attr(plotds[[i]], "label") <- label[names(plotds[i]) == var]
+  }
+
   # Return value
   metalite::outdata(meta, population, observation, parameter,
     x_var = x, y_var = y, group_var = obs_group,
-    param_var = obs_var,
+    param_var = obs_var, hover_var_outlier = hover_var_outlier,
     n = n_tbl, order = NULL, group = NULL, reference_group = NULL,
     plotds = plotds
   )

tests/testthat/test-independant-testing-prepare_boxly.R

@@ -34,10 +34,11 @@ test_that("Its class is 'outdata'", {
   expect_equal(output$y_var, "CHG")
   expect_equal(output$group_var, "TRTA")
   expect_equal(output$param_var, "PARAM")
+  expect_equal(output$hover_var_outlier, c("USUBJID", "CHG"))
   expect_equal(output$parameter, meta$plan$parameter)
   expect_equal(output$order, NULL)
   expect_equal(output$group, NULL)
-  expect_equal(names(output), c("meta", "population", "observation", "parameter", "n", "order", "group", "reference_group", "x_var", "y_var", "group_var", "param_var", "plotds"))
+  expect_equal(names(output), c("meta", "population", "observation", "parameter", "n", "order", "group", "reference_group", "x_var", "y_var", "group_var", "param_var", "hover_var_outlier", "plotds"))
   expect_equal(names(output$meta), c("data_population", "data_observation", "plan", "observation", "population", "parameter", "analysis"))
   expect_equal(nrow(output$meta$data_population), nrow(meta$data_population))
   expect_equal(nrow(output$meta$data_observation), nrow(meta$data_observation))