Add a new argument to specify hover variables for outlier in `prepare…

…_boxly` and `boxly()`.

R/boxly.R

@@ -22,6 +22,7 @@
 #' @param color Color for box plot.
 #' @param hover_summary_var A character vector of statistics to be displayed
 #'   on hover label of box.
+#' @param hover_outlier_display A character vector of hover variable for outlier.
 #' @param hover_outlier_label A character vector of hover label for outlier.
 #' @param x_label x-axis label.
 #' @param y_label y-axis label.
@@ -54,13 +55,15 @@
 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_display = c("USUBJID", outdata$y_var),
+                  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 +97,43 @@ 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_outlier_display) == length(hover_outlier_label)) {
+      message("hover_outlier_display should have the same length as hover_outlier_label.")
+    }
+  }
+
+  # 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_outlier_display)) {
+        var <- hover_outlier_display[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 variable for outlier.
 #'
 #' @return Metadata list with plotting dataset.
 #'
@@ -46,7 +47,9 @@
 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
@@ -89,7 +92,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,6 +173,30 @@ 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,