Fixes Open-Systems-Pharmacology#280 background elements defined a priori

This allows to switch off grid at creation of plot configuration
pchelle · May 19, 2022 · e2a663c · e2a663c
1 parent ccf3ff9
commit e2a663c
Show file tree

Hide file tree

Showing 2 changed files with 48 additions and 28 deletions.
diff --git a/R/plotconfiguration-background.R b/R/plotconfiguration-background.R
@@ -37,8 +37,8 @@ BackgroundConfiguration <- R6::R6Class(
       eval(validateAreaExpression)
       eval(validateLineExpression)
 
-      setAreaExpression <- parse(text = paste0("private$.", areaFieldNames, " <- ", areaFieldNames, " %||% currentTheme$background$", areaFieldNames))
-      setLineExpression <- parse(text = paste0("private$.", lineFieldNames, " <- ", lineFieldNames, " %||% currentTheme$background$", lineFieldNames))
+      setAreaExpression <- parse(text = paste0("self$", areaFieldNames, " <- ", areaFieldNames, " %||% currentTheme$background$", areaFieldNames))
+      setLineExpression <- parse(text = paste0("self$", lineFieldNames, " <- ", lineFieldNames, " %||% currentTheme$background$", lineFieldNames))
       eval(setAreaExpression)
       eval(setLineExpression)
     },
@@ -75,27 +75,51 @@ BackgroundConfiguration <- R6::R6Class(
     },
     #' @field plot `BackgroundElement` object
     plot = function(value) {
-      requestOnElement(private$.plot, value)
+      if (missing(value)) { 
+        return(private$.plot) 
+      } 
+      validateIsOfType(value, "BackgroundElement", nullAllowed = TRUE) 
+      private$.plot <- value %||% private$.plot
     },
     #' @field panel `BackgroundElement` object
     panel = function(value) {
-      requestOnElement(private$.panel, value)
+      if (missing(value)) { 
+        return(private$.panel) 
+      } 
+      validateIsOfType(value, "BackgroundElement", nullAllowed = TRUE) 
+      private$.panel <- value %||% private$.panel
     },
     #' @field xAxis `LineElement` object
     xAxis = function(value) {
-      requestOnElement(private$.xAxis, value)
+      if (missing(value)) { 
+        return(private$.xAxis) 
+      } 
+      validateIsOfType(value, "LineElement", nullAllowed = TRUE) 
+      private$.xAxis <- value %||% private$.xAxis
     },
     #' @field yAxis `LineElement` object
     yAxis = function(value) {
-      requestOnElement(private$.yAxis, value)
+      if (missing(value)) { 
+        return(private$.yAxis) 
+      } 
+      validateIsOfType(value, "LineElement", nullAllowed = TRUE) 
+      private$.yAxis <- value %||% private$.yAxis
     },
     #' @field xGrid `LineElement` object
     xGrid = function(value) {
-      requestOnElement(private$.xGrid, value)
+      if (missing(value)) { 
+        return(private$.xGrid) 
+      } 
+      validateIsOfType(value, "LineElement", nullAllowed = TRUE) 
+      private$.xGrid <- value %||% private$.xGrid
     },
     #' @field yGrid `LineElement` object
     yGrid = function(value) {
-      requestOnElement(private$.yGrid, value)
+      if (missing(value)) { 
+        return(private$.yGrid) 
+      } 
+      validateIsOfType(value, "LineElement", nullAllowed = TRUE) 
+      private$.yGrid <- value %||% private$.yGrid
     }
   ),
   private = list(
@@ -180,23 +204,3 @@ LineElement <- R6::R6Class(
     }
   )
 )
-
-#' @keywords internal
-requestOnElement <- function(field, value) {
-  if (missing(value)) {
-    return(field)
-  }
-  # Update the element partially in case of names list
-  if (isOfType(value, "list")) {
-    for (fieldName in c("color", "size", "linetype")) {
-      field[[fieldName]] <- value[[fieldName]] %||% field[[fieldName]]
-    }
-    if (isOfType(field, "BackgroundElement")) {
-      field[["fill"]] <- value[["fill"]] %||% field[["fill"]]
-    }
-  }
-  # Or update the whole element R6 object is used
-  if (isOfType(value, "BackgroundElement")) {
-    field <- value
-  }
-}
diff --git a/tests/testthat/test-plot-configuration.R b/tests/testthat/test-plot-configuration.R
@@ -1,5 +1,21 @@
 context("Plot Configuration")
 
+test_that("Background properties can be defined a priori", {
+  plotArea <- BackgroundElement$new(color = "blue", linetype = "twodash", fill = "yellow")
+  panelArea <- LineElement$new(color = "red", linetype = "dotdash", fill = "pink")
+  backgroundPlotConfiguration <- PlotConfiguration$new(plotArea = plotArea, panelArea = panelArea)
+
+  expect_equal(backgroundPlotConfiguration$background$plot, plotArea)
+  expect_equal(backgroundPlotConfiguration$background$panel, panelArea)
+
+  xGrid <- LineElement$new(color = "blue", linetype = "twodash")
+  yGrid <- LineElement$new(color = "red", linetype = "dotdash")
+  gridPlotConfiguration <- PlotConfiguration$new(xGrid = xGrid, yGrid = yGrid)
+
+  expect_equal(gridPlotConfiguration$background$xGrid, xGrid)
+  expect_equal(gridPlotConfiguration$background$yGrid, yGrid)
+})
+
 # Create a reference plot configuration
 refPlotConfiguration <- PlotConfiguration$new()
 for(property in AestheticProperties){