R/lapply-methods.R
76f39a85
 .lapply_Streamer <-
     function(X, FUN, ...)
 {
     FUN <- match.fun(FUN)
     YIELD <- selectMethod("yield", class(X)) # avoid S4 dispatch
 
     it <- 0L
     result <- vector("list", 4096L)     # pre-allocate
     .partialResult <- function(err) {
         if (is(err, "simpleError")) {
             length(result) <- it
             err$message <- paste0("yield(): ", conditionMessage(err))
             err$partialResult <- result
             class(err) <- c("partialResult", class(err))
         }
         stop(err)
     }
 
     repeat {
         y <- tryCatch(YIELD(X), error = .partialResult)
         if (!length(y))
             break;
         y <- tryCatch(FUN(y, ...), error = .partialResult)
         it <- it + 1L
         if (it == length(result))       # grow
             length(result) <- 1.6 * length(result)
         result[[it]] <- y
     }
     length(result) <- it
     result
 }
 
 setMethod(lapply, "Stream", .lapply_Streamer)
 
 setMethod(lapply, "Producer", .lapply_Streamer)
 
 .sapply_Streamer <-
     function(X, FUN, ..., simplify=TRUE, USE.NAMES=TRUE)
 {
     FUN <- match.fun(FUN)
     answer <- tryCatch(lapply(X = X, FUN = FUN, ...), error=function(err) {
         if (is(err, "partialResult"))
             err$partialResult <- simplify2array(err$partialResult,
                                                 higher = (simplify == "array"))
         stop(err)
     })
     if (!identical(simplify, FALSE) && length(answer))
         simplify2array(answer, higher = (simplify == "array"))
     else answer
 }
 
 setMethod(sapply, "Stream", .sapply_Streamer)
 
 setMethod(sapply, "Producer", .sapply_Streamer)