1# Author: Robert J. Hijmans 2# Date : October 2008 3# Licence GPL v3 4# revised November 2011 5# version 1.0 6 7 8 9setMethod('extend', signature(x='Extent'), 10# function by Etienne B. Racine 11function(x, y, ...) { 12 if (length(y) == 1) { 13 y <- rep(y, 4) 14 } else if (length(y) == 2) { 15 y <- rep(y, each=2) 16 } else if (! length(y) == 4 ) { 17 stop('argument "y" should be a vector of 1, 2, or 4 elements') 18 } 19 x@xmin <- x@xmin - y[1] 20 x@xmax <- x@xmax + y[2] 21 x@ymin <- x@ymin - y[3] 22 x@ymax <- x@ymax + y[4] 23 methods::validObject(x) 24 x 25} 26) 27 28 29 30setMethod('extend', signature(x='Raster'), 31function(x, y, value=NA, snap='near', filename='', ...) { 32 33 if (is.vector(y)) { 34 if (length(y) <= 2) { 35 adj <- abs(y) * rev(res(x)) 36 y <- extent(x) 37 y@ymin <- y@ymin - adj[1] 38 y@ymax <- y@ymax + adj[1] 39 y@xmin <- y@xmin - adj[2] 40 y@xmax <- y@xmax + adj[2] 41 } 42 } 43 44 test <- try ( y <- extent(y), silent=TRUE ) 45 if (inherits(test, "try-error")) { 46 stop('Cannot get an Extent object from argument y') 47 } 48 49 filename <- trim(filename) 50 51 y <- alignExtent(y, x, snap=snap) 52# only expanding here, not cropping 53 y <- union(y, extent(x)) 54 55 if (nlayers(x) <= 1) { 56 out <- raster(x) 57 leg <- x@legend 58 } else { 59 out <- brick(x, values=FALSE) 60 leg <- methods::new('.RasterLegend') 61 } 62 out@data@names <- names(x) 63 out <- setExtent(out, y, keepres=TRUE) 64 if (any(is.factor(x))) { 65# if (is.na(value)) { perhaps need to check if value is a level 66 levels(out) <- levels(x) 67 } 68 69 70 if (nrow(x) == nrow(out) & ncol(x) == ncol(out)) { 71 # nothing to do. 72 return(x) 73 } 74 75 if (! hasValues(x) ) { 76 return(out) 77 } 78 79 dtp <- FALSE 80 datatype <- list(...)$datatype 81 if (is.null(datatype)) { 82 datatype <- unique(dataType(x)) 83 if (length(datatype) > 1) { 84 datatype <- .commonDataType(datatype) 85 } 86 dtp <- TRUE 87 } 88 89 90 if (canProcessInMemory(out)) { 91 92 d <- matrix(value, nrow=ncell(out), ncol=nlayers(x)) 93 d[cellsFromExtent(out, extent(x)), ] <- getValues(x) 94 x <- setValues(out, d) 95 if (filename != '') { 96 if (dtp) { 97 x <- writeRaster(x, filename=filename, datatype=datatype, ...) 98 } else { 99 x <- writeRaster(x, filename=filename, ...) 100 } 101 } 102 return(x) 103 104 } else { 105 106 tr <- blockSize(out) 107 tr$old <- rep(TRUE, tr$n) 108 startrow <- rowFromY(out, yFromRow(x, 1)) 109 endrow <- rowFromY(out, yFromRow(x, nrow(x))) 110 if (endrow < nrow(out) | startrow > 1) { 111 if (nrow(out) > endrow) { 112 continuerow <- endrow + 1 113 } else { 114 continuerow <- NULL 115 } 116 tr$row <- sort(unique(c(tr$row, startrow, continuerow))) 117 tr$nrows <- c(tr$row[-1], nrow(out)+1) - tr$row 118 tr$n <- length(tr$row) 119 tr$old <- (tr$row <= endrow) & ((tr$row+tr$nrows-1) >= startrow) 120 } 121 startcol <- colFromX(out, xFromCol(x, 1)) 122 endcol <- colFromX(out, xFromCol(x, ncol(x))) 123 124 pb <- pbCreate(tr$n, label='extend', ...) 125 if (dtp) { 126 out <- writeStart(out, filename=filename, datatype=datatype, ... ) 127 } else { 128 out <- writeStart(out, filename=filename, ... ) 129 } 130 131 if ((startcol == 1) & endcol == ncol(out)) { # to make it faster for this case 132 for (i in 1:tr$n) { 133 if (tr$old[i]) { 134 d <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) 135 } else { 136 d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) 137 } 138 out <- writeValues(out, d, tr$row[i]) 139 pbStep(pb, i) 140 } 141 } else { 142 for (i in 1:tr$n) { 143 d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) 144 if (tr$old[i]) { 145 cells <- startcol:endcol + rep((0:(tr$nrows[i]-1)) * ncol(out), each=endcol-startcol+1) 146 d[cells, ] <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) 147 } 148 out <- writeValues(out, d, tr$row[i]) 149 pbStep(pb, i) 150 } 151 } 152 pbClose(pb) 153 out <- writeStop(out) 154 return(out) 155 156 } 157} 158) 159 160 161