Fixes #392 Create method for dual axis time profile plots

DESCRIPTION

@@ -41,6 +41,7 @@ Encoding: UTF-8
 RoxygenNote: 7.2.1
 Roxygen: list(markdown = TRUE)
 Suggests:
+    cowplot,
     knitr,
     rmarkdown,
     scales,
@@ -99,6 +100,7 @@ Collate:
     'themes.R'
     'timeprofile-datamapping.R'
     'timeprofile-helper.R'
+    'timeprofile-plotconfiguration.R'
     'tlf-env.R'
     'tornado-datamapping.R'
     'tornado-plotconfiguration.R'

NAMESPACE

@@ -110,6 +110,7 @@ export(exportPlot)
 export(exportPlotConfigurationCode)
 export(getBoxWhiskerMeasure)
 export(getDefaultCaptions)
+export(getDualAxisPlot)
 export(getGreekTickLabels)
 export(getGuestValues)
 export(getGuestValuesFromDataMapping)
@@ -179,6 +180,7 @@ export(setPlotLabels)
 export(setWatermark)
 export(setXAxis)
 export(setXGrid)
+export(setY2Axis)
 export(setYAxis)
 export(setYGrid)
 export(tlfStatFunctions)

R/observed-data-mapping.R

@@ -14,12 +14,15 @@ ObservedDataMapping <- R6::R6Class(
     ymin = NULL,
     #' @field ymax mapping error bars around scatter points
     ymax = NULL,
+    #' @field y2Axis Name of y2Axis variable to map
+    y2Axis = NULL,
 
     #' @description Create a new `ObservedDataMapping` object
     #' @param x Name of x variable to map
     #' @param y Name of y variable to map
     #' @param ymin mapping lower end of error bars around scatter points
     #' @param ymax mapping upper end of error bars around scatter points
+    #' @param y2Axis Name of y2Axis variable to map
     #' @param color R6 class `Grouping` object or its input
     #' @param shape R6 class `Grouping` object or its input
     #' @param group R6 class `Grouping` object or its input
@@ -33,9 +36,10 @@ ObservedDataMapping <- R6::R6Class(
                           y,
                           ymin = NULL,
                           ymax = NULL,
+                          y2Axis = NULL,
+                          group = NULL,
                           color = NULL,
                           shape = NULL,
-                          group = NULL,
                           error = NULL,
                           uncertainty = NULL,
                           mdv = NULL,
@@ -45,7 +49,16 @@ ObservedDataMapping <- R6::R6Class(
       validateIsString(ymin, nullAllowed = TRUE)
       validateIsString(ymax, nullAllowed = TRUE)
       validateIsString(mdv, nullAllowed = TRUE)
-      super$initialize(x = x, y = y, color = color, shape = shape, group = group, data = data)
+      # .smartMapping is available in utilities-mapping.R
+      smartMap <- .smartMapping(data)
+      super$initialize(
+        x = x %||% smartMap$x,
+        y = y %||% smartMap$y,
+        color = color, 
+        shape = shape, 
+        group = group, 
+        data = data
+        )
 
       # If defined, ymin and ymax are used as is
       # If not, error/uncertainty are used and
@@ -54,6 +67,7 @@ ObservedDataMapping <- R6::R6Class(
       self$ymin <- ymin %||% ifNotNull(self$error, "ymin")
       self$ymax <- ymax %||% ifNotNull(self$error, "ymax")
       self$mdv <- mdv
+      self$y2Axis <- y2Axis
     },
 
     #' @description Check that `data` variables include map variables
@@ -63,8 +77,9 @@ ObservedDataMapping <- R6::R6Class(
     #' Dummy variable `defaultAes` is necessary to allow further modification of plots.
     checkMapData = function(data, metaData = NULL) {
       validateIsOfType(data, "data.frame")
-      validateIsIncluded(self$error, names(data), nullAllowed = TRUE)
-      validateIsIncluded(self$mdv, names(data), nullAllowed = TRUE)
+      .validateMapping(self$error, data, nullAllowed = TRUE)
+      .validateMapping(self$mdv, data, nullAllowed = TRUE)
+      .validateMapping(self$y2Axis, data, nullAllowed = TRUE)
 
       # Using super method, fetches x, y and groups
       mapData <- super$checkMapData(data, metaData)
@@ -84,12 +99,68 @@ ObservedDataMapping <- R6::R6Class(
       if (isIncluded(self$ymin, names(data))) {
         mapData[, self$ymin] <- data[, self$ymin]
       }
+      if (!isEmpty(self$y2Axis)) {
+        mapData[, self$y2Axis] <- as.logical(data[, self$y2Axis])
+      }
       # MDV is a Nonmem notation in which values with MDV==1 are removed
       if (!isEmpty(self$mdv)) {
         mapData[, self$mdv] <- as.logical(data[, self$mdv])
         mapData <- mapData[!mapData[, self$mdv], ]
       }
       return(mapData)
+    },
+
+    #' @description Assess if `data` require a dual axis plot
+    #' @param data data.frame to check
+    #' @return A logical
+    requireDualAxis = function(data) {
+      .validateMapping(self$y2Axis, data, nullAllowed = TRUE)
+      if(isEmpty(self$y2Axis)){
+        return(FALSE)
+      }
+      return(any(as.logical(data[, self$y2Axis]), na.rm = TRUE))
+    },
+
+    #' @description Render NA values for all right axis data
+    #' @param data A data.frame
+    #' @return A data.frame to be plotted in left axis
+    getLeftAxis = function(data) {
+      if(!self$requireDualAxis(data)){
+        return(data)
+      }
+      # Ensure NAs in that data don't mess up the selection
+      selectedRows <- as.logical(data[, self$y2Axis]) %in% TRUE
+      if (isIncluded(self$ymax, names(data))) {
+        data[selectedRows, self$ymax] <- NA
+      }
+      if (isIncluded(self$ymin, names(data))) {
+        data[selectedRows, self$ymin] <- NA
+      }
+      if (isIncluded(self$y, names(data))) {
+        data[selectedRows, self$y] <- NA
+      }
+      return(data)
+    },
+
+    #' @description Render NA values for all left axis data
+    #' @param data A data.frame
+    #' @return A data.frame to be plotted in right axis
+    getRightAxis = function(data) {
+      if(!self$requireDualAxis(data)){
+        return(NULL)
+      }
+      # Ensure NAs in that data don't mess up the selection
+      selectedRows <- as.logical(data[, self$y2Axis]) %in% FALSE
+      if (isIncluded(self$ymax, names(data))) {
+        data[selectedRows, self$ymax] <- NA
+      }
+      if (isIncluded(self$ymin, names(data))) {
+        data[selectedRows, self$ymin] <- NA
+      }
+      if (isIncluded(self$y, names(data))) {
+        data[selectedRows, self$y] <- NA
+      }
+      return(data)
     }
   )
 )

R/plot-observed-time-profile.R

@@ -18,7 +18,7 @@
 #'   data = obsData,
 #'   dataMapping = ObservedDataMapping$new(x = "x", y = "y")
 #' )
-plotObservedTimeProfile <- function(data = NULL,
+plotObservedTimeProfile <- function(data,
                                     metaData = NULL,
                                     dataMapping = NULL,
                                     plotConfiguration = NULL,
@@ -33,9 +33,50 @@ plotObservedTimeProfile <- function(data = NULL,
   )
   plotObject <- .setPlotObject(plotObject, plotConfiguration)
 
+  requireDualAxis <- dataMapping$requireDualAxis(data)
+
+  if (!requireDualAxis) {
+    plotObject <- .plotObservedTimeProfileCore(
+      data = data,
+      metaData = metaData,
+      dataMapping = dataMapping,
+      plotConfiguration = plotConfiguration,
+      plotObject = plotObject
+    )
+    return(plotObject)
+  }
+
+  leftPlotObject <- .plotObservedTimeProfileCore(
+    data = dataMapping$getLeftAxis(data),
+    metaData = metaData,
+    dataMapping = dataMapping,
+    plotConfiguration = plotConfiguration,
+    plotObject = plotObject
+  )
+  rightPlotObject <- .plotObservedTimeProfileCore(
+    data = dataMapping$getRightAxis(data),
+    metaData = metaData,
+    dataMapping = dataMapping,
+    plotConfiguration = plotConfiguration,
+    plotObject = plotObject
+  )
+  plotObject <- getDualAxisPlot(leftPlotObject, rightPlotObject)
+  return(plotObject)
+}
+
+
+#' @title .plotObservedTimeProfileCore
+#' @description Producing Core of Time Profile plots for observed data
+#' @inheritParams plotObservedTimeProfile
+#' @return A `ggplot` object
+#' @keywords internal
+.plotObservedTimeProfileCore <- function(data = NULL,
+                                         metaData = NULL,
+                                         dataMapping = NULL,
+                                         plotConfiguration = NULL,
+                                         plotObject = NULL) {
   mapData <- dataMapping$checkMapData(data)
   mapLabels <- .getAesStringMapping(dataMapping)
-
   #----- Build layers of molecule plot -----
   # 1- Error bars if available
   if (!any(isEmpty(dataMapping$ymin), isEmpty(dataMapping$ymax))) {

R/plot-simulated-time-profile.R

@@ -39,10 +39,51 @@ plotSimulatedTimeProfile <- function(data = NULL,
     data, metaData, dataMapping
   )
   plotObject <- .setPlotObject(plotObject, plotConfiguration)
+
+  requireDualAxis <- dataMapping$requireDualAxis(data)
+
+  if (!requireDualAxis) {
+    plotObject <- .plotSimulatedTimeProfileCore(
+      data = data,
+      metaData = metaData,
+      dataMapping = dataMapping,
+      plotConfiguration = plotConfiguration,
+      plotObject = plotObject
+    )
+    return(plotObject)
+  }
+
+  leftPlotObject <- .plotSimulatedTimeProfileCore(
+    data = dataMapping$getLeftAxis(data),
+    metaData = metaData,
+    dataMapping = dataMapping,
+    plotConfiguration = plotConfiguration,
+    plotObject = plotObject
+  )
+  rightPlotObject <- .plotSimulatedTimeProfileCore(
+    data = dataMapping$getRightAxis(data),
+    metaData = metaData,
+    dataMapping = dataMapping,
+    plotConfiguration = plotConfiguration,
+    plotObject = plotObject
+  )
+  plotObject <- getDualAxisPlot(leftPlotObject, rightPlotObject)
+  return(plotObject)
+}
 
+#' @title .plotSimulatedTimeProfileCore
+#' @description Producing Core of Time Profile plots for simulated data
+#' @inheritParams plotSimulatedTimeProfile
+#' @return A `ggplot` object
+#' @keywords internal
+.plotSimulatedTimeProfileCore <- function(data = NULL,
+                                         metaData = NULL,
+                                         dataMapping = NULL,
+                                         plotConfiguration = NULL,
+                                         plotObject = NULL) {
   mapData <- dataMapping$checkMapData(data)
   mapLabels <- .getAesStringMapping(dataMapping)
-
+  
   #----- Build layers of molecule plot -----
   # 1- Ribbons if available
   if (!any(isEmpty(dataMapping$ymin), isEmpty(dataMapping$ymax))) {
@@ -67,7 +108,7 @@ plotSimulatedTimeProfile <- function(data = NULL,
         show.legend = TRUE
       )
   }
-
+  
   # 2- Lines
   if (!isEmpty(dataMapping$y)) {
     aestheticValues <- .getAestheticValuesFromConfiguration(
@@ -91,7 +132,7 @@ plotSimulatedTimeProfile <- function(data = NULL,
         show.legend = TRUE,
       )
   }
-
+  
   #----- Update properties using ggplot2::scale functions -----
   plotObject <- .updateAesProperties(
     plotObject,

R/plot-timeprofile.R

@@ -79,6 +79,59 @@ plotTimeProfile <- function(data = NULL,
 
   plotObject <- .setPlotObject(plotObject, plotConfiguration)
 
+  requireDualAxis <- any(
+    dataMapping$requireDualAxis(data),
+    observedDataMapping$requireDualAxis(observedData)
+  )
+
+  if (!requireDualAxis) {
+    plotObject <- .plotTimeProfileCore(
+      data = data,
+      metaData = metaData,
+      dataMapping = dataMapping,
+      observedData = observedData,
+      observedDataMapping = observedDataMapping,
+      plotConfiguration = plotConfiguration,
+      plotObject = plotObject
+    )
+    return(plotObject)
+  }
+
+  leftPlotObject <- .plotTimeProfileCore(
+    data = dataMapping$getLeftAxis(data),
+    metaData = metaData,
+    dataMapping = dataMapping,
+    observedData = observedDataMapping$getLeftAxis(observedData),
+    observedDataMapping = observedDataMapping,
+    plotConfiguration = plotConfiguration,
+    plotObject = plotObject
+  )
+  rightPlotObject <- .plotTimeProfileCore(
+    data = dataMapping$getRightAxis(data),
+    metaData = metaData,
+    dataMapping = dataMapping,
+    observedData = observedDataMapping$getRightAxis(observedData),
+    observedDataMapping = observedDataMapping,
+    plotConfiguration = plotConfiguration,
+    plotObject = plotObject
+  )
+  plotObject <- getDualAxisPlot(leftPlotObject, rightPlotObject)
+  return(plotObject)
+}
+
+
+#' @title .plotTimeProfileCore
+#' @description Producing Core of Time Profile plots
+#' @inheritParams plotTimeProfile
+#' @return A `ggplot` object
+#' @keywords internal
+.plotTimeProfileCore <- function(data = NULL,
+                                 metaData = NULL,
+                                 dataMapping = NULL,
+                                 observedData = NULL,
+                                 observedDataMapping = NULL,
+                                 plotConfiguration = NULL,
+                                 plotObject = NULL) {
   mapData <- dataMapping$checkMapData(data)
   mapLabels <- .getAesStringMapping(dataMapping)
 
@@ -288,6 +341,7 @@ plotTimeProfile <- function(data = NULL,
 }
 
 
+
 #' @title updateTimeProfileLegend
 #' @description Update time profile legend caption
 #' @param plotObject A ggplot object