diff --git a/NAMESPACE b/NAMESPACE index 34b8a6e2..6d27aabb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -146,6 +146,7 @@ export(setXGrid) export(setYAxis) export(setYGrid) export(tlfStatFunctions) +export(updateTimeProfileLegend) export(useDarkTheme) export(useExcelTheme) export(useHighChartTheme) diff --git a/R/aaa-utilities.R b/R/aaa-utilities.R index b05fce92..6e15cdff 100644 --- a/R/aaa-utilities.R +++ b/R/aaa-utilities.R @@ -87,10 +87,10 @@ parseUpdateAestheticProperty <- function(aestheticProperty, plotConfigurationPro parse(text = paste0(aestheticProperty, "Length <- length(unique(mapData[, ", aestheticProperty, "Variable]))")), # Update the property using ggplot `scale` functions parse(text = paste0( - "plotObject <- plotObject + ggplot2::scale_", aestheticProperty, "_manual(", + "suppressMessages(plotObject <- plotObject + ggplot2::scale_", aestheticProperty, "_manual(", "values=getAestheticValues(n=", aestheticProperty, "Length,", "selectionKey=plotConfiguration$", plotConfigurationProperty, "$", aestheticProperty, - ',aesthetic = "', aestheticProperty, '"))' + ',aesthetic = "', aestheticProperty, '")))' )), # remove the legend of aesthetic if default unmapped aesthetic parse(text = paste0("if(isIncluded(", aestheticProperty, 'Variable, "legendLabels")){plotObject <- plotObject + ggplot2::guides(', aestheticProperty, " = 'none')}")) diff --git a/R/datamapping-range.R b/R/datamapping-range.R index 95661108..d7d0e828 100644 --- a/R/datamapping-range.R +++ b/R/datamapping-range.R @@ -21,6 +21,7 @@ RangeDataMapping <- R6::R6Class( #' @param linetype R6 class `Grouping` object or its input #' @param shape R6 class `Grouping` object or its input #' @param size R6 class `Grouping` object or its input + #' @param group R6 class `Grouping` object or its input #' @param data data.frame to map used by `smartMapping` #' @return A new `RangeDataMapping` object initialize = function(x = NULL, @@ -32,6 +33,7 @@ RangeDataMapping <- R6::R6Class( linetype = NULL, shape = NULL, size = NULL, + group = NULL, data = NULL) { # smartMapping is available in utilities-mapping.R @@ -39,7 +41,7 @@ RangeDataMapping <- R6::R6Class( super$initialize(x %||% smartMap$x, y = NULL, groupMapping = groupMapping, color = color, fill = fill, - linetype = linetype, shape = shape, size = size + linetype = linetype, shape = shape, size = size, group = group ) self$ymin <- ymin %||% smartMap$ymin diff --git a/R/datamapping-xygroup.R b/R/datamapping-xygroup.R index 5a8359cc..ec01a449 100644 --- a/R/datamapping-xygroup.R +++ b/R/datamapping-xygroup.R @@ -18,6 +18,7 @@ XYGDataMapping <- R6::R6Class( #' @param linetype R6 class `Grouping` object or its input #' @param shape R6 class `Grouping` object or its input #' @param size R6 class `Grouping` object or its input + #' @param group R6 class `Grouping` object or its input #' @param data data.frame to map used by `smartMapping` #' @return A new `XYGDataMapping` object initialize = function(x = NULL, @@ -28,6 +29,7 @@ XYGDataMapping <- R6::R6Class( linetype = NULL, shape = NULL, size = NULL, + group = NULL, data = NULL) { # smartMapping is available in utilities-mapping.R @@ -39,15 +41,16 @@ XYGDataMapping <- R6::R6Class( "fill" = fill, "linetype" = linetype, "shape" = shape, - "size" = size + "size" = size, + "group" = group )) # To simplify the process workflow, groupMapping inputs color, fill... can be used directly instead of groupMapping self$groupMapping <- groupMapping %||% GroupMapping$new( - color %||% smartMap$color, - fill %||% smartMap$fill, - linetype %||% smartMap$linetype, - shape %||% smartMap$shape, - size %||% smartMap$size + color %||% group %||% smartMap$color, + fill %||% group %||% smartMap$fill, + linetype %||% group %||% smartMap$linetype, + shape %||% group %||% smartMap$shape, + size %||% group %||% smartMap$size ) }, diff --git a/R/observed-data-mapping.R b/R/observed-data-mapping.R index b5cf7345..049b6758 100644 --- a/R/observed-data-mapping.R +++ b/R/observed-data-mapping.R @@ -6,8 +6,6 @@ ObservedDataMapping <- R6::R6Class( "ObservedDataMapping", inherit = XYGDataMapping, public = list( - #' @field lloq mapping lower limit of quantitation variable - lloq = NULL, #' @field error mapping error bars around scatter points error = NULL, #' @field mdv mapping missing dependent variable @@ -21,8 +19,9 @@ ObservedDataMapping <- R6::R6Class( #' @param x Name of x variable to map #' @param y Name of y variable to map #' @param group R6 class `Grouping` object or its input + #' @param color R6 class `Grouping` object or its input + #' @param shape R6 class `Grouping` object or its input #' @param data data.frame to map used by `smartMapping` - #' @param lloq mapping lower limit of quantitation variable #' @param uncertainty mapping error bars around scatter points. #' Deprecated parameter replaced by `error`. #' @param error mapping error bars around scatter points @@ -36,19 +35,18 @@ ObservedDataMapping <- R6::R6Class( error = NULL, ymin = NULL, ymax = NULL, - lloq = NULL, mdv = NULL, + color = NULL, + shape = NULL, group = NULL, data = NULL){ - validateIsString(lloq, nullAllowed = TRUE) validateIsString(uncertainty, nullAllowed = TRUE) validateIsString(error, nullAllowed = TRUE) validateIsString(ymin, nullAllowed = TRUE) validateIsString(ymax, nullAllowed = TRUE) validateIsString(mdv, nullAllowed = TRUE) - super$initialize(x = x, y = y, color = group, data = data) + super$initialize(x = x, y = y, color = color, shape = shape, group = group, data = data) - self$lloq <- lloq # If defined, ymin and ymax are used as is # If not, error/uncertainty are used and # creates ymin and ymax as y +/- error @@ -66,19 +64,14 @@ ObservedDataMapping <- R6::R6Class( checkMapData = function(data, metaData = NULL) { validateIsOfType(data, "data.frame") validateIsIncluded(self$error, names(data), nullAllowed = TRUE) - validateIsIncluded(self$lloq, names(data), nullAllowed = TRUE) validateIsIncluded(self$mdv, names(data), nullAllowed = TRUE) # Using super method, fetches x, y and groups mapData <- super$checkMapData(data, metaData) - # Add lloq data - if (!isOfLength(self$lloq, 0)) { - mapData[, self$lloq] <- data[, self$lloq] - mapData$lloq <- data[, self$lloq] - } + # ymin and ymax for error bars # This section may change depending on how we want to include options - if (!isOfLength(self$error, 0)) { + if (!isEmpty(self$error)) { mapData[, self$error] <- data[, self$error] # Symetric error bars mapData[, self$ymax] <- data[, self$y] + data[, self$error] @@ -92,7 +85,7 @@ ObservedDataMapping <- R6::R6Class( mapData[, self$ymin] <- data[,self$ymin] } # MDV is a Nonmem notation in which values with MDV==1 are removed - if (!isOfLength(self$mdv, 0)) { + if (!isEmpty(self$mdv)) { mapData[, self$mdv] <- as.logical(data[,self$mdv]) mapData <- mapData[!mapData[, self$mdv], ] } diff --git a/R/plot-timeprofile.R b/R/plot-timeprofile.R index 4550af91..181d763b 100644 --- a/R/plot-timeprofile.R +++ b/R/plot-timeprofile.R @@ -3,37 +3,36 @@ #' Producing Time Profile plots #' #' @inheritParams addScatter -#' @param dataMapping +#' @param dataMapping #' A `TimeProfileDataMapping` object mapping `x`, `y`, `ymin`, `ymax` and aesthetic groups to their variable names of `data`. #' @param observedData A data.frame to use for plot. #' Unlike `data`, meant for simulated data, plotted as lines and ribbons; #' `observedData` is plotted as scatter points and errorbars. -#' @param observedDataMapping -#' An `ObservedDataMapping` object mapping `x`, `y`, `ymin`, `ymax`, `lloq` and aesthetic groups to their variable names of `observedData`. -#' @param plotConfiguration +#' @param observedDataMapping +#' An `ObservedDataMapping` object mapping `x`, `y`, `ymin`, `ymax` and aesthetic groups to their variable names of `observedData`. +#' @param plotConfiguration #' An optional `TimeProfilePlotConfiguration` object defining labels, grid, background and watermark. #' @return A `ggplot` object #' #' @export #' @family molecule plots -#' @examples +#' @examples #' # Produce a Time profile plot with observed and simulated data #' obsData <- data.frame(x = c(1, 2, 1, 2, 3), y = c(5, 0.2, 2, 3, 4)) #' simTime <- seq(1, 10, 0.1) #' simData <- data.frame( -#' x = simTime, -#' y = 10*exp(-simTime), -#' ymin = 8*exp(-simTime), -#' ymax = 12*exp(-simTime) +#' x = simTime, +#' y = 10 * exp(-simTime), +#' ymin = 8 * exp(-simTime), +#' ymax = 12 * exp(-simTime) #' ) -#' +#' #' plotTimeProfile( -#' data = simData, -#' observedData = obsData, -#' dataMapping = TimeProfileDataMapping$new(x = "x", y = "y", ymin = "ymin", ymax = "ymax"), -#' observedDataMapping = ObservedDataMapping$new(x = "x", y = "y") +#' data = simData, +#' observedData = obsData, +#' dataMapping = TimeProfileDataMapping$new(x = "x", y = "y", ymin = "ymin", ymax = "ymax"), +#' observedDataMapping = ObservedDataMapping$new(x = "x", y = "y") #' ) -#' plotTimeProfile <- function(data = NULL, metaData = NULL, dataMapping = NULL, @@ -43,15 +42,15 @@ plotTimeProfile <- function(data = NULL, plotObject = NULL) { validateIsOfType(data, "data.frame", nullAllowed = TRUE) validateIsOfType(observedData, "data.frame", nullAllowed = TRUE) - if (all(isOfLength(data, 0), isOfLength(observedData, 0))) { - warning("data and observed data are of length 0. Time profile layer was not added.") + if (all(isEmpty(data), isEmpty(observedData))) { + warning("'data' and 'observedData' are of length 0. Time profile layer was not added.") return(plotObject) } - if (!isOfLength(data, 0)) { + if (!isEmpty(data)) { dataMapping <- dataMapping %||% TimeProfileDataMapping$new(data = data) } - if (!isOfLength(observedData, 0)) { + if (!isEmpty(observedData)) { observedDataMapping <- observedDataMapping %||% ObservedDataMapping$new(data = data) } @@ -65,60 +64,210 @@ plotTimeProfile <- function(data = NULL, plotObject <- plotObject %||% initializePlot(plotConfiguration) # Get transformed data from mapping and convert labels into characters usable by aes_string - if (!isOfLength(data, 0)) { + if (!isEmpty(data)) { mapData <- dataMapping$checkMapData(data) - if (!any(isOfLength(dataMapping$ymin, 0), isOfLength(dataMapping$ymax, 0))) { - plotObject <- addRibbon( - data = mapData, - dataMapping = dataMapping, - plotConfiguration = plotConfiguration, - plotObject = plotObject - ) + mapLabels <- getAesStringMapping(dataMapping) + if (!any(isEmpty(dataMapping$ymin), isEmpty(dataMapping$ymax))) { + plotObject <- plotObject + + ggplot2::geom_ribbon( + data = mapData, + mapping = ggplot2::aes_string( + x = mapLabels$x, + ymin = mapLabels$ymin, + ymax = mapLabels$ymax, + fill = mapLabels$fill + ), + alpha = getAestheticValues(n = 1, selectionKey = plotConfiguration$ribbons$alpha, position = 0, aesthetic = "alpha"), + show.legend = TRUE + ) } - if (!isOfLength(dataMapping$y, 0)) { - plotObject <- addLine( - data = mapData, - dataMapping = dataMapping, - plotConfiguration = plotConfiguration, - plotObject = plotObject - ) + if (!isEmpty(dataMapping$y)) { + plotObject <- plotObject + + ggplot2::geom_path( + data = mapData, + mapping = ggplot2::aes_string( + x = mapLabels$x, + y = mapLabels$y, + color = mapLabels$color, + linetype = mapLabels$linetype + ), + size = getAestheticValues(n = 1, selectionKey = plotConfiguration$lines$size, position = 0, aesthetic = "size"), + show.legend = TRUE + ) } + eval(parseUpdateAestheticProperty(AestheticProperties$fill, "ribbons")) + eval(parseUpdateAestheticProperty(AestheticProperties$linetype, "lines")) + } + + # If no observed data, also update colors and return plotObect + if (isEmpty(observedData)) { + eval(parseUpdateAestheticProperty(AestheticProperties$color, "lines")) + plotObject <- setLegendPosition(plotObject) + plotObject <- setLegendFont(plotObject) + eval(parseUpdateAxes()) + return(plotObject) } - if (!isOfLength(observedData, 0)) { - mapObservedData <- observedDataMapping$checkMapData(observedData) - if (!all( - isOfLength(observedDataMapping$error, 0), - isOfLength(observedDataMapping$ymin, 0), - isOfLength(observedDataMapping$ymax, 0) - )){ - plotObject <- addErrorbar( + mapObservedData <- observedDataMapping$checkMapData(observedData) + observedMapLabels <- getAesStringMapping(observedDataMapping) + + if (!any(isEmpty(observedDataMapping$ymin), isEmpty(observedDataMapping$ymax))) { + # Split errorbars for negative data and log scaling + plotObject <- plotObject + + ggplot2::geom_linerange( data = mapObservedData, - dataMapping = observedDataMapping, - plotConfiguration = plotConfiguration, - plotObject = plotObject - ) - } - plotObject <- addScatter( - data = mapObservedData, - dataMapping = observedDataMapping, - plotConfiguration = plotConfiguration, - plotObject = plotObject - ) - # LLOQ - if (!isOfLength(observedDataMapping$lloq, 0)) { - mapObservedData$legendLabels <- paste(mapObservedData$legendLabels, " LLOQ") - plotObject <- addLine( + mapping = ggplot2::aes_string( + x = observedMapLabels$x, + ymin = observedMapLabels$ymin, + ymax = observedMapLabels$y, + color = observedMapLabels$color + ), + size = getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$size, position = 0, aesthetic = "size"), + linetype = getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$linetype, position = 0, aesthetic = "linetype"), + show.legend = FALSE + ) + + ggplot2::geom_linerange( data = mapObservedData, - dataMapping = XYGDataMapping$new( - x = observedDataMapping$x, - y = "lloq", - color = "legendLabels" + mapping = ggplot2::aes_string( + x = observedMapLabels$x, + ymin = observedMapLabels$y, + ymax = observedMapLabels$ymax, + color = observedMapLabels$color ), - plotConfiguration = plotConfiguration, - plotObject = plotObject + size = getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$size, position = 0, aesthetic = "size"), + linetype = getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$linetype, position = 0, aesthetic = "linetype"), + show.legend = FALSE ) + } + plotObject <- plotObject + + ggplot2::geom_point( + data = mapObservedData, + mapping = ggplot2::aes_string( + x = observedMapLabels$x, + y = observedMapLabels$y, + color = observedMapLabels$color, + shape = observedMapLabels$shape + ), + size = getAestheticValues(n = 1, selectionKey = plotConfiguration$points$size, position = 0, aesthetic = "size"), + show.legend = TRUE + ) + + # Update shapes + # Code chunk below is equivalent to commented expression with a change of variable names + # parseUpdateAestheticProperty(AestheticProperties$shape, "points") + shapeVariable <- gsub("`", "", observedMapLabels$shape) + shapeLength <- length(levels(mapObservedData[, shapeVariable])) + shapeValues <- getAestheticValues( + n = shapeLength, + selectionKey = plotConfiguration$points$shape, + aesthetic = "shape" + ) + suppressMessages(plotObject <- plotObject + ggplot2::scale_shape_manual(values = shapeValues)) + if (isIncluded(shapeVariable, "legendLabels")) { + plotObject <- plotObject + ggplot2::guides(shape = "none") + } + + # Update colors, + # Since colors can be available in both simulated and observed, the commented expressions can't apply + # parseUpdateAestheticProperty(AestheticProperties$color, "lines") + # parseUpdateAestheticProperty(AestheticProperties$color, "points") + + # No simulated data -> update only observedData + if (isEmpty(data)) { + colorVariable <- gsub("`", "", observedMapLabels$color) + colorLength <- length(levels(mapObservedData[, colorVariable])) + + suppressMessages( + plotObject <- plotObject + + ggplot2::scale_color_manual( + values = getAestheticValues( + n = colorLength, + selectionKey = plotConfiguration$points$color, + aesthetic = "color" + ) + ) + ) + if (isIncluded(colorVariable, "legendLabels")) { + plotObject <- plotObject + ggplot2::guides(color = "none") } + + plotObject <- setLegendPosition(plotObject) + plotObject <- setLegendFont(plotObject) + eval(parseUpdateAxes()) + return(plotObject) + } + + # Simulated and Observed data -> need to merge the legends + colorVariable <- gsub("`", "", mapLabels$color) + colorLength <- length(levels(mapData[, colorVariable])) + colorObservedVariable <- gsub("`", "", observedMapLabels$color) + # The final color vector needs a length of totalLength to prevent scale_color_manual to crash + colorBreaks <- c( + levels(mapData[, colorVariable]), + setdiff(levels(mapObservedData[, colorObservedVariable]), levels(mapData[, colorVariable])) + ) + totalLength <- length(colorBreaks) + + # colorValues is colors for simulated and then colors for observed + colorValues <- c( + getAestheticValues( + n = colorLength, + selectionKey = plotConfiguration$lines$color, + aesthetic = "color" + ), + getAestheticValues( + n = totalLength - colorLength, + selectionKey = plotConfiguration$points$color, + aesthetic = "color" + ) + ) + + # Export the legend captions so the user can update legend keys order + plotObject$plotConfiguration$legend$caption <- data.frame( + name = colorBreaks, + label = colorBreaks, + color = colorValues, + fill = c(getAestheticValues(n = fillLength, selectionKey = plotConfiguration$ribbons$fill, position = 0, aesthetic = "fill"), + rep(NA, totalLength-fillLength)), + linetype = c(getAestheticValues(n = linetypeLength, selectionKey = plotConfiguration$lines$linetype, position = 0, aesthetic = "linetype"), + rep("blank", totalLength-linetypeLength)), + shape = c(rep(" ", totalLength-shapeLength), shapeValues), + stringsAsFactors = FALSE + ) + + plotObject <- updateTimeProfileLegend( + plotObject = plotObject, + caption = plotObject$plotConfiguration$legend$caption + ) + + if (isIncluded(colorVariable, "legendLabels") & isIncluded(colorObservedVariable, "legendLabels")) { + plotObject <- plotObject + ggplot2::guides(color = "none") } + + plotObject <- setLegendPosition(plotObject) + plotObject <- setLegendFont(plotObject) + eval(parseUpdateAxes()) return(plotObject) } + + +#' @title updateTimeProfileLegend +#' @description Update time profile legend caption +#' @param plotObject A ggplot object +#' @param caption A data.frame as obtained from `getLegendCaption` to use for updating a plot legend. +#' @return A `ggplot` object +#' @export +updateTimeProfileLegend <- function(plotObject, caption){ + suppressMessages( + plotObject <- plotObject + + ggplot2::scale_color_manual(breaks = caption$name, labels = caption$label, values = caption$color) + + ggplot2::guides( + fill = "none", shape = "none", linetype = "none", + color = ggplot2::guide_legend( + override.aes = list(fill = caption$fill, linetype = caption$linetype, shape = caption$shape) + ) + ) + ) + plotObject$plotConfiguration$legend$caption <- caption + return(plotObject) +} \ No newline at end of file diff --git a/R/timeprofile-datamapping.R b/R/timeprofile-datamapping.R index dac998d7..f28337ba 100644 --- a/R/timeprofile-datamapping.R +++ b/R/timeprofile-datamapping.R @@ -12,6 +12,9 @@ TimeProfileDataMapping <- R6::R6Class( #' @param ymin Name of ymin variable to map #' @param ymax Name of ymax variable to map #' @param group R6 class `Grouping` object or its input + #' @param color R6 class `Grouping` object or its input + #' @param fill R6 class `Grouping` object or its input + #' @param linetype R6 class `Grouping` object or its input #' @param data data.frame to map used by `smartMapping` #' @return A new `RangeDataMapping` object initialize = function(x = NULL, @@ -19,6 +22,9 @@ TimeProfileDataMapping <- R6::R6Class( ymin = NULL, ymax = NULL, group = NULL, + color = NULL, + fill = NULL, + linetype = NULL, data = NULL) { # smartMapping is available in utilities-mapping.R @@ -27,7 +33,7 @@ TimeProfileDataMapping <- R6::R6Class( x = x %||% smartMap$x, ymin = ymin %||% smartMap$ymin, ymax = ymax %||% smartMap$ymax, - color = group + color = color, fill = fill, linetype = linetype, group = group ) # Since TimeProfileDataMapping inherits from RangeDataMapping # super$initialize introduce a self$y which is NULL @@ -43,7 +49,7 @@ TimeProfileDataMapping <- R6::R6Class( validateMapping(self$y, data, nullAllowed = TRUE) mapData <- super$checkMapData(data, metaData) # This may change depending of how we want to include options - if (!isOfLength(self$y, 0)) { + if (!isEmpty(self$y)) { mapData[, self$y] <- data[, self$y] } self$data <- mapData diff --git a/man/ObservedDataMapping.Rd b/man/ObservedDataMapping.Rd index eaaba3fc..2a42f566 100644 --- a/man/ObservedDataMapping.Rd +++ b/man/ObservedDataMapping.Rd @@ -29,8 +29,6 @@ Other DataMapping classes: \section{Public fields}{ \if{html}{\out{