|
| 1 | +# fwb::fwb(...) => |
| 2 | +# |
| 3 | +# local({ |
| 4 | +# .progressr_steps <- R |
| 5 | +# .progressr_simple <- if (is.null(simple)) wtype != "multinom" else simple |
| 6 | +# .progressr_skip_count <- if (.progressr_simple) 2L else 1L |
| 7 | +# .progressr_progressor <- progressr::progressor(steps = .progressr_steps) |
| 8 | +# fwb::fwb( |
| 9 | +# data = x, |
| 10 | +# statistic = function(..., ...FUN, .progressr_progressor) { |
| 11 | +# if (.progressr_skip_count > 0L) { |
| 12 | +# .progressr_skip_count <<- .progressr_skip_count - 1L |
| 13 | +# } else { |
| 14 | +# on.exit(.progressr_progressor()) |
| 15 | +# } |
| 16 | +# ...FUN(...) |
| 17 | +# }, |
| 18 | +# R = .progressr_steps, |
| 19 | +# ...FUN = statistic, |
| 20 | +# .progressr_progressor = .progressr_progressor |
| 21 | +# ) |
| 22 | +# }) |
| 23 | +# |
| 24 | +progressify_fwb <- local({ |
| 25 | + template_fwb_outer <- bquote_compile(local({ |
| 26 | + .progressr_steps <- .(STEPS) |
| 27 | + .progressr_simple <- if (is.null(.(SIMPLE))) .(WTYPE) != "multinom" else .(SIMPLE) |
| 28 | + .progressr_skip_count <- if (.progressr_simple) 2L else 1L |
| 29 | + .progressr_progressor <- progressr::progressor(steps = .progressr_steps) |
| 30 | + .(EXPR) |
| 31 | + })) |
| 32 | + |
| 33 | + template_fwb_FUN <- bquote_compile(function(..., ...FUN, .progressr_progressor) { |
| 34 | + if (.progressr_skip_count > 0L) { |
| 35 | + .progressr_skip_count <<- .progressr_skip_count - 1L |
| 36 | + } else { |
| 37 | + on.exit(.progressr_progressor()) |
| 38 | + } |
| 39 | + ...FUN(...) |
| 40 | + }) |
| 41 | + |
| 42 | + function(expr, fcn_name, fcn, ..., envir = parent.frame()) { |
| 43 | + names <- names(expr) |
| 44 | + if (is.null(names)) names <- rep("", length.out = length(expr)) |
| 45 | + names <- names[-1] |
| 46 | + target_names <- names(formals(fcn))[seq_along(names)] |
| 47 | + unnamed <- setdiff(target_names, names) |
| 48 | + ## Handle '...' in formals - only resolve positional args before it |
| 49 | + ddd <- which(unnamed == "...") |
| 50 | + if (length(ddd) > 0L) { |
| 51 | + stopifnot(length(ddd) == 1L) |
| 52 | + unnamed <- unnamed[seq_len(ddd - 1L)] |
| 53 | + } |
| 54 | + empty_idxs <- which(names == "") |
| 55 | + n <- min(length(empty_idxs), length(unnamed)) |
| 56 | + if (n > 0L) names[empty_idxs[seq_len(n)]] <- unnamed[seq_len(n)] |
| 57 | + names <- c("", names) |
| 58 | + |
| 59 | + idx_R <- which(names == "R") |
| 60 | + idx_statistic <- which(names == "statistic") |
| 61 | + idx_simple <- which(names == "simple") |
| 62 | + idx_wtype <- which(names == "wtype") |
| 63 | + |
| 64 | + parts <- as.list(expr) |
| 65 | + |
| 66 | + steps <- if (length(idx_R) == 1L) parts[[idx_R]] else 999L |
| 67 | + parts[[idx_R]] <- quote(.progressr_steps) |
| 68 | + |
| 69 | + simple_expr <- if (length(idx_simple) == 1L) parts[[idx_simple]] else quote(NULL) |
| 70 | + wtype_expr <- if (length(idx_wtype) == 1L) parts[[idx_wtype]] else quote(getOption("fwb_wtype", "exp")) |
| 71 | + |
| 72 | + stopifnot(length(idx_statistic) == 1L) |
| 73 | + statistic <- expr[[idx_statistic]] |
| 74 | + parts[[idx_statistic]] <- bquote_apply(template_fwb_FUN, FUN = statistic) |
| 75 | + |
| 76 | + idx_verbose <- which(names == "verbose") |
| 77 | + if (length(idx_verbose) == 0L) { |
| 78 | + parts$verbose <- FALSE |
| 79 | + } |
| 80 | + |
| 81 | + progressr_args <- list( |
| 82 | + ...FUN = statistic, |
| 83 | + .progressr_progressor = quote(.progressr_progressor) |
| 84 | + ) |
| 85 | + parts <- c(parts, progressr_args) |
| 86 | + |
| 87 | + bquote_apply(template_fwb_outer, STEPS = steps, SIMPLE = simple_expr, WTYPE = wtype_expr, EXPR = as.call(parts)) |
| 88 | + } ## progressify_fwb() |
| 89 | +}) |
| 90 | + |
| 91 | + |
| 92 | +append_builtin_transpilers_for_fwb <- local({ |
| 93 | + known_fcns <- list( |
| 94 | + fwb = c |
| 95 | + ) |
| 96 | + |
| 97 | + template <- bquote_compile(function(expr, options) { |
| 98 | + ns <- getNamespace("fwb") |
| 99 | + fcn <- get(.(fcn_name), mode = "function", envir = ns) |
| 100 | + progressify_fwb(expr, fcn_name = .(fcn_name), fcn = fcn, envir = parent.frame()) |
| 101 | + }) |
| 102 | + |
| 103 | + make_transpiler <- function(fcn_name) { |
| 104 | + transpiler <- eval(bquote_apply(template)) |
| 105 | + eval(transpiler) |
| 106 | + } |
| 107 | + |
| 108 | + function() { |
| 109 | + ## fwb::fwb() |
| 110 | + transpilers <- list() |
| 111 | + for (fcn_name in names(known_fcns)) { |
| 112 | + transpilers[[fcn_name]] <- list( |
| 113 | + label = sprintf("fwb::%s() transpiler", fcn_name), |
| 114 | + transpiler = make_transpiler(fcn_name) |
| 115 | + ) |
| 116 | + } ## for (fcn_name ...) |
| 117 | + transpilers <- list(fwb = transpilers) |
| 118 | + |
| 119 | + append_transpilers("progressify::built-in", transpilers) |
| 120 | + |
| 121 | + ## Return required packages |
| 122 | + c("fwb", "progressr") |
| 123 | + } |
| 124 | +}) |
0 commit comments