Implement plotObservedVsSimulated()

DESCRIPTION

@@ -26,7 +26,7 @@ Imports:
     readr,
     stringr,
     tidyr,
-    tlf (>= 1.3.0)
+    tlf (>= 1.4.0)
 Suggests:
     knitr,
     rmarkdown,
@@ -70,6 +70,7 @@ Collate:
     'pk-parameter.R'
     'pk-sim.R'
     'plot-individual-time-profile.R'
+    'plot-observed-vs-simulated.R'
     'plot-population-time-profile.R'
     'population-characteristics.R'
     'population.R'

NAMESPACE

@@ -107,6 +107,7 @@ export(pkAnalysesToTibble)
 export(pkParameterByName)
 export(plotGrid)
 export(plotIndividualTimeProfile)
+export(plotObservedVsSimulated)
 export(plotPopulationTimeProfile)
 export(populationAsDataFrame)
 export(populationToDataFrame)

NEWS.md

@@ -1,5 +1,9 @@
 # ospsuite 12.0 (development version)
 
+* Adds new visualization functions:
+
+    - `plotObservedVsSimulated()` for observed versus predicted scatter plots.
+
 # ospsuite 11.0.123
 
 ## New features

R/default-plot-configuration.R

@@ -120,9 +120,9 @@
 #' @field legendPosition A character string defining the legend position.
 #'   Available options can be seen using `tlf::LegendPositions` list.
 #' @field legendTitleSize,legendTitleColor,legendTitleFontFamily,legendTitleFontFace,legendTitleAngle,legendTitleAlign Aesthetic properties for the legend title.
-#' @field legendCaptionSize,legendCaptionColor,legendCaptionFontFamily,legendCaptionFontFace,legendCaptionAngle,legendCaptionAlign Aesthetic properties for the legend caption.
-#' @field xAxisTicksLabels,xAxisLabelTicksSize,xAxisLabelTicksColor,xAxisLabelTicksFontFamily,xAxisLabelTicksFontFace,xAxisLabelTicksAngle,xAxisLabelTicksAlign Aesthetic properties for the x-axis label.
-#' @field yAxisTicksLabels,yAxisLabelTicksSize,yAxisLabelTicksColor,yAxisLabelTicksFontFamily,yAxisLabelTicksFontFace,yAxisLabelTicksAngle,yAxisLabelTicksAlign Aesthetic properties for the y-axis label.
+#' @field legendKeysSize,legendKeysColor,legendKeysFontFamily,legendKeysFontFace,legendKeysAngle,legendKeysAlign Aesthetic properties for the legend caption.
+#' @field xAxisTicksLabels,xAxisLabelTicksSize,xAxisLabelTicksColor,xAxisLabelTicksFontFamily,xAxisLabelTicksFontFace,xAxisLabelTicksAngle,xAxisLabelTicksAlign,xAxisExpand Aesthetic properties for the x-axis label.
+#' @field yAxisTicksLabels,yAxisLabelTicksSize,yAxisLabelTicksColor,yAxisLabelTicksFontFamily,yAxisLabelTicksFontFace,yAxisLabelTicksAngle,yAxisLabelTicksAlign,yAxisExpand Aesthetic properties for the y-axis label.
 #' @field xAxisLimits,yAxisLimits A numeric vector of axis limits for the x-and
 #'   y-axis, respectively.
 #' @field xAxisTicks,yAxisTicks A numeric vector or a function defining where to
@@ -226,21 +226,21 @@ DefaultPlotConfiguration <- R6::R6Class(
     legendTitleFontFamily = "",
     legendTitleFontFace = tlf::FontFaces$plain,
     legendTitleAngle = 0,
-    legendTitleAlign = tlf::Alignments$center,
+    legendTitleAlign = tlf::Alignments$left,
 
-    # legendCaption ------------------------------------
+    # legendKeys ------------------------------------
 
-    legendCaptionSize = tlf::PlotAnnotationTextSize$plotLegendCaptionSize,
-    legendCaptionColor = "black",
-    legendCaptionFontFamily = "",
-    legendCaptionFontFace = tlf::FontFaces$plain,
-    legendCaptionAngle = 0,
-    legendCaptionAlign = tlf::Alignments$center,
+    legendKeysSize = tlf::PlotAnnotationTextSize$plotLegendCaptionSize,
+    legendKeysColor = "black",
+    legendKeysFontFamily = "",
+    legendKeysFontFace = tlf::FontFaces$plain,
+    legendKeysAngle = 0,
+    legendKeysAlign = tlf::Alignments$left,
 
     # XAxisConfiguration ------------------------------------
 
     xAxisLimits = NULL,
-    xAxisScale = tlf::Scaling$lin,
+    xAxisScale = NULL,
     xAxisTicks = NULL,
     xAxisTicksLabels = tlf::TickLabelTransforms$identity,
     xAxisLabelTicksSize = NULL,
@@ -253,7 +253,7 @@ DefaultPlotConfiguration <- R6::R6Class(
     # YAxisConfiguration ------------------------------------
 
     yAxisLimits = NULL,
-    yAxisScale = tlf::Scaling$lin,
+    yAxisScale = NULL,
     yAxisTicks = NULL,
     yAxisTicksLabels = tlf::TickLabelTransforms$identity,
     yAxisLabelTicksSize = NULL,
@@ -292,12 +292,14 @@ DefaultPlotConfiguration <- R6::R6Class(
     xAxisColor = "black",
     xAxisSize = 0.5,
     xAxisLinetype = tlf::Linetypes$solid,
+    xAxisExpand = FALSE,
 
     # yAxis ------------------------------------
 
     yAxisColor = "black",
     yAxisSize = 0.5,
     yAxisLinetype = tlf::Linetypes$solid,
+    yAxisExpand = FALSE,
 
     # xGrid ------------------------------------
 
@@ -324,8 +326,8 @@ DefaultPlotConfiguration <- R6::R6Class(
 
     # There is no `pointsFill` because it doesn't make sense to "fill" a line
     # with color. There is already `pointsColor` for that.
-    pointsColor = NULL,
-    pointsShape = NULL,
+    pointsColor = tlf::ColorMaps$ospDefault,
+    pointsShape = names(tlf::Shapes),
     pointsSize = 3,
     pointsAlpha = 0.75,
 

R/get-net-task.R

@@ -1,5 +1,4 @@
-#' @title Returns an instance of the specified `.NET` Task
-#' @name .getNetTask
+#' Get an instance of the specified `.NET` Task
 #'
 #' @param taskName The name of the task to retrieve (**without** `Get` prefix).
 #'

R/messages.R

@@ -26,10 +26,26 @@ messages$unpairableDatasetsRemoved <- function() {
   "Following non-grouped or unpairable datasets have been removed"
 }
 
+messages$valuesNotInterpolated <- function() {
+  "Predicted values couldn't be interpolated at following time points"
+}
+
 messages$printMultipleEntries <- function(header, entries) {
   message(paste0(header, ":\n"), paste0(entries, collapse = "\n"))
 }
 
+messages$linearScaleWithFoldDistance <- function() {
+  "Linear scale is inappropriate when `foldDistance` argument is specified."
+}
+
 messages$errorLoadingUnitsForDimension <- function(dimensions) {
   messages$printMultipleEntries("Could not load units for the following dimensions", dimensions)
 }
+
+messages$plottingWithEmptyDataCombined <- function() {
+  "No plot can be created because the entered `DataCombined` object does not contain any datasets."
+}
+
+messages$plottingWithNoPairedDatasets <- function() {
+  "No plot can be created because the entered `DataCombined` object does not contain any observed-simulated datasets that can be paired."
+}

R/plot-individual-time-profile.R

@@ -33,6 +33,11 @@ plotIndividualTimeProfile <- function(dataCombined,
   validateIsOfType(dataCombined, "DataCombined")
   validateIsSameLength(objectCount(dataCombined), 1L) # only single instance is allowed
 
+  if (is.null(dataCombined$groupMap)) {
+    warning(messages$plottingWithEmptyDataCombined())
+    return(NULL)
+  }
+
   # data frames -----------------------------
 
   combinedData <- dataCombined$toDataFrame()

R/plot-observed-vs-simulated.R

@@ -0,0 +1,142 @@
+#' Observed versus predicted/simulated scatter plot
+#'
+#' @inheritParams plotIndividualTimeProfile
+#' @param foldDistance A vector for plotting lines at required fold distances
+#'   The vector can include only fold distance values different from `1`. Even
+#'   if it is not specified, it will **always** be included.
+#'
+#' @import tlf
+#'
+#' @family plotting
+#'
+#' @examples
+#'
+#' # TODO: add example
+#'
+#' @export
+plotObservedVsSimulated <- function(dataCombined,
+                                    defaultPlotConfiguration = NULL,
+                                    foldDistance = 2) {
+  # validation -----------------------------
+
+  defaultPlotConfiguration <- defaultPlotConfiguration %||% DefaultPlotConfiguration$new()
+  validateIsOfType(dataCombined, "DataCombined")
+  validateIsSameLength(objectCount(dataCombined), 1L) # only single instance is allowed
+  validateIsOfType(defaultPlotConfiguration, "DefaultPlotConfiguration", nullAllowed = FALSE)
+
+  if (is.null(dataCombined$groupMap)) {
+    warning(messages$plottingWithEmptyDataCombined())
+    return(NULL)
+  }
+
+  # data frames -----------------------------
+
+  combinedData <- dataCombined$toDataFrame()
+
+  # Remove the observed and simulated datasets which can't be paired.
+  combinedData <- .removeUnpairableDatasets(combinedData)
+
+  # Return early if there are no pair-able datasets present
+  if (nrow(combinedData) == 0L) {
+    warning(messages$plottingWithNoPairedDatasets())
+    return(NULL)
+  }
+
+  # Getting all units on the same scale
+  combinedData <- .unitConverter(combinedData, defaultPlotConfiguration$xUnit, defaultPlotConfiguration$yUnit)
+
+  # `ObsVsPredPlotConfiguration` object -----------------------------
+
+  # Create an instance of `ObsVsPredPlotConfiguration` class by doing a
+  # one-to-one mapping of internal plot configuration object's public fields
+  obsVsPredPlotConfiguration <- .convertGeneralToSpecificPlotConfiguration(
+    data = combinedData,
+    specificPlotConfiguration = tlf::ObsVsPredPlotConfiguration$new(),
+    generalPlotConfiguration = defaultPlotConfiguration
+  )
+
+  # Linear scaling is stored as identity scaling in `{tlf}`
+  is_any_scale_linear <- (
+    obsVsPredPlotConfiguration$xAxis$scale == "identity" ||
+      obsVsPredPlotConfiguration$yAxis$scale == "identity"
+  )
+
+  # The argument `foldDistance` should only include fold values different from
+  # the default value, which must always be present.
+  #
+  # The default value depends on the scale:
+  #
+  # - For linear scale: `1`
+  # - For logarithmic scale: `0`
+  defaultFoldDistance <- ifelse(is_any_scale_linear, 0, 1)
+
+  if (!any(dplyr::near(defaultFoldDistance, foldDistance))) {
+    foldDistance <- c(defaultFoldDistance, foldDistance)
+  }
+
+  if (is_any_scale_linear && !is.null(foldDistance)) {
+    warning(messages$linearScaleWithFoldDistance())
+    foldDistance <- 0
+  }
+
+  # paired data frame -----------------------------
+
+  # Create observed versus simulated paired data using interpolation for each
+  # grouping level and combine the resulting data frames in a row-wise manner.
+  #
+  # Both of these routines will be carried out by `dplyr::group_modify()`.
+  pairedData <- combinedData %>%
+    dplyr::group_by(group) %>%
+    dplyr::group_modify(.f = ~ .createObsVsPredData(.x, scaling = obsVsPredPlotConfiguration$yAxis$scale)) %>%
+    dplyr::ungroup()
+
+  # Add min and max values for horizontal error bars
+  pairedData <- dplyr::mutate(
+    pairedData,
+    obsValueLower = obsValue - obsErrorValue,
+    obsValueHigher = obsValue + obsErrorValue
+  )
+
+  # Time points at which predicted values can't be interpolated, and need to be
+  # extrapolated.
+  #
+  # This will happen in rare case scenarios where simulated data is sampled at a
+  # lower frequency than observed data.
+  predValueMissingIndices <- which(is.na(pairedData$predValue))
+
+  # Warn the user about failure to interpolate.
+  if (length(predValueMissingIndices) > 0) {
+    warning(
+      messages$printMultipleEntries(
+        header = messages$valuesNotInterpolated(),
+        entries = pairedData$obsTime[predValueMissingIndices]
+      )
+    )
+  }
+
+  # axes labels -----------------------------
+
+  # The type of plot can be guessed from the specific `PlotConfiguration` object
+  # used, since each plot has a unique corresponding class. The labels can then
+  # be prepared accordingly.
+  axesLabels <- .createAxesLabels(combinedData, obsVsPredPlotConfiguration)
+  obsVsPredPlotConfiguration$labels$xlabel$text <- obsVsPredPlotConfiguration$labels$xlabel$text %||% axesLabels$xLabel
+  obsVsPredPlotConfiguration$labels$ylabel$text <- obsVsPredPlotConfiguration$labels$ylabel$text %||% axesLabels$yLabel
+
+  # plot -----------------------------
+
+  tlf::plotObsVsPred(
+    data = as.data.frame(pairedData),
+    dataMapping = tlf::ObsVsPredDataMapping$new(
+      x = "obsValue",
+      y = "predValue",
+      group = "group",
+      xmin = "obsValueLower",
+      xmax = "obsValueHigher",
+      lines = NULL
+    ),
+    foldDistance = foldDistance,
+    smoother = NULL,
+    plotConfiguration = obsVsPredPlotConfiguration
+  )
+}

R/plot-population-time-profile.R

@@ -18,8 +18,6 @@
 plotPopulationTimeProfile <- function(dataCombined,
                                       defaultPlotConfiguration = NULL,
                                       quantiles = c(0.05, 0.5, 0.95)) {
-  # validation -----------------------------
-
   validateIsNumeric(quantiles, nullAllowed = FALSE)
   validateIsOfLength(quantiles, 3L)