File: futureOf.R

package info (click to toggle)
r-cran-future 1.11.1.1%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 1,380 kB
  • sloc: sh: 14; makefile: 2
file content (121 lines) | stat: -rw-r--r-- 3,622 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
#' Get the future of a future variable
#'
#' Get the future of a future variable that has been created directly
#' or indirectly via \code{\link{future}()}.
#'
#' @param var the variable.  If NULL, all futures in the
#' environment are returned.
#' @param envir the environment where to search from.
#' @param mustExist If TRUE and the variable does not exists, then
#' an informative error is thrown, otherwise NA is returned.
#' @param default the default value if future was not found.
#' @param drop if TRUE and \code{var} is NULL, then returned list
#' only contains futures, otherwise also \code{default} values.
#'
#' @return A \link{Future} (or \code{default}).
#' If \code{var} is NULL, then a named list of Future:s are returned.
#'
#' @example incl/futureOf.R
#'
#' @export
#' @importFrom listenv map parse_env_subset
futureOf <- function(var = NULL, envir = parent.frame(), mustExist = TRUE, default = NA, drop = FALSE) {
  ## Argument 'expr':
  expr <- substitute(var)


  ## Inspect by expression?
  if (!is.null(expr)) {
    target <- parse_env_subset(expr, envir = envir, substitute = FALSE)
    future <- get_future(target, mustExist = mustExist)
    return(future)
  }


  ## Otherwise, inspect all variables in environment
  if (inherits(envir, "listenv")) {
    map <- map(envir)
    res <- list()
    length(res) <- length(map)
    names(res) <- names(map)

    for (idx in seq_along(res)) {
      target <- parse_env_subset(idx, envir = envir, substitute = FALSE)
      future <- get_future(target, mustExist = FALSE, default = default)
      if (!is.null(future) || !is.atomic(future) || !is.na(future)) {
        res[[idx]] <- future
      }
    }
  } else {
    ## names(x) is only supported in R (>= 3.2.0)
    vars <- ls(envir = envir, all.names = TRUE)
    vars <- grep("^.future_", vars, invert = TRUE, value = TRUE)
    res <- lapply(vars, FUN = function(var) {
      target <- parse_env_subset(var, envir = envir, substitute = FALSE)
      get_future(target, mustExist = FALSE, default = default)
    })
    names(res) <- vars
  }

  ## Keep only futures?
  if (drop && length(res) > 0) {
    keep <- sapply(res, FUN = inherits, "Future")
    res <- res[keep]
  } else {
    ## Preserve dimensions
    dim <- dim(envir)
    if (!is.null(dim)) {
      dim(res) <- dim
      dimnames(res) <- dimnames(envir)
    }
  }

  res
}


get_future <- function(target, mustExist = TRUE, default = NA) {
  res <- default

  if (!target$exists) {
    msg <- sprintf("No such future variable: %s", target$code)
    if (mustExist) {
      mdebug("ERROR: %s", msg)
      stop(msg, call. = FALSE)
    }
    attr(res, "reason") <- msg
    return(res)
  }

  envir <- target$envir
  envirName <- environmentName(envir)
  if (!nzchar(envirName)) envirName <- "<noname>"

  ## (a) Check if element is a future promise
  if (inherits(envir, "listenv")) {
    map <- map(envir)
    name <- map[target$idx]
  } else {
    name <- target$name
  }
  future_name <- sprintf(".future_%s", name)
  if (exists(future_name, envir = envir, inherits = FALSE)) {
    return(get(future_name, envir = envir, inherits = FALSE))
  }

  ## (b) Check if element itself is a future object
  if (exists(name, envir = envir, inherits = FALSE)) {
    future <- get(name, envir = envir, inherits = FALSE)
    if (inherits(future, "Future")) return(future)
  }

  ## Not found
  msg <- sprintf("Future (%s) not found in %s %s: %s", sQuote(name), class(envir)[1], sQuote(envirName), sQuote(target$code))
  if (mustExist) {
    mdebug("ERROR: %s", msg)
    stop(msg, call. = FALSE)
  }

  attr(res, "reason") <- msg
  res
} # get_future()