Fix task decoration in ProgressTrackingContext

NEWS.md

@@ -1,6 +1,10 @@
 # Development
 
 ## Added
+- Add exception `Exception$primitive_as_task_not_allowed` for trying to decorate
+  primitive functions with progress tracking in the `ProgressTrackingContext`
+  class.
+- Add helper `Helper$is_of_class` to check if an object is of a given class.
 - Add optional arguments to the `get_output` operation of `SyncBackend` for
   consistency.
 - Add more tests to improve coverage.
@@ -24,6 +28,12 @@
   operation.
 
 ## Fixed
+- Update `.decorate` method of `ProgressTrackingContext` to be more flexible.
+  More specifically, the method will now throw when primitive functions are
+  provided for decoration. The method can now handle both inline functions
+  (i.e., `function(x) x`) and functions that have a body defined in terms of
+  compound expressions (i.e., `function(x) { x }`). Closes
+  [#32](https://github.com/mihaiconstantin/parabar/issues/32).
 - Fix the `export` operation in the `SyncBackend` and `Context` classes to
   fallback to the parent environment if the argument `environment` is not
   provided.

R/Exception.R

@@ -21,6 +21,7 @@
 #'   \item{\code{Exception$temporary_file_creation_failed()}}{Exception for reading results while an asynchronous task is running.}
 #'   \item{\code{Exception$type_not_assignable()}}{Exception for when providing incorrect object types.}
 #'   \item{\code{Exception$unknown_package_option()}}{Exception for when requesting unknown package options.}
+#'   \item{\code{Exception$primitive_as_task_not_allowed()}}{Exception for when decorating primitive functions with progress tracking.}
 #' }
 #'
 #' @export
@@ -116,3 +117,13 @@ Exception$unknown_package_option <- function(option) {
     # Throw the error.
     stop(message, call. = FALSE)
 }
+
+# Exception for trying to decorate a primitive in a progress tracking context.
+Exception$primitive_as_task_not_allowed <- function() {
+    # Construct exception message.
+    message = paste0("Cannot decorate primitive function with progress tracking.")
+
+    # Throw the error.
+    stop(message, call. = FALSE)
+}
+

R/Helper.R

@@ -9,6 +9,7 @@
 #' @format
 #' \describe{
 #'   \item{\code{Helper$get_class_name()}}{Helper for getting the class of a given object.}
+#'   \item{\code{Helper$is_of_class()}}{Check if an object is of a certain class.}
 #'   \item{\code{Helper$get_option()}}{Get package option, or corresponding default value.}
 #'   \item{\code{Helper$set_option()}}{Set package option.}
 #'   \item{\code{Helper$check_object_type()}}{Check the type of a given object.}
@@ -24,6 +25,11 @@ Helper$get_class_name <- function(object) {
     return(class(object)[1])
 }
 
+# Helper to check if object is of certain class.
+Helper$is_of_class <- function(object, class) {
+    return(class(object)[1] == class)
+}
+
 # Get package option, or corresponding default value.
 Helper$get_option <- function(option) {
     # Get the `Options` instance from the global options, or create a new one.

R/ProgressTrackingContext.R

@@ -120,6 +120,15 @@ ProgressTrackingContext <- R6::R6Class("ProgressTrackingContext",
         # Progress bar configuration.
         .bar_config = list(),
 
+        # Validate the type of task provided.
+        .validate_task = function(task) {
+            # If the task is a primitive.
+            if (is.primitive(task)) {
+                # Then throw an exception.
+                Exception$primitive_as_task_not_allowed()
+            }
+        },
+
         # Create a temporary file to log progress from backend tasks.
         .make_log = function() {
             # Get a temporary file name (i.e., OS specific) or a fixed one.
@@ -140,21 +149,15 @@ ProgressTrackingContext <- R6::R6Class("ProgressTrackingContext",
 
         # Decorate task function to log the progress after each execution.
         .decorate = function(task, log) {
-            # Determine file log lock path.
-            log_lock_path <- paste0(log, ".lock")
+            # Validate the task function provided.
+            private$.validate_task(task)
 
-            # Get the body of the function to patch.
-            fun_body <- body(task)
-
-            # Get the length of the body.
-            length_fun_body <- length(fun_body)
-
-            # Insert the expression.
-            fun_body[[length_fun_body + 1]] <- bquote(
-                # The injected expression.
+            # Create the language construct to inject.
+            injection <- bquote(
+                # The injected expression to run after each task execution.
                 on.exit({
                     # Acquire an exclusive lock.
-                    log_lock <- filelock::lock(.(log_lock_path))
+                    log_lock <- filelock::lock(.(paste0(log, ".lock")))
 
                     # Write the line.
                     cat("\n", file = .(log), sep = "", append = TRUE)
@@ -164,11 +167,29 @@ ProgressTrackingContext <- R6::R6Class("ProgressTrackingContext",
                 })
             )
 
-            # Reorder the body.
-            fun_body <- fun_body[c(1, (length_fun_body + 1), 2:length_fun_body)]
+            # Capture the task body.
+            task_body <- body(task)
 
-            # Attach the function body and return it.
-            body(task) <- fun_body
+            # If the body is a call wrapped in a `{` primitive.
+            if (Helper$is_of_class(task_body, "{")) {
+                # Remove the `{` call.
+                task_body <- as.list(task_body)[-1]
+            }
+
+            # Update the body of the task function.
+            body(task) <- as.call(
+                # Coerce the elements to a `list` mode.
+                c(
+                    # Specify the function part.
+                    as.symbol("{"),
+
+                    # Provide the injection.
+                    injection,
+
+                    # The task body.
+                    task_body
+                )
+            )
 
             return(task)
         },

tests/testthat/helpers.R

@@ -68,6 +68,17 @@ task_is_running <- function(backend) {
     return(status)
 }
 
+# Check if the body of a decorated tasks contains a specific pattern.
+body_contains <- function(task, pattern, position = 2) {
+    # Get the body of the decorated task at a specific position.
+    extraction <- as.list(body(task))[position]
+
+    # Check if the body at position contains the pattern.
+    contains <- grepl(pattern, extraction)
+
+    return(contains)
+}
+
 #endregion
 
 
@@ -697,6 +708,11 @@ ProgressTrackingContextTester <- R6::R6Class("ProgressTrackingContextTester",
         # Wrapper to expose `.make_log` for testing.
         make_log = function() {
             private$.make_log()
+        },
+
+        # Wrapper to expose the `.decorate` for testing.
+        decorate = function(task, log) {
+            private$.decorate(task, log)
         }
     ),
 

tests/testthat/test-progress-tracking-context.R

@@ -144,6 +144,45 @@ test_that("'ProgressTrackingContext' correctly creates log files.", {
 })
 
 
+test_that("'ProgressTrackingContext' decorates tasks with progress tracking correctly", {
+    # Create a progress tracking context object.
+    context <- ProgressTrackingContextTester$new()
+
+    # Pick a specific log path.
+    log <- "/some/parabar/log/path"
+
+    # Decorate a function with compound expression body (i.e., `{`).
+    decorated_task <- context$decorate(task = function(x) { x + 1 }, log = log)
+
+    # Expect correct decoration for compound expressions.
+    expect_true(body_contains(decorated_task, pattern = log, position = 2))
+
+    # Decorate an inline function.
+    decorated_task <- context$decorate(task = function(x) x + 1, log = log)
+
+    # Expect correct decoration for inline functions.
+    expect_true(body_contains(decorated_task, pattern = log, position = 2))
+
+    # Decorate a `base` method that uses method dispatching.
+    decorated_task <- context$decorate(task = base::mean, log = log)
+
+    # Expect correct decoration for `base` methods.
+    expect_true(body_contains(decorated_task, pattern = log, position = 2))
+
+    # Expect the decoration to fail for primitive functions.
+    expect_error(
+        context$decorate(task = sum, log = log),
+        as_text(Exception$primitive_as_task_not_allowed())
+    )
+
+    # Decorate a wrapped primitive function.
+    decorated_task <- context$decorate(task = function(x) sum(x), log = log)
+
+    # Expect correct decoration for wrapped primitive functions.
+    expect_true(body_contains(decorated_task, pattern = log, position = 2))
+})
+
+
 test_that("'ProgressTrackingContext' executes the task in parallel correctly", {
     # Create a specification.
     specification <- Specification$new()