File: temp_registry.R

package info (click to toggle)
r-cran-future.batchtools 0.10.0%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 436 kB
  • sloc: sh: 54; makefile: 2
file content (123 lines) | stat: -rw-r--r-- 4,084 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
#' @importFrom batchtools makeRegistry saveRegistry
temp_registry <- local({
  ## All known batchtools registries
  regs <- new.env()

  make_registry <- function(cluster.functions = NULL, config = list(), ...) {
    ## Temporarily disable batchtools output?
    ## (i.e. messages and progress bars)
    debug <- getOption("future.debug", FALSE)
    batchtools_output <- getOption("future.batchtools.output", debug)

    work.dir <- config$work.dir
    if (is.null(work.dir)) work.dir <- getwd()
    config$work.dir <- NULL
    
    if (!batchtools_output) {
      oopts <- options(batchtools.verbose = FALSE, batchtools.progress = FALSE)
      on.exit(options(oopts))
    }

    reg <- makeRegistry(work.dir = work.dir, ...)

    if (!is.null(cluster.functions)) {    ### FIXME
      reg$cluster.functions <- cluster.functions
    }

    ## Post-tweak the batchtools registry?
    ## This avoids having to set up a custom batchtools 'conf.file' etc.
    if (length(config) > 0L) {
      names <- names(config)
      for (name in names) reg[[name]] <- config[[name]]
      saveRegistry(reg)
    }
    
    reg
  } ## make_registry()

  function(label = "batchtools", path = NULL, config = list(), ...) {
    if (is.null(label)) label <- "batchtools"
    ## The job label (the name on the job queue) - may be duplicated
    label <- as.character(label)
    stop_if_not(length(label) == 1L, nchar(label) > 0L)

    ## This session's path holding all of its future batchtools directories
    ##   e.g. .future/<datetimestamp>-<unique_id>/
    if (is.null(path)) path <- future_cache_path()

    if (length(config) > 0L) {
      stop_if_not(is.list(config))
      names <- names(config)
      stop_if_not(!is.null(names), all(nzchar(names)))
    }

    ## The batchtools subfolder for a specific future - must be unique
    prefix <- sprintf("%s_", label)

    ## FIXME: We need to make sure 'prefix' consists of only valid
    ## filename characters. /HB 2016-10-19
    prefix <- as_valid_directory_prefix(prefix)

    unique <- FALSE
    while (!unique) {
      ## The FutureRegistry key for this batchtools future - must be unique
      key <- tempvar(prefix = prefix, value = NA, envir = regs)
      ## The directory for this batchtools future
      ##   e.g. .future/<datetimestamp>-<unique_id>/<key>/
      path_registry <- file.path(path, key)
      ## Should not happen, but just in case.
      unique <- !file.exists(path_registry)
    }

    ## FIXME: We need to make sure 'label' consists of only valid
    ## batchtools ID characters, i.e. it must match regular
    ## expression "^[a-zA-Z]+[0-9a-zA-Z_]*$".
    ## /HB 2016-10-19
    reg_id <- as_valid_registry_id(label)
    make_registry(file.dir = path_registry, config = config, ...)
  }
})



drop_non_valid_characters <- function(name, pattern, default = "batchtools") {
  as_string <- (length(name) == 1L)
  name <- unlist(strsplit(name, split = "", fixed = TRUE), use.names = FALSE)
  name[!grepl(pattern, name)] <- ""
  if (length(name) == 0L) return(default)
  if (as_string) name <- paste(name, collapse = "")
  name
}

as_valid_directory_prefix <- function(name) {
  pattern <- "^[-._a-zA-Z0-9]+$"
  ## Nothing to do?
  if (grepl(pattern, name)) return(name)
  name <- unlist(strsplit(name, split = "", fixed = TRUE), use.names = FALSE)
  ## All characters must be letters, digits, underscores, dash, or period.
  name <- drop_non_valid_characters(name, pattern = pattern)
  name <- paste(name, collapse = "")
  stop_if_not(grepl(pattern, name))
  name
}

as_valid_registry_id <- function(name) {
  pattern <- "^[a-zA-Z]+[0-9a-zA-Z_]*$"
  ## Nothing to do?
  if (grepl(pattern, name)) return(name)

  name <- unlist(strsplit(name, split = "", fixed = TRUE), use.names = FALSE)

  ## All characters must be letters, digits, or underscores
  name <- drop_non_valid_characters(name, pattern = "[0-9a-zA-Z_]")
  name <- name[nzchar(name)]

  ## First character must be a letter :/
  if (!grepl("^[a-zA-Z]+", name[1])) name[1] <- "z"

  name <- paste(name, collapse = "")

  stop_if_not(grepl(pattern, name))

  name
}