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