R/utilities-plotting.R

Defines functions .extractAggregatedSimulatedData .addMissingGroupings .validateDefaultPlotConfiguration .validateDataCombinedForPlotting

Documented in .addMissingGroupings .extractAggregatedSimulatedData

#' Make sure entered `DataCombined` object is valid for plotting
#'
#' @family utilities-plotting
#'
#' @keywords internal
#' @noRd
.validateDataCombinedForPlotting <- function(dataCombined) {
  .validateScalarDataCombined(dataCombined)

  # If there are no datasets in the object, no plot will be created.
  if (is.null(dataCombined$groupMap)) {
    warning(messages$plottingWithEmptyDataCombined())
  }
}

#' Make sure entered `DefaultPlotConfiguration` object is valid for plotting
#'
#' @family utilities-plotting
#'
#' @keywords internal
#' @noRd
.validateDefaultPlotConfiguration <- function(defaultPlotConfiguration = NULL) {
  defaultPlotConfiguration <- defaultPlotConfiguration %||% DefaultPlotConfiguration$new()
  validateIsOfType(defaultPlotConfiguration, "DefaultPlotConfiguration")

  # Plotting functions should not update the configuration objects
  defaultPlotConfiguration <- defaultPlotConfiguration$clone(deep = TRUE)

  return(defaultPlotConfiguration)
}

#' Replace missing groupings with dataset names
#'
#' @description
#'
#' Datasets which haven't been assigned to any group will be plotted as a group
#' on its own. That is, the `group` column entries for them will be their names.
#'
#' @param data A data frame returned by `DataCombined$toDataFrame()`.
#'
#' @family utilities-plotting
#'
#' @examples
#'
#' df <- dplyr::tibble(
#'   group = c(
#'     "Stevens 2012 solid total",
#'     "Stevens 2012 solid total",
#'     NA,
#'     NA,
#'     NA
#'   ),
#'   name = c(
#'     "Organism|Lumen|Stomach|Metformin|Gastric retention",
#'     "Stevens_2012_placebo.Placebo_total",
#'     "Stevens_2012_placebo.Sita_dist",
#'     "Stevens_2012_placebo.Sita_proximal",
#'     "Stevens_2012_placebo.Sita_total"
#'   ),
#'   dataType = c(
#'     "simulated",
#'     "observed",
#'     "observed",
#'     "observed",
#'     "observed"
#'   )
#' )
#'
#' # original
#' df
#'
#' # transformed
#' ospsuite:::.addMissingGroupings(df)
#'
#' @keywords internal
.addMissingGroupings <- function(data) {
  data <- dplyr::mutate(
    data,
    group = dplyr::case_when(
      # If grouping is missing, then use dataset name as its own grouping.
      is.na(group) ~ name,
      # Otherwise, no change.
      TRUE ~ group
    )
  )

  return(data)
}


#' Extract aggregated simulated data
#'
#' @param simData A data frame with simulated data from
#'  `DataCombined$toDataFrame()`.
#' @param aggregation The type of the aggregation of individual data. One of
#'  `quantiles` (Default), `arithmetic` or `geometric` (full list in
#'  `ospsuite::DataAggregationMethods`). Will replace `yValues` by the median,
#'  arithmetic or geometric average and add a set of upper and lower bounds
#'  (`yValuesLower` and `yValuesHigher`).
#' @param quantiles A numerical vector with quantile values (Default: `c(0.05,
#'  0.50, 0.95)`) to be plotted. Ignored if `aggregation` is not `quantiles`.
#' @inheritDotParams .normRange nsd
#'
#' @details The simulated values will be aggregated across individuals for each
#'  time point.
#'
#'  For `aggregation = quantiles` (default), the quantile values defined in the
#'  argument `quantiles` will be used. In the profile plot, the middle value
#'  will be used to draw a line, while the lower and upper values will be used
#'  as the lower und upper ranges. For `aggregation = arithmetic`, arithmetic
#'  mean with arithmetic standard deviation (SD) will be plotted. Use the
#'  optional parameter `nsd` to change the number of SD to plot above and below
#'  the mean. For `aggregation = geometric`, geometric mean with geometric
#'  standard deviation (SD) will be plotted. Use the optional parameter `nsd` to
#'  change the number of SD to plot above and below the mean.
#'
#' @family utilities-plotting
#'
#' @import data.table
#'
#' @examples
#'
#' # let's create a data frame to test this function
#' df <- dplyr::tibble(
#'   xValues = c(
#'     0, 1, 2, 3, 4, 5, 0, 1, 2, 3, 4, 5,
#'     0, 1, 2, 3, 4, 5, 0, 1, 2, 3, 4, 5, 0, 1, 2, 3, 4, 5, 0, 1, 2,
#'     3, 4, 5, 0, 1, 2, 3, 4, 5, 0, 1, 2, 3, 4, 5
#'   ),
#'   yValues = c(
#'     0,
#'     0.990956723690033, 0.981773018836975, 0.972471475601196, 0.963047087192535,
#'     0.953498184680939, 0, 0.990953505039215, 0.981729507446289, 0.97233647108078,
#'     0.962786376476288, 0.953093528747559, 0, 0.990955889225006, 0.981753170490265,
#'     0.972399413585663, 0.962896287441254, 0.953253626823425, 0, 0.990950107574463,
#'     0.981710314750671, 0.972296476364136, 0.962724387645721, 0.953009009361267,
#'     0, 0.261394888162613, 0.266657412052155, 0.27151620388031, 0.275971591472626,
#'     0.280027687549591, 0, 0.26139160990715, 0.266613900661469, 0.271381109952927,
#'     0.275710910558701, 0.279623001813889, 0, 0.261393994092941, 0.266637593507767,
#'     0.271443992853165, 0.275820910930634, 0.279783099889755, 0, 0.261388212442398,
#'     0.266594797372818, 0.27134120464325, 0.275649011135101, 0.279538512229919
#'   ),
#'   group = c(rep("Stevens 2012 solid total", 24), rep("Stevens 2012 solid distal", 24)),
#'   name = group
#' )
#'
#' # raw data
#' df
#'
#' # aggregated data
#' ospsuite:::.extractAggregatedSimulatedData(df)
#'
#' @keywords internal
.extractAggregatedSimulatedData <- function(simData,
                                            aggregation = "quantiles",
                                            ...) {
  ospsuite.utils::validateEnumValue(
    value       = aggregation,
    enum        = DataAggregationMethods,
    nullAllowed = FALSE
  )

  valueNames <- c("yValuesLower", "yValues", "yValuesHigher")
  simAggregatedData <- data.table::as.data.table(simData)

  aggregation_function <- switch(aggregation,
    "quantiles"  = .quantRange,
    "arithmetic" = .normRange,
    "geometric"  = .geoRange
  )

  # For each dataset, compute quantiles across all individuals for each time point
  #
  # Each group should always a single dataset, so grouping by `group` *and* `name`
  # should produce the same result as grouping by only `group` column.
  #
  # The reason `name` column also needs to be retained in the resulting data
  # is because it is mapped to linetype property in population profile type.
  simAggregatedData <-
    simAggregatedData[,
      stats::setNames(
        as.list(aggregation_function(yValues, ...)),
        valueNames
      ),
      by = .(group, name, xValues)
    ]


  return(simAggregatedData)
}

#' Create axes labels
#'
#' @details
#'
#' If axes labels haven't been specified, create them using information about
#' dimensions and units present in the data frame produced by
#' `DataCombined$toDataFrame()`.
#'
#' @param data A data frame from `DataCombined$toDataFrame()`, which has
#'   additionally been cleaned using `ospsuite:::.unitConverter()` to have the
#'   same units across datasets.
#' @param specificPlotConfiguration The nature of labels will change depending
#'   on the type of plot. The type of plot can be guessed from the specific
#'   `PlotConfiguration` object used, since each plot has a unique corresponding
#'   class.
#'
#' @family utilities-plotting
#'
#' @examples
#'
#' df <- dplyr::tibble(
#'   dataType = c(rep("simulated", 3), rep("observed", 3)),
#'   xValues = c(0, 14.482, 28.965, 0, 1, 2),
#'   xUnit = "min",
#'   xDimension = "Time",
#'   yValues = c(1, 1, 1, 1, 1, 1),
#'   yUnit = "mol/ml",
#'   yDimension = ospDimensions$`Concentration (mass)`,
#'   yErrorValues = c(2.747, 2.918, 2.746, NA, NA, NA),
#'   molWeight = c(10, 10, 20, 20, 10, 10)
#' )
#'
#' df <- ospsuite:::.unitConverter(df)
#'
#' ospsuite:::.createAxesLabels(df, tlf::TimeProfilePlotConfiguration$new())
#'
#' @keywords internal
.createAxesLabels <- function(data, specificPlotConfiguration) {
  # If empty data frame is entered or plot type is not specified, return early
  if (nrow(data) == 0L || missing(specificPlotConfiguration)) {
    return(NULL)
  }

  # special concern for concentration --------------------------

  # If there are multiple dimensions for Y-axis variable, it is most likely to
  # be due to multiple concentration dimensions.
  #
  # Hard code these to  a single dimension: `"Concentration"`.
  #
  # For more, see:
  # https://github.com/Open-Systems-Pharmacology/OSPSuite-R/issues/938
  concDimensions <- c(ospDimensions$`Concentration (mass)`, ospDimensions$`Concentration (molar)`)

  if (!all(is.na(data$yDimension))) {
    data <- dplyr::mutate(data,
      yDimension = dplyr::case_when(
        yDimension %in% concDimensions ~ "Concentration",
        TRUE ~ yDimension
      )
    )
  }

  if (!all(is.na(data$xDimension))) {
    data <- dplyr::mutate(data,
      xDimension = dplyr::case_when(
        xDimension %in% concDimensions ~ "Concentration",
        TRUE ~ xDimension
      )
    )
  }

  # Initialize strings with unique values for units and dimensions.
  #
  # The`.unitConverter()` has already ensured that there is only a single unit
  # for quantities, so we can safely take the unique unit to prepare axes
  # labels.
  xUnitString <- unique(data$xUnit)
  yUnitString <- unique(data$yUnit)

  # There might be multiple dimensions across datasets, select the first one.
  xDimensionString <- unique(data$xDimension)[[1]]
  yDimensionString <- unique(data$yDimension)[[1]]

  # If quantities are unitless, no unit information needs to be displayed.
  # Otherwise, `Dimension [Unit]` pattern is followed.
  xUnitString <- ifelse(xUnitString == "", xUnitString, paste0(" [", xUnitString, "]"))
  xUnitString <- paste0(xDimensionString, xUnitString)
  yUnitString <- ifelse(yUnitString == "", yUnitString, paste0(" [", yUnitString, "]"))
  yUnitString <- paste0(yDimensionString, yUnitString)

  # The exact axis label will depend on the type of the plot, and the type
  # of the plot can be guessed using the specific `PlotConfiguration` object.
  plotType <- class(specificPlotConfiguration)[[1]]

  # If the specific `PlotConfiguration` object is not any of the cases included
  # in the `switch` below, the the labels will remain `NULL`.

  # X-axis label
  xLabel <- switch(plotType,
    "TimeProfilePlotConfiguration" = ,
    "ResVsTimePlotConfiguration" = xUnitString,
    # Note that `yUnitString` here is deliberate.
    #
    # In case of an observed versus simulated plot, `yValues` are plotted on
    # both x- and y-axes, and therefore the units strings are going to be the
    # same for both axes.
    "ObsVsPredPlotConfiguration" = paste0("Observed values (", yUnitString, ")"),
    "ResVsPredPlotConfiguration" = paste0("Simulated values (", yUnitString, ")")
  )

  # Y-axis label
  yLabel <- switch(plotType,
    "TimeProfilePlotConfiguration" = yUnitString,
    "ResVsPredPlotConfiguration" = ,
    "ResVsTimePlotConfiguration" = "Residuals",
    "ObsVsPredPlotConfiguration" = paste0("Simulated values (", yUnitString, ")")
  )

  return(list("xLabel" = xLabel, "yLabel" = yLabel))
}


#' Update axes label fields in `PlotConfiguration` object
#'
#' @family utilities-plotting
#'
#' @keywords internal
#' @noRd
.updatePlotConfigurationAxesLabels <- function(data, plotConfiguration) {
  axesLabels <- .createAxesLabels(data, plotConfiguration)

  # Update only if the user hasn't already specified labels.
  plotConfiguration$labels$xlabel$text <- plotConfiguration$labels$xlabel$text %||% axesLabels$xLabel
  plotConfiguration$labels$ylabel$text <- plotConfiguration$labels$ylabel$text %||% axesLabels$yLabel

  return(plotConfiguration)
}


#' Compute error bar bounds from error type
#'
#' @keywords internal
#' @noRd
.computeBoundsFromErrorType <- function(data) {
  if (is.null(data)) {
    return(NULL)
  }

  if (!all(is.na(data$yErrorValues)) && !all(is.na(data$yErrorType))) {
    data <-
      dplyr::mutate(
        data,
        # If the error values are 0, the error bar caps will be displayed even
        # when there are no error bars. Replacing `0`s with `NA`s gets rid of this
        # problem.
        #
        # For more, see: https://github.com/Open-Systems-Pharmacology/TLF-Library/issues/348
        yErrorValues = dplyr::case_when(
          dplyr::near(yErrorValues, 0) ~ NA_real_,
          TRUE ~ yErrorValues
        ),
        # For compuring uncertainty, there are only three possibilities:
        #
        # - The error type is arithmetic (`DataErrorType$ArithmeticStdDev`).
        # - The error type is geometric (`DataErrorType$GeometricStdDev`).
        # - If the errors are none of these, then add `NA`s (of type `double`),
        #   since these are the only error types supported in `DataErrorType`.
        yValuesLower = dplyr::case_when(
          yErrorType == DataErrorType$ArithmeticStdDev ~ yValues - yErrorValues,
          yErrorType == DataErrorType$GeometricStdDev ~ yValues / yErrorValues,
          TRUE ~ NA_real_
        ),
        yValuesHigher = dplyr::case_when(
          yErrorType == DataErrorType$ArithmeticStdDev ~ yValues + yErrorValues,
          yErrorType == DataErrorType$GeometricStdDev ~ yValues * yErrorValues,
          TRUE ~ NA_real_
        )
      )
  } else {
    # These columns should always be present in the data frame because they are
    # part of `{tlf}` mapping.
    data <- dplyr::mutate(data, yValuesLower = NA_real_, yValuesHigher = NA_real_)
  }

  return(data)
}





#' Create plot-specific `tlf::PlotConfiguration` object
#'
#' @details
#'
#' The default plot configuration and the labels needs to vary from plot-to-plot
#' because each plot has its specific (default) aesthetic needs that need to be
#' met.
#'
#' For example, although the axes labels for profile plots will be (e.g.) "Time
#' vs Fraction", they will be (e.g.) "Observed vs simulated values" for scatter
#' plots. Additionally, mapping group to line colors might be desirable for a
#' profile plot, it is not so for scatter plots.
#'
#' This function generates object of specific subclass of
#' `tlf::PlotConfiguration` needed for the given plot but with suitable defaults
#' taken from the `DefaultPlotConfiguration` object.
#'
#' @param specificPlotConfiguration A specific subclass of
#'   `tlf::PlotConfiguration` needed for the given plot.
#' @param generalPlotConfiguration A `DefaultPlotConfiguration` object.
#'
#' @family utilities-plotting
#'
#' @examples
#'
#' ospsuite:::.convertGeneralToSpecificPlotConfiguration(
#'   tlf::TimeProfilePlotConfiguration$new(),
#'   ospsuite::DefaultPlotConfiguration$new()
#' )
#'
#' @keywords internal
.convertGeneralToSpecificPlotConfiguration <- function(specificPlotConfiguration,
                                                       generalPlotConfiguration) {
  # Plot-specific configuration defaults -----------------------------------

  # The type of plot can be guessed from the specific `PlotConfiguration` object
  # used, since each plot has a unique corresponding class.
  plotType <- class(specificPlotConfiguration)[[1]]

  # For `plotIndividualTimeProfile()` and `plotPopulationTimeProfile()`
  if (plotType == "TimeProfilePlotConfiguration") {
    generalPlotConfiguration$linesColor <- generalPlotConfiguration$linesColor %||% tlf::ColorMaps$ospDefault
    # This is especially necessary when multiple simulated datasets are present per group
    generalPlotConfiguration$linesLinetype <- generalPlotConfiguration$linesLinetype %||% names(tlf::Linetypes)
    generalPlotConfiguration$legendPosition <- generalPlotConfiguration$legendPosition %||% tlf::LegendPositions$insideTopRight
    generalPlotConfiguration$xAxisScale <- generalPlotConfiguration$xAxisScale %||% tlf::Scaling$lin
    generalPlotConfiguration$yAxisScale <- generalPlotConfiguration$yAxisScale %||% tlf::Scaling$lin
  }

  # For `plotObservedVsSimulated()`
  if (plotType == "ObsVsPredPlotConfiguration") {
    generalPlotConfiguration$linesColor <- "black"
    generalPlotConfiguration$legendPosition <- generalPlotConfiguration$legendPosition %||% tlf::LegendPositions$insideBottomRight
    generalPlotConfiguration$xAxisScale <- generalPlotConfiguration$xAxisScale %||% tlf::Scaling$log
    generalPlotConfiguration$yAxisScale <- generalPlotConfiguration$yAxisScale %||% tlf::Scaling$log
    # every fold distance line should get a unique type of line
    generalPlotConfiguration$linesLinetype <- generalPlotConfiguration$linesLinetype %||% names(tlf::Linetypes)
  }

  # For `plotResidualsVsTime()` and `plotResidualsVsSimulated()`
  if (plotType %in% c("ResVsTimePlotConfiguration", "ResVsPredPlotConfiguration")) {
    generalPlotConfiguration$linesColor <- "black"
    generalPlotConfiguration$linesLinetype <- generalPlotConfiguration$linesLinetype %||% tlf::Linetypes$dashed
    generalPlotConfiguration$xAxisScale <- generalPlotConfiguration$xAxisScale %||% tlf::Scaling$lin
    generalPlotConfiguration$yAxisScale <- generalPlotConfiguration$yAxisScale %||% tlf::Scaling$lin
  }

  # labels object ---------------------------------------

  labelTitle <- tlf::Label$new(
    text = generalPlotConfiguration$title,
    color = generalPlotConfiguration$titleColor,
    size = generalPlotConfiguration$titleSize,
    fontFace = generalPlotConfiguration$titleFontFace,
    fontFamily = generalPlotConfiguration$titleFontFamily,
    angle = generalPlotConfiguration$titleAngle,
    align = generalPlotConfiguration$titleAlign,
    margin = generalPlotConfiguration$titleMargin
  )

  labelSubtitle <- tlf::Label$new(
    text = generalPlotConfiguration$subtitle,
    color = generalPlotConfiguration$subtitleColor,
    size = generalPlotConfiguration$subtitleSize,
    fontFace = generalPlotConfiguration$subtitleFontFace,
    fontFamily = generalPlotConfiguration$subtitleFontFamily,
    angle = generalPlotConfiguration$subtitleAngle,
    align = generalPlotConfiguration$subtitleAlign,
    margin = generalPlotConfiguration$subtitleMargin
  )

  labelCaption <- tlf::Label$new(
    text = generalPlotConfiguration$caption,
    color = generalPlotConfiguration$captionColor,
    size = generalPlotConfiguration$captionSize,
    fontFace = generalPlotConfiguration$captionFontFace,
    fontFamily = generalPlotConfiguration$captionFontFamily,
    angle = generalPlotConfiguration$captionAngle,
    align = generalPlotConfiguration$captionAlign,
    margin = generalPlotConfiguration$captionMargin
  )

  labelXLabel <- tlf::Label$new(
    text = generalPlotConfiguration$xLabel,
    color = generalPlotConfiguration$xLabelColor,
    size = generalPlotConfiguration$xLabelSize,
    fontFace = generalPlotConfiguration$xLabelFontFace,
    fontFamily = generalPlotConfiguration$xLabelFontFamily,
    angle = generalPlotConfiguration$xLabelAngle,
    align = generalPlotConfiguration$xLabelAlign,
    margin = generalPlotConfiguration$xLabelMargin
  )

  labelYLabel <- tlf::Label$new(
    text = generalPlotConfiguration$yLabel,
    color = generalPlotConfiguration$yLabelColor,
    size = generalPlotConfiguration$yLabelSize,
    fontFace = generalPlotConfiguration$yLabelFontFace,
    fontFamily = generalPlotConfiguration$yLabelFontFamily,
    angle = generalPlotConfiguration$yLabelAngle,
    align = generalPlotConfiguration$yLabelAlign,
    margin = generalPlotConfiguration$yLabelMargin
  )

  labelConfiguration <- tlf::LabelConfiguration$new(
    title = labelTitle,
    subtitle = labelSubtitle,
    caption = labelCaption,
    xlabel = labelXLabel,
    ylabel = labelYLabel
  )

  # legend object ---------------------------------------

  legendTitleFont <- tlf::Font$new(
    size = generalPlotConfiguration$legendTitleSize,
    color = generalPlotConfiguration$legendTitleColor,
    fontFamily = generalPlotConfiguration$legendTitleFontFamily,
    fontFace = generalPlotConfiguration$legendTitleFontFace,
    angle = generalPlotConfiguration$legendTitleAngle,
    align = generalPlotConfiguration$legendTitleAlign,
    margin = generalPlotConfiguration$legendTitleMargin
  )

  legendTitleLabel <- tlf::Label$new(
    text = generalPlotConfiguration$legendTitle,
    font = legendTitleFont
  )

  legendKeysFont <- tlf::Font$new(
    size = generalPlotConfiguration$legendKeysSize,
    color = generalPlotConfiguration$legendKeysColor,
    fontFamily = generalPlotConfiguration$legendKeysFontFamily,
    fontFace = generalPlotConfiguration$legendKeysFontFace,
    angle = generalPlotConfiguration$legendKeysAngle,
    align = generalPlotConfiguration$legendKeysAlign,
    margin = generalPlotConfiguration$legendKeysMargin
  )

  legendConfiguration <- tlf::LegendConfiguration$new(
    position = generalPlotConfiguration$legendPosition,
    caption = NULL,
    title = legendTitleLabel, # for legend title aesthetics
    font = legendKeysFont, # for legend keys aesthetics
    background = tlf::BackgroundElement$new(
      color = generalPlotConfiguration$legendBorderColor,
      fill = ggplot2::alpha(
        colour = generalPlotConfiguration$legendBackgroundColor,
        alpha = generalPlotConfiguration$legendBackgroundAlpha
      ),
      linetype = generalPlotConfiguration$legendBorderType,
      size = generalPlotConfiguration$legendBorderSize
    )
  )

  # background objects -----------------------------------

  labelWatermark <- tlf::Label$new(
    text = generalPlotConfiguration$watermark,
    color = generalPlotConfiguration$watermarkColor,
    size = generalPlotConfiguration$watermarkSize,
    fontFace = generalPlotConfiguration$watermarkFontFace,
    fontFamily = generalPlotConfiguration$watermarkFontFamily,
    angle = generalPlotConfiguration$watermarkAngle,
    align = generalPlotConfiguration$watermarkAlign,
    margin = generalPlotConfiguration$watermarkMargin
  )

  plotBackground <- tlf::BackgroundElement$new(
    fill = generalPlotConfiguration$plotBackgroundFill,
    color = generalPlotConfiguration$plotBackgroundColor,
    size = generalPlotConfiguration$plotBackgroundSize,
    linetype = generalPlotConfiguration$plotBackgroundLinetype
  )

  plotPanelBackground <- tlf::BackgroundElement$new(
    fill = generalPlotConfiguration$plotPanelBackgroundFill,
    color = generalPlotConfiguration$plotPanelBackgroundColor,
    size = generalPlotConfiguration$plotPanelBackgroundSize,
    linetype = generalPlotConfiguration$plotPanelBackgroundLinetype
  )

  xAxis <- tlf::LineElement$new(
    color = generalPlotConfiguration$xAxisColor,
    size = generalPlotConfiguration$xAxisSize,
    linetype = generalPlotConfiguration$xAxisLinetype
  )

  yAxis <- tlf::LineElement$new(
    color = generalPlotConfiguration$yAxisColor,
    size = generalPlotConfiguration$yAxisSize,
    linetype = generalPlotConfiguration$yAxisLinetype
  )

  xGrid <- tlf::LineElement$new(
    color = generalPlotConfiguration$xGridColor,
    size = generalPlotConfiguration$xGridSize,
    linetype = generalPlotConfiguration$xGridLinetype
  )

  yGrid <- tlf::LineElement$new(
    color = generalPlotConfiguration$yGridColor,
    size = generalPlotConfiguration$yGridSize,
    linetype = generalPlotConfiguration$yGridLinetype
  )

  backgroundConfiguration <- tlf::BackgroundConfiguration$new(
    watermark = generalPlotConfiguration$labelWatermark,
    plot = generalPlotConfiguration$plotBackground,
    panel = generalPlotConfiguration$plotPanelBackground,
    xAxis = generalPlotConfiguration$xAxis,
    yAxis = generalPlotConfiguration$yAxis,
    xGrid = generalPlotConfiguration$xGrid,
    yGrid = generalPlotConfiguration$yGrid
  )

  # xAxis objects -----------------------------------

  xAxisFont <- tlf::Font$new(
    size = generalPlotConfiguration$xAxisLabelTicksSize,
    color = generalPlotConfiguration$xAxisLabelTicksColor,
    fontFamily = generalPlotConfiguration$xAxisLabelTicksFontFamily,
    fontFace = generalPlotConfiguration$xAxisLabelTicksFontFace,
    angle = generalPlotConfiguration$xAxisLabelTicksAngle,
    align = generalPlotConfiguration$xAxisLabelTicksAlign,
    margin = generalPlotConfiguration$xAxisLabelTicksMargin
  )

  xAxisConfiguration <- tlf::XAxisConfiguration$new(
    axisLimits = generalPlotConfiguration$xAxisLimits,
    valuesLimits = generalPlotConfiguration$xValuesLimits,
    scale = generalPlotConfiguration$xAxisScale,
    ticks = generalPlotConfiguration$xAxisTicks,
    ticklabels = generalPlotConfiguration$xAxisTicksLabels,
    font = xAxisFont,
    expand = generalPlotConfiguration$xAxisExpand
  )

  # yAxis objects -----------------------------------

  yAxisFont <- tlf::Font$new(
    size = generalPlotConfiguration$yAxisLabelTicksSize,
    color = generalPlotConfiguration$yAxisLabelTicksColor,
    fontFamily = generalPlotConfiguration$yAxisLabelTicksFontFamily,
    fontFace = generalPlotConfiguration$yAxisLabelTicksFontFace,
    angle = generalPlotConfiguration$yAxisLabelTicksAngle,
    align = generalPlotConfiguration$yAxisLabelTicksAlign,
    margin = generalPlotConfiguration$yAxisLabelTicksMargin
  )

  yAxisConfiguration <- tlf::YAxisConfiguration$new(
    axisLimits = generalPlotConfiguration$yAxisLimits,
    valuesLimits = generalPlotConfiguration$yValuesLimits,
    scale = generalPlotConfiguration$yAxisScale,
    ticks = generalPlotConfiguration$yAxisTicks,
    ticklabels = generalPlotConfiguration$yAxisTicksLabels,
    font = yAxisFont,
    expand = generalPlotConfiguration$yAxisExpand
  )

  # lines -------------------------------------------------------

  linesConfiguration <- tlf::ThemeAestheticSelections$new(
    color = generalPlotConfiguration$linesColor,
    shape = generalPlotConfiguration$linesShape,
    size = generalPlotConfiguration$linesSize,
    linetype = generalPlotConfiguration$linesLinetype,
    alpha = generalPlotConfiguration$linesAlpha
  )

  # points -------------------------------------------------------

  pointsConfiguration <- tlf::ThemeAestheticSelections$new(
    color = generalPlotConfiguration$pointsColor,
    shape = generalPlotConfiguration$pointsShape,
    size = generalPlotConfiguration$pointsSize,
    alpha = generalPlotConfiguration$pointsAlpha
  )

  # ribbons -------------------------------------------------------

  ribbonsConfiguration <- tlf::ThemeAestheticSelections$new(
    fill = generalPlotConfiguration$ribbonsFill,
    shape = generalPlotConfiguration$ribbonsShape,
    size = generalPlotConfiguration$ribbonsSize,
    linetype = generalPlotConfiguration$ribbonsLinetype,
    alpha = generalPlotConfiguration$ribbonsAlpha
  )

  # errorbars -------------------------------------------------------

  errorbarsConfiguration <- tlf::ThemeAestheticSelections$new(
    size = generalPlotConfiguration$errorbarsSize,
    # TODO 2DO: https://github.com/Open-Systems-Pharmacology/TLF-Library/issues/347
    # capSize = generalPlotConfiguration$errorbarsCapSize,
    linetype = generalPlotConfiguration$errorbarsLinetype,
    alpha = generalPlotConfiguration$errorbarsAlpha
  )

  # LLOQ
  .updateSpecificSetting("displayLLOQ", specificPlotConfiguration, generalPlotConfiguration)
  .updateSpecificSetting("lloqDirection", specificPlotConfiguration, generalPlotConfiguration)

  # foldDistance
  .updateSpecificSetting("foldLinesLegend", specificPlotConfiguration, generalPlotConfiguration)
  .updateSpecificSetting("foldLinesLegendDiagonal", specificPlotConfiguration, generalPlotConfiguration)

  # Update specific plot configuration object ----------------------

  # Do one-to-one mappings of public fields
  specificPlotConfiguration$labels <- labelConfiguration
  specificPlotConfiguration$legend <- legendConfiguration
  specificPlotConfiguration$xAxis <- xAxisConfiguration
  specificPlotConfiguration$yAxis <- yAxisConfiguration
  specificPlotConfiguration$background <- backgroundConfiguration
  specificPlotConfiguration$lines <- linesConfiguration
  specificPlotConfiguration$points <- pointsConfiguration
  specificPlotConfiguration$ribbons <- ribbonsConfiguration
  specificPlotConfiguration$errorbars <- errorbarsConfiguration

  return(specificPlotConfiguration)
}

.updateSpecificSetting <- function(specificSetting, specificPlotConfiguration, generalPlotConfiguration) {
  if (!is.null(specificPlotConfiguration[[specificSetting]]) &
    !is.null(generalPlotConfiguration[[specificSetting]])) {
    if (generalPlotConfiguration[[specificSetting]] != specificPlotConfiguration[[specificSetting]]) {
      specificPlotConfiguration[[specificSetting]] <- generalPlotConfiguration[[specificSetting]]
    }
  }
}

#' Names of aggregation available for plotPopulationTimeProfile()
#'
#' @export
DataAggregationMethods <-
  ospsuite.utils::enum(c(
    "quantiles",
    "arithmetic",
    "geometric"
  ))

#' Quantile Range
#'
#' @inheritParams stats::quantile
#' @param ... further arguments passed to stats::quantile.
#'
#' @return numeric vector of length 3 representing the computed quantiles of x.
#' @noRd
.quantRange <- function(x, probs = c(0.05, 0.5, 0.95), na.rm = FALSE, ...) {
  validateIsNumeric(probs, nullAllowed = FALSE)
  validateIsOfLength(probs, 3L)
  stats::quantile(x, probs, na.rm = na.rm, ...)
}

#' Normal Range
#'
#' @param x numeric vector to compute normal range from
#' @param nsd optional argument defining the number of standard deviation to add
#'   and substract to the mean
#' @param na.rm a logical evaluating to TRUE or FALSE indicating whether NA
#'   values should be stripped before the computation proceeds.
#' @param ... further arguments passed to mean and sd functions.
#'
#' @return numeric vector of length 3 representing the min, mean and max of the
#'   normal range.
#' @keywords internal
.normRange <- function(x, nsd = 1, na.rm = FALSE, ...) {
  mean <- mean(x, na.rm = na.rm, ...)
  sd <- stats::sd(x, na.rm = na.rm)
  return(c(mean - (abs(nsd) * sd), mean, mean + (abs(nsd) * sd)))
}

#' Geometric Range
#'
#' @param x numeric vector to compute geometric range from
#' @inheritParams .normRange
#' @param na.rm a logical evaluating to TRUE or FALSE indicating whether NA
#'   values should be stripped before the computation proceeds.
#' @param ... further arguments passed to mean and sd functions.
#'
#' @return numeric vector of length 3 representing the min, mean and max of the
#'   geometric range.
#' @keywords internal
.geoRange <- function(x, nsd = 1, na.rm = FALSE, ...) {
  geomean <- .geoMean(x, na.rm = na.rm, ...)
  geomsd <- .geoSD(x, na.rm = na.rm)

  return(c(
    exp(log(geomean) - abs(nsd) * log(geomsd)),
    geomean,
    exp(log(geomean) + abs(nsd) * log(geomsd))
  ))
}


.geoMean <- function(x, na.rm = FALSE, ...) {
  exp(mean(log(x), na.rm = na.rm, ...))
}

.geoSD <- function(x, na.rm = FALSE, ...) {
  exp(stats::sd(log(x), na.rm = na.rm, ...))
}
Open-Systems-Pharmacology/OSPSuite-R documentation built on Feb. 14, 2025, 4:48 p.m.