eke out minor speed gains

R/class_counter.R

@@ -28,16 +28,18 @@ counter_get_names <- function(counter) {
 }
 
 counter_exists_name <- function(counter, name) {
+  !is.null(.subset2(.subset2(counter, "envir"), name))
   exists(name, envir = counter$envir, inherits = FALSE)
 }
 
 counter_exist_names <- function(counter, names) {
+  envir <- .subset2(counter, "envir")
   as.logical(
     lapply(
       names,
-      exists,
-      envir = counter$envir,
-      inherits = FALSE
+      function(name) {
+        !is.null(envir[[name]])
+      }
     )
   )
 }

R/class_memory.R

@@ -24,13 +24,8 @@ memory_set_object <- function(memory, name, object) {
     memory$names <- c(memory$names, name)
     memory$count <- memory$count + 1L
   }
-  assign(
-    x = name,
-    value = object,
-    envir = memory$envir,
-    inherits = FALSE,
-    immediate = TRUE
-  )
+  envir <- .subset2(memory, "envir")
+  envir[[name]] <- object
 }
 
 memory_del_objects <- function(memory, names) {

R/class_metrics.R

@@ -33,11 +33,13 @@ metrics_terminated_early <- function(metrics) {
 }
 
 metrics_outcome <- function(metrics) {
-  if_any(
-    metrics_has_cancel(metrics),
-    "cancel",
-    if_any(metrics_has_error(metrics), "error", "completed")
-  )
+  if (metrics_has_cancel(metrics)) {
+    return("cancel")
+  }
+  if (metrics_has_error(metrics)) {
+    return("error")
+  }
+  "completed"
 }
 
 metrics_validate <- function(metrics) {

R/class_record.R

@@ -24,13 +24,29 @@ record_init <- function(
   warnings = NA_character_,
   error = NA_character_
 ) {
+  path <- as.character(path)
+  children <- as.character(children)
+  warnings <- as.character(warnings)
+  error <- as.character(error)
+  if (!length(path)) {
+    path <- NA_character_
+  }
+  if (!length(children)) {
+    children <- NA_character_
+  }
+  if (!length(warnings)) {
+    warnings <- NA_character_
+  }
+  if (!length(error)) {
+    error <- NA_character_
+  }
   record_new(
     name = as.character(name),
     type = as.character(type),
     command = as.character(command),
     seed = as.integer(seed),
     depend = as.character(depend),
-    path = as.character(path) %||% NA_character_,
+    path = path,
     data = as.character(data),
     time = as.character(time),
     size = as.character(size),
@@ -39,10 +55,10 @@ record_init <- function(
     repository = as.character(repository),
     iteration = as.character(iteration),
     parent = as.character(parent),
-    children = as.character(children) %||% NA_character_,
+    children = children,
     seconds = as.numeric(seconds),
-    warnings = as.character(warnings) %||% NA_character_,
-    error = as.character(error) %||% NA_character_
+    warnings = warnings,
+    error = error
   )
 }
 
@@ -121,11 +137,12 @@ record_produce_row <- function(record) {
 }
 
 record_row_path <- function(record) {
-  store <- store_init(
+  store <- store_enclass(
+    list(),
     format = record$format,
     repository = record$repository
   )
-  store_row_path(store, file_init(path = record$path))
+  store_row_path(store, list(path = record$path))
 }
 
 record_from_row <- function(row, path_store) {

R/class_store.R

@@ -4,7 +4,6 @@ store_init <- function(
   resources = list()
 ) {
   store <- store_new(
-    file = file_init(),
     resources = resources,
     methods_format = store_methods_format(format),
     methods_repository = store_methods_repository(repository)
@@ -24,13 +23,11 @@ store_mock <- function(
 }
 
 store_new <- function(
-  file = NULL,
   resources = NULL,
   methods_format = NULL,
   methods_repository = NULL
 ) {
   out <- new.env(parent = emptyenv(), hash = FALSE)
-  out$file <- file
   out$resources <- resources
   out$methods_format <- methods_format
   out$methods_repository <- methods_repository
@@ -51,12 +48,20 @@ store_enclass <- function(store, format, repository) {
 # because the responsibilities of store and format
 # would overlap too much.
 store_dispatch_format <- function(format) {
-  class <- if_any(is_format_custom(format), "format_custom", format)
+  if (is_format_custom(format)) {
+    class <- "format_custom"
+  } else {
+    class <- format
+  }
   enclass(format, class)
 }
 
 store_dispatch_repository <- function(repository) {
-  class <- if_any(is_repository_cas(repository), "repository_cas", repository)
+  if (is_repository_cas(repository)) {
+    class <- "repository_cas"
+  } else {
+    class <- repository
+  }
   enclass(repository, class)
 }
 

R/utils_hash.R

@@ -1,5 +1,4 @@
 hash_file <- function(path) {
-  stopifnot(length(path) == 1L)
   secretbase::siphash13(file = path)
 }
 

tests/performance/test-maps.R

@@ -12,7 +12,13 @@ tar_script({
   )
 })
 start <- proc.time()["elapsed"]
-px <- pprof(tar_make(reporter = "summary", callr_function = NULL))
+px <- proffer::pprof(
+  tar_make(
+    reporter = "silent",
+    seconds_meta_append = 1,
+    callr_function = NULL
+  )
+)
 message(proc.time()["elapsed"] - start)
 
 # With silent reporter