diff --git a/R/boxly.R b/R/boxly.R index 8d03098..bd49b5d 100644 --- a/R/boxly.R +++ b/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)) { diff --git a/R/prepare_boxly.R b/R/prepare_boxly.R index c1b208a..1cf3e53 100644 --- a/R/prepare_boxly.R +++ b/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 ) diff --git a/man/boxly.Rd b/man/boxly.Rd index 91071f7..56cd912 100644 --- a/man/boxly.Rd +++ b/man/boxly.Rd @@ -8,7 +8,7 @@ boxly( 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", @@ -23,7 +23,8 @@ boxly( \item{hover_summary_var}{A character vector of statistics to be displayed on hover label of box.} -\item{hover_outlier_label}{A character vector of hover label for outlier.} +\item{hover_outlier_label}{A character vector of hover label for outlier. +A label from an input data is used if \code{NA} for a variable is specified.} \item{x_label}{x-axis label.} diff --git a/man/prepare_boxly.Rd b/man/prepare_boxly.Rd index 3ad98d6..d917fe3 100644 --- a/man/prepare_boxly.Rd +++ b/man/prepare_boxly.Rd @@ -4,7 +4,13 @@ \alias{prepare_boxly} \title{Prepare data for interactive box plot} \usage{ -prepare_boxly(meta, population = NULL, observation = NULL, analysis = NULL) +prepare_boxly( + meta, + population = NULL, + observation = NULL, + analysis = NULL, + hover_var_outlier = c("USUBJID", metalite::collect_adam_mapping(meta, analysis)$y) +) } \arguments{ \item{meta}{A metadata object created by metalite.} @@ -17,6 +23,8 @@ The term name is used as key to link information.} \item{analysis}{A character value of analysis term name. The term name is used as key to link information.} + +\item{hover_var_outlier}{A character vector of hover variables for outlier.} } \value{ Metadata list with plotting dataset. diff --git a/tests/testthat/test-independant-testing-prepare_boxly.R b/tests/testthat/test-independant-testing-prepare_boxly.R index 4a2dd96..79485a2 100644 --- a/tests/testthat/test-independant-testing-prepare_boxly.R +++ b/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))