Добавить индикатор выполнения для загрузки функции в R

Question

Я пытаюсь добавить индикатор выполнения в функцию начальной загрузки в R. Я попытался сделать пример функции максимально простой (следовательно, я использую среднее значение в этом примере) ,

library(boot) 
v1 <- rnorm(1000) 
rep_count = 1 

m.boot <- function(data, indices) { 
    d <- data[indices] 
    setWinProgressBar(pb, rep_count) 
    rep_count <- rep_count + 1 
    Sys.sleep(0.01) 
    mean(d, na.rm = T) 
    } 

tot_rep <- 200 
pb <- winProgressBar(title = "Bootstrap in progress", label = "", 
        min = 0, max = tot_rep, initial = 0, width = 300) 
b <- boot(v1, m.boot, R = tot_rep) 
close(pb) 

Функция бутстраповской правильно, но проблема в том, что значение rep_count не увеличивается в цикле и индикатор остается замороженным в процессе.

Если я проверяю значение rep_count после начальной загрузки будет завершена, он по-прежнему 1.

Что я делаю неправильно? возможно, функция загрузки не просто вставляет функцию m.boot в цикл, и поэтому переменные в ней не увеличиваются?

спасибо.

Answer 1

pbapply пакет был разработан для работы с векторизованными функциями. Есть два способа добиться этого в контексте этого вопроса: (1) напишите обертку, как было предложено, что не даст тот же объект класса 'boot'; (2) в качестве альтернативы, строка lapply(seq_len(RR), fn) может быть записана как pblapply(seq_len(RR), fn). Вариант 2 может произойти либо путем локального копирования/обновления функции boot, как показано в приведенном ниже примере, либо попросить сопровождающего пакета Брайана Рипли, если он рассмотрит возможность добавления строки выполнения непосредственно или через pbapply в качестве зависимости.

Мое решение (изменения, указанные комментарии):

library(boot) 
library(pbapply) 
boot2 <- function (data, statistic, R, sim = "ordinary", stype = c("i", 
    "f", "w"), strata = rep(1, n), L = NULL, m = 0, weights = NULL, 
    ran.gen = function(d, p) d, mle = NULL, simple = FALSE, ..., 
    parallel = c("no", "multicore", "snow"), ncpus = getOption("boot.ncpus", 
     1L), cl = NULL) 
{ 
call <- match.call() 
stype <- match.arg(stype) 
if (missing(parallel)) 
    parallel <- getOption("boot.parallel", "no") 
parallel <- match.arg(parallel) 
have_mc <- have_snow <- FALSE 
if (parallel != "no" && ncpus > 1L) { 
    if (parallel == "multicore") 
     have_mc <- .Platform$OS.type != "windows" 
    else if (parallel == "snow") 
     have_snow <- TRUE 
    if (!have_mc && !have_snow) 
     ncpus <- 1L 
    loadNamespace("parallel") 
} 
if (simple && (sim != "ordinary" || stype != "i" || sum(m))) { 
    warning("'simple=TRUE' is only valid for 'sim=\"ordinary\", stype=\"i\", n=0', so ignored") 
    simple <- FALSE 
} 
if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) 
    runif(1) 
seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE) 
n <- NROW(data) 
if ((n == 0) || is.null(n)) 
    stop("no data in call to 'boot'") 
temp.str <- strata 
strata <- tapply(seq_len(n), as.numeric(strata)) 
t0 <- if (sim != "parametric") { 
    if ((sim == "antithetic") && is.null(L)) 
     L <- empinf(data = data, statistic = statistic, stype = stype, 
      strata = strata, ...) 
    if (sim != "ordinary") 
     m <- 0 
    else if (any(m < 0)) 
     stop("negative value of 'm' supplied") 
    if ((length(m) != 1L) && (length(m) != length(table(strata)))) 
     stop("length of 'm' incompatible with 'strata'") 
    if ((sim == "ordinary") || (sim == "balanced")) { 
     if (isMatrix(weights) && (nrow(weights) != length(R))) 
      stop("dimensions of 'R' and 'weights' do not match") 
    } 
    else weights <- NULL 
    if (!is.null(weights)) 
     weights <- t(apply(matrix(weights, n, length(R), 
      byrow = TRUE), 2L, normalize, strata)) 
    if (!simple) 
     i <- index.array(n, R, sim, strata, m, L, weights) 
    original <- if (stype == "f") 
     rep(1, n) 
    else if (stype == "w") { 
     ns <- tabulate(strata)[strata] 
     1/ns 
    } 
    else seq_len(n) 
    t0 <- if (sum(m) > 0L) 
     statistic(data, original, rep(1, sum(m)), ...) 
    else statistic(data, original, ...) 
    rm(original) 
    t0 
} 
else statistic(data, ...) 
pred.i <- NULL 
fn <- if (sim == "parametric") { 
    ran.gen 
    data 
    mle 
    function(r) { 
     dd <- ran.gen(data, mle) 
     statistic(dd, ...) 
    } 
} 
else { 
    if (!simple && ncol(i) > n) { 
     pred.i <- as.matrix(i[, (n + 1L):ncol(i)]) 
     i <- i[, seq_len(n)] 
    } 
    if (stype %in% c("f", "w")) { 
     f <- freq.array(i) 
     rm(i) 
     if (stype == "w") 
      f <- f/ns 
     if (sum(m) == 0L) 
      function(r) statistic(data, f[r, ], ...) 
     else function(r) statistic(data, f[r, ], pred.i[r, 
      ], ...) 
    } 
    else if (sum(m) > 0L) 
     function(r) statistic(data, i[r, ], pred.i[r, ], 
      ...) 
    else if (simple) 
     function(r) statistic(data, index.array(n, 1, sim, 
      strata, m, L, weights), ...) 
    else function(r) statistic(data, i[r, ], ...) 
} 
RR <- sum(R) 
res <- if (ncpus > 1L && (have_mc || have_snow)) { 
    if (have_mc) { 
     parallel::mclapply(seq_len(RR), fn, mc.cores = ncpus) 
    } 
    else if (have_snow) { 
     list(...) 
     if (is.null(cl)) { 
      cl <- parallel::makePSOCKcluster(rep("localhost", 
       ncpus)) 
      if (RNGkind()[1L] == "L'Ecuyer-CMRG") 
       parallel::clusterSetRNGStream(cl) 
      res <- parallel::parLapply(cl, seq_len(RR), fn) 
      parallel::stopCluster(cl) 
      res 
     } 
     else parallel::parLapply(cl, seq_len(RR), fn) 
    } 
} 
else pblapply(seq_len(RR), fn) #### changed !!! 
t.star <- matrix(, RR, length(t0)) 
for (r in seq_len(RR)) t.star[r, ] <- res[[r]] 
if (is.null(weights)) 
    weights <- 1/tabulate(strata)[strata] 
boot.return(sim, t0, t.star, temp.str, R, data, statistic, 
    stype, call, seed, L, m, pred.i, weights, ran.gen, mle) 
} 
## Functions not exported by boot 
isMatrix <- boot:::isMatrix 
index.array <- boot:::index.array 
boot.return <- boot:::boot.return 
## Now the example 
m.boot <- function(data, indices) { 
    d <- data[indices] 
    mean(d, na.rm = T) 
} 
tot_rep <- 200 
v1 <- rnorm(1000) 
b <- boot2(v1, m.boot, R = tot_rep) 

Answer 2

Увеличенная rep_count является локальной переменной и утеряна после каждого вызова функции. В следующей итерации функция получает rep_count от глобальной окружающей среды снова, то есть, его значение равно 1.

Вы можете использовать <<-:

rep_count <<- rep_count + 1 

Это сопоставляет rep_count первым нашел на пути поиска вне функция. Конечно, использование <<- обычно не рекомендуется, потому что следует избегать побочных эффектов функций, но здесь у вас есть законный прецедент. Тем не менее, вы должны, вероятно, включить все это в функцию, чтобы избежать побочного эффекта для глобальной среды.

Там могут быть лучшие решения ...

Answer 3

Вы можете использовать пакет pbapply

library(boot) 
library(pbapply) 
v1 <- rnorm(1000) 
rep_count = 1 

# your m.boot function .... 
m.boot <- function(data, indices) { 
            d <- data[indices] 
            mean(d, na.rm = T) 
            } 

# ... wraped in `bootfunc` 
bootfunc <- function(x) { boot(x, m.boot, R = 200) } 

# apply function to v1 , returning progress bar 
pblapply(v1, bootfunc) 

# > b <- pblapply(v1, bootfunc) 
# > |++++++++++++++++++++++++++++++++++++++++++++++++++| 100% Elapsed time: 02s 

Answer 4

Я думаю, что я нашел возможное решение. Это сливает ответ @Roland с удобством pbapply пакета, используя свои функции startpb(), closepb() и т.д ..

library(boot) 
library(pbapply) 

v1 <- rnorm(1000) 
rep_count = 1 
tot_rep = 200 

m.boot <- function(data, indices) { 
    d <- data[indices] 
    setpb(pb, rep_count) 
    rep_count <<- rep_count + 1 
    Sys.sleep(0.01)    #Just to slow down the process 
    mean(d, na.rm = T) 
} 

pb <- startpb(min = 0, max = tot_rep) 
b <- boot(v1, m.boot, R = tot_rep) 
closepb(pb) 
rep_count = 1 

Как предполагалось ранее, обернув все в функции позволяет избежать баловаться с переменной rep_count.