Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

303 obs map to shape #351

Merged
merged 4 commits into from
Jul 29, 2022
Merged

303 obs map to shape #351

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
65902b6
Fixes #303 observed data map to shape
pchelle Jul 29, 2022
5db1f17
Fixes #346 remove dynamic code
pchelle Jul 29, 2022
2917f8c
Update documentation with latest roxygen
pchelle Jul 29, 2022
f310f9d
format with styler
IndrajeetPatil Jul 29, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions DESCRIPTION
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,5 +100,6 @@ Collate:
'utilities-label.R'
'utilities-legend.R'
'utilities-mapping.R'
'utilities-molecule-plots.R'
'utilities-theme.R'
'utils.R'
219 changes: 46 additions & 173 deletions R/aaa-utilities.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
}
32 changes: 16 additions & 16 deletions R/atom-plots.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -184,7 +184,7 @@ addScatter <- function(data = NULL,
newLabels = newLabels,
aestheticSelections = plotConfiguration$points
))
eval(.parseUpdateAxes())
plotObject <- .updateAxes(plotObject)
return(plotObject)
}

Expand Down Expand Up @@ -362,7 +362,7 @@ addLine <- function(data = NULL,
newLabels = newLabels,
aestheticSelections = plotConfiguration$lines
))
eval(.parseUpdateAxes())
plotObject <- .updateAxes(plotObject)
return(plotObject)
}

Expand Down Expand Up @@ -495,7 +495,7 @@ addRibbon <- function(data = NULL,
newLabels = newLabels,
aestheticSelections = plotConfiguration$ribbons
))
eval(.parseUpdateAxes())
plotObject <- .updateAxes(plotObject)
return(plotObject)
}

Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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
),
Expand All @@ -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
Expand All @@ -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)
}

Expand Down
44 changes: 26 additions & 18 deletions R/datamapping-range.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)) {
Expand Down
Loading