Эффективность рисования прямоугольников на матрице изображения в R

Question

У меня есть функция drawRect, которая рисует прямоугольник на матрице n x m x 3 (один слой для каждого цветового канала).

Он принимает в 2-х основных параметров: прямоугольник Params c(xleft, xright, ytop, ybottom) и матрица изображения im

drawRect <- function(rect, im, color=2){ 
    int = 255 
    im[rect[3]:rect[4],rect[1],color] = int 
    im[rect[3]:rect[4],rect[2],color] = int 
    im[rect[3],rect[1]:rect[2],color] = int 
    im[rect[4],rect[1]:rect[2],color] = int 
    return(im) 
} 

Функция работает как ее предполагается. Тем не менее, я пытаюсь нарисовать ~ 2000 прямоугольников на изображении 3400 x 5200 x 3, и здесь он становится ЧРЕЗВЫЧАЙНО медленным.

У меня есть 2000 x 4 матрицу параметров прямоугольника, который выглядит примерно так:

#xleft xright ytop ybottom 
313 413 143  243 
413 513 143  243 
513 613 143  243 
613 713 143  243 
713 813 143  243 
811 911 143  243 
... 

Любые идеи о том, как ускорить этот процесс ...

Примечание мои изображения считываются в использовании readJPEG функция пакета jpeg и записывается в файл с использованием функции writeJPEG.

---

Edit: Я пытался переходящим в матрице прямоугольника параметров, так и с помощью функции применяется, чтобы избежать несколько вызовов функции, но до сих пор нет существенного улучшения.

drawRect2 <- function(rects, im, color=2, int = 255){ 

    x=apply(rects, 1, function(rect){ 
     im[rect[3]:rect[4],rect[1],color] = int 
     im[rect[3]:rect[4],rect[2],color] = int 
     im[rect[3],rect[1]:rect[2],color] = int 
     im[rect[4],rect[1]:rect[2],color] = int 
    }) 

    return(im) 
} 

Answer 1

Я не знаю, если есть Векторизованная версия rect но вы можете использовать poylygon который векторизованный. Вам нужно просто добавить NA между прямоугольниками. Этот ответ вдохновлен отличным ответом here.

cuts <- function(x) 
{ 
    n <- length(x) %/% 4 
    map <- rep(c(rep(TRUE,4),FALSE), n) 
    result <- rep(NA, n*5) 
    result[map] <- x 
    result 
} 


n <- 2000 

xbottom <- runif(n) 
ybottom <- runif(n) 
xtop <- xbottom+runif(n) 
ytop <- ybottom+runif(n) 

x <- cbind(xbottom,xbottom,xtop,xtop) 
y <- cbind(ybottom,ytop,ytop,ybottom) 
cols <- heat.colors(n)[order(x[,1])] 
plot(0, xlim=c(min(x),max(x)), ylim=c(min(y),max(y))) 
polygon(x=cuts(t(x)), y=cuts(t(y)), col=cols) 

Это создаст прямоугольники 2000 моментально.