# cm-post.R: compare solutions to the following post to # r-devel from carlos martinez 12 apr 2008: # Looking for a simple, effective a minimum execution time solution. # For a vector as: # c(0,0,1,0,1,1,1,0,0,1,1,0,1,0,1,1,1,1,1,1) # To transform it to the following vector without using any loops: # c(0,0,1,0,1,2,3,0,0,1,2,0,1,0,1,2,3,4,5,6) set.seed(1066) # for reproducibility N <- 1e6 x <- as.double(runif(N) > .5) x[1] <- 0 # seems to be needed for fhad (and fvin?) fvin <- function(x) { ind <- which(x == 0) unlist(lapply(mapply(seq, ind, c(tail(ind, -1) - 1, length(x))), function(y) cumsum(x[y]))) } fdan <- function(x) { d <- diff(c(0,x,0)) starts <- which(d == 1) ends <- which(d == -1) x[x == 1] <- unlist(lapply(ends - starts, function(n) 1:n)) x } fdan2 <- function(x) { runs <- rle(x) runlengths <- runs$lengths[runs$values == 1] x[x == 1] <- unlist(lapply(runlengths, function(n) 1:n)) x } fhad <- function(x) unlist(lapply(split(x, cumsum(x == 0)), seq_along)) - 1 # following requires "ra" for fast times www.milbo.users.sonic.net/ra library(jit) fjit <- function(x) { jit(1) if (length(x) > 1) for (i in 2:length(x)) if (x[i]) x[i] <- x[i-1] + 1 x } fgreg <- function(x) Reduce( function(x,y) x*y + y, x, accumulate=TRUE ) fanon <- function(x) x * unlist(lapply(rle(x)$lengths, seq)) cat("times with N =", N, "\n") cat("dan", system.time(ydan <- fdan(x))[3], "\n") cat("dan2", system.time(ydan2 <- fdan2(x))[3], "\n") cat("had", system.time(yhad <- fhad(x))[3], "\n") cat("vin", system.time(yvin <- fvin(x))[3], "\n") cat("jit", system.time(yjit <- fjit(x))[3], "\n") cat("greg", system.time(ygreg <- fgreg(x))[3], "\n") # very slow cat("anon", system.time(yanon <- fanon(x))[3], "\n") stopifnot(identical(ydan2, ydan)) stopifnot(identical(as.numeric(yhad), ydan)) stopifnot(identical(yvin, ydan)) stopifnot(identical(yjit, ydan)) stopifnot(identical(ygreg, ydan)) # stopifnot(identical(yanon, ydan))