303 obs map to shape (Open-Systems-Pharmacology#351)

* Fixes Open-Systems-Pharmacology#303 observed data map to shape * Fixes Open-Systems-Pharmacology#346 remove dynamic code * Update documentation with latest roxygen * format with styler Co-authored-by: Indrajeet Patil <patilindrajeet.science@gmail.com>
Yuri05 · Jan 27, 2023 · 5b6ad0c · 5b6ad0c
1 parent a52f0a3
commit 5b6ad0c
Show file tree

Hide file tree

Showing 60 changed files with 1,336 additions and 768 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -100,5 +100,6 @@ Collate:
     'utilities-label.R'
     'utilities-legend.R'
     'utilities-mapping.R'
+    'utilities-molecule-plots.R'
     'utilities-theme.R'
     'utils.R'
diff --git a/R/aaa-utilities.R b/R/aaa-utilities.R
@@ -42,188 +42,61 @@
   return(parse(text = paste0(objectName, " <- ", value)))
 }
 
-#' @title .parseCheckPlotInputs
-#' @description Create an expression that checks usual plot inputs
-#' @param plotType Type of plot (e.g. "PKRatio" for plotPKRatio)
-#' @return An expression to `eval()`
+#' @title .setDataMapping
+#' @description Set `DataMapping` object internally using `tlf` default if `dataMapping` is not provided
+#' @param dataMapping A `DataMappingClass` object
+#' @param DataMappingClass Required class for `dataMapping`
+#' @param data A data.frame potentially used for smart mapping
+#' @return A `DataMapping` object
 #' @keywords internal
-.parseCheckPlotInputs <- function(plotType) {
-  c(
-    expression(validateIsOfType(data, "data.frame")),
-    expression(validateIsOfType(plotObject, "ggplot", nullAllowed = TRUE)),
-    parse(text = paste0('if(nrow(data)==0){warning(messages$errorNrowData("', plotType, ' plot")); return(plotObject)}')),
-    parse(text = paste0("dataMapping <- dataMapping %||% ", plotType, "DataMapping$new(data=data)")),
-    parse(text = paste0(
-      "plotConfiguration <- plotConfiguration %||% ",
-      plotType, "PlotConfiguration$new(data=data, metaData=metaData, dataMapping=dataMapping)"
-    )),
-    parse(text = paste0('validateIsOfType(dataMapping, "', plotType, 'DataMapping")')),
-    parse(text = paste0('validateIsOfType(plotConfiguration, "', plotType, 'PlotConfiguration")'))
-  )
+.setDataMapping <- function(dataMapping, DataMappingClass, data = NULL) {
+  dataMapping <- dataMapping %||% DataMappingClass$new(data = data)
+  validateIsOfType(dataMapping, DataMappingClass)
+  return(dataMapping)
 }
 
-#' @title .parseUpdateAxes
-#' @description Create an expression that updates the plot axes
-#' @return An expression to `eval()`
+#' @title .setPlotConfiguration
+#' @description Set `PlotConfiguration` object internally using `tlf` default if `plotConfiguration` is not provided
+#' @param plotConfiguration A `PlotConfigurationClass` object
+#' @param PlotConfigurationClass Required class for `plotConfiguration`
+#' @param data A data.frame potentially used for smart plot configuration
+#' @param metaData A list of meta data potentially used for smart plot configuration
+#' @param dataMapping A `DataMapping` object potentially used for smart plot configuration
+#' @return A `PlotConfiguration` object
 #' @keywords internal
-.parseUpdateAxes <- function() {
-  # Try is used to prevent crashes in the final plot due to ggplot2 peculiarities regarding scale functions
-  c(
-    expression(try(suppressMessages(plotObject <- setXAxis(plotObject)))),
-    expression(try(suppressMessages(plotObject <- setYAxis(plotObject))))
-  )
+.setPlotConfiguration <- function(plotConfiguration,
+                                  PlotConfigurationClass,
+                                  data = NULL,
+                                  metaData = NULL,
+                                  dataMapping = NULL) {
+  plotConfiguration <- plotConfiguration %||%
+    PlotConfigurationClass$new(data = data, metaData = metaData, dataMapping = dataMapping)
+  validateIsOfType(plotConfiguration, PlotConfigurationClass)
+  return(plotConfiguration)
 }
 
-#' @title .parseUpdateAestheticProperty
-#' @description Create an expression that updates the aesthetic properties based on
-#' the information of `PlotConfiguration`
-#' @param aestheticProperty Name of aesthetic property as defined in `AestheticProperties`
-#' @param plotConfigurationProperty Name of PlotConfiguration property as defined in `AestheticProperties`
-#' @return An expression to `eval()`
+#' @title .setPlotObject
+#' @description Set a `ggplot` object associated with its `plotConfiguration`
+#' @param plotObject A `ggplot` object
+#' @param plotConfiguration A `PlotConfiguration` object
+#' @return A `ggplot` object
 #' @keywords internal
-.parseUpdateAestheticProperty <- function(aestheticProperty, plotConfigurationProperty) {
-  c(
-    parse(text = paste0(aestheticProperty, 'Variable <- gsub("`", "", mapLabels$', aestheticProperty, ")")),
-    parse(text = paste0(aestheticProperty, "Length <- length(unique(mapData[, ", aestheticProperty, "Variable]))")),
-    # Update the property using ggplot `scale` functions
-    parse(text = paste0(
-      "suppressMessages(plotObject <- plotObject + ggplot2::scale_", aestheticProperty, "_manual(",
-      "values=.getAestheticValues(n=", aestheticProperty, "Length,",
-      "selectionKey=plotConfiguration$", plotConfigurationProperty, "$", 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')}"))
-  )
+.setPlotObject <- function(plotObject,
+                           plotConfiguration = NULL) {
+  plotObject <- plotObject %||% initializePlot(plotConfiguration)
+  validateIsOfType(plotObject, "ggplot")
+  validateIsIncluded("plotConfiguration", names(plotObject))
+  return(plotObject)
 }
 
-#' @title .parseAddScatterLayer
-#' @description Create an expression that adds scatter plot layer
-#' @return An expression to `eval()`
-#' @keywords internal
-.parseAddScatterLayer <- function() {
-  expression({
-    plotObject <- plotObject +
-      ggplot2::geom_point(
-        data = mapData,
-        mapping = ggplot2::aes_string(
-          x = mapLabels$x,
-          y = mapLabels$y,
-          color = mapLabels$color,
-          shape = mapLabels$shape
-        ),
-        size = .getAestheticValues(n = 1, selectionKey = plotConfiguration$points$size, position = 0, aesthetic = "size"),
-        alpha = .getAestheticValues(n = 1, selectionKey = plotConfiguration$points$alpha, aesthetic = "alpha"),
-        na.rm = TRUE,
-        show.legend = TRUE
-      )
-  })
-}
 
-#' @title .parseAddLineLayer
-#' @description Create an expression that adds scatter plot layer
-#' TODO: create a vignette explaining how argument `lines` in dataMapping is related to this
-#' @param type one of "horizontal", "vertical" or "diagonal"
-#' Note that for "diagonal", geom_abline is used.
-#' `value` of intercept is taken as is for linear scale but corresponds to the log of `value` for log scale.
-#'  For instance, intercept = c(-1, 0, 1) with log scale actually means that the line will go through c(0.1, 1, 10)
-#'  because c(-1, 0, 1) = log10(c(0.1, 1, 10)).
-#' @param value value of xintercept or yintercept
-#' @param position line position for aesthetic properties
-#' @return An expression to `eval()`
-#' @keywords internal
-.parseAddLineLayer <- function(type, value, position) {
-  parse(text = paste0(
-    "plotObject <- plotObject + ",
-    switch(type,
-      "horizontal" = paste0("ggplot2::geom_hline(yintercept = ", value, ","),
-      "vertical" = paste0("ggplot2::geom_vline(xintercept = ", value, ","),
-      "diagonal" = paste0("ggplot2::geom_abline(slope=1, intercept = ", value, ","),
-      "ddiHorizontal" = paste0("ggplot2::geom_abline(slope=0, intercept = ", value, ",")
-    ),
-    "color=.getAestheticValues(n=1,selectionKey=plotConfiguration$lines$color,position=", position, ',aesthetic="color"),',
-    "linetype=.getAestheticValues(n=1,selectionKey=plotConfiguration$lines$linetype,position=", position, ',aesthetic="linetype"),',
-    "alpha=.getAestheticValues(n=1,selectionKey=plotConfiguration$lines$alpha,position=", position, ',aesthetic="alpha"),',
-    "size=.getAestheticValues(n=1,selectionKey=plotConfiguration$lines$size,position=", position, ', aesthetic="size"))'
-  ))
-}
-
-#' @title .parseAddUncertaintyLayer
-#' @description Create an expression that adds errorbars
-#' `mapLabels` needs to be obtained from `DataMapping` objects
-#' @return An expression to `eval()`
+#' @title .updateAxes
+#' @description Updates the plot axes
+#' @return A `ggplot` object
 #' @keywords internal
-.parseAddUncertaintyLayer <- function(direction = "vertical") {
-  parse(text = paste0(
-    "plotObject <- plotObject +",
-    # Plot error bars from xmin/ymin to x/y
-    # If lower value is negative and plot is log scaled,
-    # Upper bar will still be plotted
-    "ggplot2::geom_linerange(",
-    "data = mapData,",
-    "mapping = aes_string(",
-    switch(direction,
-      "vertical" = "x = mapLabels$x, ymin = mapLabels$ymin, ymax = mapLabels$y,",
-      "horizontal" = "y = mapLabels$y, xmin = mapLabels$xmin, xmax = mapLabels$x,"
-    ),
-    "color = mapLabels$color,",
-    "group = mapLabels$color",
-    "),",
-    'size = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$size, position = 0, aesthetic = "size"),',
-    'linetype = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$linetype, aesthetic = "linetype"),',
-    'alpha = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$alpha, aesthetic = "alpha"),',
-    "na.rm = TRUE,",
-    "show.legend = FALSE",
-    ") + ",
-    "ggplot2::geom_linerange(",
-    "data = mapData,",
-    "mapping = aes_string(",
-    switch(direction,
-      "vertical" = "x = mapLabels$x, ymin = mapLabels$y, ymax = mapLabels$ymax,",
-      "horizontal" = "y = mapLabels$y, xmin = mapLabels$x, xmax = mapLabels$xmax,"
-    ),
-    "color = mapLabels$color,",
-    "group = mapLabels$color",
-    "),",
-    'size = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$size, position = 0, aesthetic = "size"),',
-    'linetype = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$linetype, aesthetic = "linetype"),',
-    'alpha = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$alpha, aesthetic = "alpha"),',
-    "na.rm = TRUE,",
-    "show.legend = FALSE",
-    ") + ",
-    # Add lower cap to error bar
-    "ggplot2::geom_point(",
-    "data = mapData,",
-    "mapping = aes_string(",
-    switch(direction,
-           "vertical" = "x = mapLabels$x, y = mapLabels$ymin,",
-           "horizontal" = "y = mapLabels$y, x = mapLabels$xmin,"
-    ),
-    "color = mapLabels$color,",
-    "group = mapLabels$color",
-    "),",
-    'size = tlfEnv$defaultErrorbarCapSize,',
-    'shape = ', switch(direction, "vertical" = '"_"', "horizontal" = '"|"'), ',',
-    'alpha = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$alpha, aesthetic = "alpha"),',
-    "na.rm = TRUE,",
-    "show.legend = FALSE",
-    ") + ",
-    # Add upper cap to error bar
-    "ggplot2::geom_point(",
-    "data = mapData,",
-    "mapping = aes_string(",
-    switch(direction,
-           "vertical" = "x = mapLabels$x, y = mapLabels$ymax,",
-           "horizontal" = "y = mapLabels$y, x = mapLabels$xmax,"
-    ),
-    "color = mapLabels$color,",
-    "group = mapLabels$color",
-    "),",
-    'size = tlfEnv$defaultErrorbarCapSize,',
-    'shape = ', switch(direction, "vertical" = '"_"', "horizontal" = '"|"'), ',', 
-    'alpha = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$alpha, aesthetic = "alpha"),',
-    "na.rm = TRUE,",
-    "show.legend = FALSE",
-    ")"
-  ))
+.updateAxes <- function(plotObject) {
+  # Try is used to prevent crashes in the final plot due to ggplot2 peculiarities regarding scale functions
+  try(suppressMessages(plotObject <- setXAxis(plotObject)))
+  try(suppressMessages(plotObject <- setYAxis(plotObject)))
+  return(plotObject)
 }
diff --git a/R/atom-plots.R b/R/atom-plots.R
@@ -184,7 +184,7 @@ addScatter <- function(data = NULL,
     newLabels = newLabels,
     aestheticSelections = plotConfiguration$points
   ))
-  eval(.parseUpdateAxes())
+  plotObject <- .updateAxes(plotObject)
   return(plotObject)
 }
 
@@ -362,7 +362,7 @@ addLine <- function(data = NULL,
     newLabels = newLabels,
     aestheticSelections = plotConfiguration$lines
   ))
-  eval(.parseUpdateAxes())
+  plotObject <- .updateAxes(plotObject)
   return(plotObject)
 }
 
@@ -495,7 +495,7 @@ addRibbon <- function(data = NULL,
     newLabels = newLabels,
     aestheticSelections = plotConfiguration$ribbons
   ))
-  eval(.parseUpdateAxes())
+  plotObject <- .updateAxes(plotObject)
   return(plotObject)
 }
 
@@ -566,7 +566,7 @@ addErrorbar <- function(data = NULL,
                         plotObject = NULL) {
   validateIsOfType(dataMapping, c("RangeDataMapping", "ObservedDataMapping"), nullAllowed = TRUE)
   validateIsOfType(plotConfiguration, PlotConfiguration, nullAllowed = TRUE)
-  
+
   # If data is not input, creates data and its mapping from x, ymin and ymax input
   if (isEmpty(data)) {
     data <- as.data.frame(cbind(x = x, ymin = ymin %||% 0, ymax = ymax %||% 0))
@@ -600,31 +600,31 @@ addErrorbar <- function(data = NULL,
   }
   mapData$legendLabels <- caption %||% mapData$legendLabels
   legendLength <- length(unique(mapData$legendLabels))
-  
+
   eval(.parseVariableToObject("plotObject$plotConfiguration$errorbars", c("color", "size", "linetype"), keepIfNull = TRUE))
-  
+
   plotObject <- plotObject +
     ggplot2::geom_linerange(
       data = mapData,
       mapping = aes_string(
-        x = mapLabels$x, 
-        ymin = mapLabels$ymin, 
+        x = mapLabels$x,
+        ymin = mapLabels$ymin,
         ymax = mapLabels$ymax,
         color = mapLabels$color,
         group = mapLabels$color
-        ),
+      ),
       size = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$size, position = 0, aesthetic = "size"),
       linetype = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$linetype, aesthetic = "linetype"),
       alpha = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$alpha, aesthetic = "alpha"),
       color = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$color, aesthetic = "color"),
       na.rm = TRUE,
       show.legend = FALSE
-      ) + 
+    ) +
     ggplot2::geom_point(
       data = mapData,
       mapping = aes_string(
-        x = mapLabels$x, 
-        y = mapLabels$ymin, 
+        x = mapLabels$x,
+        y = mapLabels$ymin,
         color = mapLabels$color,
         group = mapLabels$color
       ),
@@ -634,11 +634,11 @@ addErrorbar <- function(data = NULL,
       color = .getAestheticValues(n = 1, selectionKey = plotConfiguration$errorbars$color, aesthetic = "color"),
       na.rm = TRUE,
       show.legend = FALSE
-    ) + 
+    ) +
     ggplot2::geom_point(
       data = mapData,
       mapping = aes_string(
-        x = mapLabels$x, 
+        x = mapLabels$x,
         y = mapLabels$ymax,
         color = mapLabels$color,
         group = mapLabels$color
@@ -650,9 +650,9 @@ addErrorbar <- function(data = NULL,
       na.rm = TRUE,
       show.legend = FALSE
     )
-  
+
   # Try is used to prevent crashes in the final plot due to ggplot2 peculiarities regarding scale functions
-  eval(.parseUpdateAxes())
+  plotObject <- .updateAxes(plotObject)
   return(plotObject)
 }
 

diff --git a/R/datamapping-range.R b/R/datamapping-range.R
@@ -67,26 +67,34 @@ RangeDataMapping <- R6::R6Class(
 
       # All possible Groupings are listed in the enum LegendTypes
       for (groupType in LegendTypes) {
-        if (!is.null(self$groupMapping[[groupType]]$group)) {
-          grouping <- self$groupMapping[[groupType]]
+        if (isEmpty(self$groupMapping[[groupType]]$group)) {
+          next
+        }
+        grouping <- self$groupMapping[[groupType]]
+
+        groupVariables <- grouping$group
+        if (isOfType(groupVariables, "data.frame")) {
+          # Last group variable is the label in group data.frames
+          # and need to be removed from the check
+          groupVariables <- names(groupVariables)
+          groupVariables <- utils::head(groupVariables, -1)
+        }
+        .validateMapping(groupVariables, data)
+        # Enforce grouping variables to be factors
+        self$data[, grouping$label] <- as.factor(grouping$getCaptions(data, metaData))
+
+        # Dummy variable for default aesthetics that will be used to define legend labels
+        legendLabels <- self$data$legendLabels %||% grouping$getCaptions(data, metaData)
 
-          groupVariables <- grouping$group
-          if (isOfType(groupVariables, "data.frame")) {
-            # Last group variable is the label in group data.frames
-            # and need to be removed from the check
-            groupVariables <- names(groupVariables)
-            groupVariables <- utils::head(groupVariables, -1)
-          }
-          .validateMapping(groupVariables, data)
-          self$data[, grouping$label] <- grouping$getCaptions(data, metaData)
-          # Dummy variable for default aesthetics
-          # Will be used to define legend labels
-          self$data$legendLabels <- ifNotNull(
-            self$data$legendLabels,
-            paste(self$data$legendLabels, grouping$getCaptions(data, metaData), sep = "-"),
-            grouping$getCaptions(data, metaData)
-          )
+        # Prevent duplication of legend if groupings are the same
+        if (isTRUE(all.equal(legendLabels, grouping$getCaptions(data, metaData)))) {
+          self$data$legendLabels <- legendLabels
+          next
         }
+        self$data$legendLabels <- as.factor(paste(as.character(self$data$legendLabels),
+          as.character(grouping$getCaptions(data, metaData)),
+          sep = "-"
+        ))
       }
 
       if (is.null(self$data$legendLabels)) {