txtProgressBar per bootstrap parallelo non visualizzato correttamente

Question

Di seguito è riportato un MWE del mio problema: ho programmato una barra di avanzamento per alcune funzioni utilizzando il bootstrap (tramite la funzione di avvio dal pacchetto di avvio).

Questo funziona bene finché non utilizzo l'elaborazione parallela (res_1core di seguito). Se desidero utilizzare l'elaborazione parallela impostando parallel = "multicore" e ncpus = 2, la barra di avanzamento non viene visualizzata correttamente (res_2core di seguito).

library(boot) 

rsq <- function(formula, data, R, parallel = c("no", "multicore", "snow"), ncpus = 1) { 
    env <- environment() 
    counter <- 0 
    progbar <- txtProgressBar(min = 0, max = R, style = 3) 
    bootfun <- function(formula, data, indices) { 
    d <- data[indices,] 
    fit <- lm(formula, data = d) 
    curVal <- get("counter", envir = env) 
    assign("counter", curVal + 1, envir = env) 
    setTxtProgressBar(get("progbar", envir = env), curVal + 1) 
    return(summary(fit)$r.square) 
    } 
    res <- boot(data = data, statistic = bootfun, R = R, formula = formula, parallel = parallel, ncpus = ncpus) 
    return(res) 
} 

res_1core <- rsq(mpg ~ wt + disp, data = mtcars, R = 1000) 
res_2core <- rsq(mpg ~ wt + disp, data = mtcars, R = 1000, parallel = "multicore", ncpus = 2) 

Ho letto che questo è legato al fatto che la funzione di avvio invita lapply per singolo core e mclapply per l'elaborazione multicore. Qualcuno sa di una soluzione facile per affrontare questo? Voglio dire, vorrei mostrare i progressi tenendo conto di tutti i processi paralleli.

Aggiornamento

Grazie all'ingresso di Karolis Koncevičius, ho trovato una soluzione alternativa (basta utilizzare la versione aggiornata di rsq funzione qui sotto):

rsq <- function(formula, data, R, parallel = c("no", "multicore", "snow"), ncpus = 1) { 
    bootfun <- function(formula, data, indices) { 
    d <- data[indices,] 
    fit <- lm(formula, data = d) 
    return(summary(fit)$r.square) 
    } 

    env <- environment() 
    counter <- 0 
    progbar <- txtProgressBar(min = 0, max = R, style = 3) 
    flush.console() 

    intfun <- function(formula, data, indices) { 
    curVal <- get("counter", envir = env) + ncpus 
    assign("counter", curVal, envir = env) 
    setTxtProgressBar(get("progbar", envir = env), curVal) 
    bootfun(formula, data, indices) 
    } 
    res <- boot(data = data, statistic = intfun, R = R, formula = formula, parallel = parallel, ncpus = ncpus) 
    return(res) 
} 

Purtroppo, questo funziona solo per l'elaborazione multicore quando Eseguo R dal terminale. Qualche idea su come applicare la patch in modo che venga visualizzata correttamente anche in R console o Rstudio?

Answer 1

Non esattamente quello che hai ordinato, ma potrebbe essere utile.

Una semplice funzione statistica per l'avvio:

library(boot) 

bootfun <- function(formula, data, indices) { 
    d <- data[indices,] 
    fit <- lm(formula, data=d) 
    summary(fit)$r.square 
} 

Superiore funzione per visualizzare il progresso:

progressReporter <- function(total, nBars=100, f, ...) { 
    count <- 1 
    step <- ceiling(total/nBars) 
    cat(paste(rep("|", nBars), collapse=""), "\r") 
    flush.console() 
    function(...) { 
     if (count %% step==0) { 
      cat(".") 
     } 
     count <<- count + 1 
     f(...) 
    } 
} 

Ora questa funzione è barare - visualizza progressi ogni "passo" di iterazioni. Se hai 1000 iterazioni, usa due core e stampa ogni 10 iterazione: farà il lavoro. I core non condividono lo stato, ma ognuno eseguirà il contatore fino a 500 e la funzione risponderà ad entrambi i contatori.

D'altra parte se si eseguono 1000 iterazioni, si eseguono 10 core e si registra ogni 200 - la funzione rimarrà silenziosa, poiché tutti i core contano fino a 100 ciascuno. Nessuno arriverà a 200 - nessuna barra di avanzamento. Spero tu abbia l'idea. Penso che dovrebbe essere ok nella maggior parte dei casi.

Provalo:

res_1core <- boot(formula="mpg ~ wt + disp", data=mtcars, R=1000, statistic=progressReporter(1000, nBars=100, f=bootfun)) 
res_2core <- boot(formula="mpg ~ wt + disp", data=mtcars, R=1000, statistic=progressReporter(1000, nBars=100, f=bootfun), parallel="multicore", ncpus=2)