Hinzufügen einer Fortschrittsbalken zu Boot-Funktion in R

Question

Ich versuche, eine Fortschrittsbalken zu einer Bootstrap-Funktion in R hinzufügen. Ich habe versucht, die Beispielfunktion so einfach wie möglich zu machen (daher verwende ich in diesem Beispiel Mittelwert) .

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) 

Die Bootstrap richtig funktioniert, aber das Problem ist, dass der Wert von rep_count nicht in der Schleife nicht erhöht und die Fortschrittsbalken bleiben während des Prozesses eingefroren.

Wenn ich den Wert von rep_count nach dem Bootstrap-Check abgeschlossen ist, ist es immer noch 1.

Was mache ich falsch? vielleicht die boot-funktion nicht einfach die m.boot funktion in eine schleife und so die variablen darin sind nicht erhöht?

Vielen Dank.

Answer 1

Das pbapply Paket wurde entwickelt, um mit vektorisierten Funktionen zu arbeiten. Im Zusammenhang mit dieser Frage gibt es zwei Möglichkeiten, dies zu erreichen: (1) Schreiben eines Wrappers wie vorgeschlagen, der nicht das gleiche Objekt der Klasse 'boot' erzeugt; (2) alternativ kann die Zeile lapply(seq_len(RR), fn) als pblapply(seq_len(RR), fn) geschrieben werden. Option 2 kann entweder durch lokales Kopieren/Aktualisieren der boot-Funktion, wie im folgenden Beispiel gezeigt, oder durch die Frage des Paketbetreuers Brian Ripley, ob er in Betracht ziehen würde, einen Fortschrittsbalken direkt oder über pbapply als Abhängigkeit hinzuzufügen.

Meine Lösung (Änderungen von Kommentaren angezeigt):

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

Die erhöhte ist eine lokale Variable und ging nach jedem Funktionsaufruf verloren. In der nächsten Iteration wird die Funktion rep_count aus der globalen Umwelt wieder, das heißt, sein Wert ist 1.

können Sie verwenden <<-:

rep_count <<- rep_count + 1 

Dies weist die rep_count zuerst auf dem Suchpfad außerhalb der gefunden Funktion. Natürlich wird die Verwendung von <<- normalerweise nicht empfohlen, da Nebenwirkungen von Funktionen vermieden werden sollten, aber hier haben Sie einen legitimen Anwendungsfall. Sie sollten das Ganze jedoch wahrscheinlich in eine Funktion einfügen, um eine Nebenwirkung auf die globale Umgebung zu vermeiden.

Es könnte bessere Lösungen sein ...

Answer 3

Sie das Paket 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

Ich glaube, ich eine mögliche Lösung gefunden verwenden können. Dies verbindet die Antwort von @Roland mit der Bequemlichkeit des pbapply Pakets, seine Funktionen startpb(), closepb(), etc ..

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 

Wie bereits angedeutet, alles in einer Funktion Umwickeln verhindert mit den rep_count variablen Messing.