raster/0000755000176200001440000000000014173106421011551 5ustar liggesusersraster/NAMESPACE0000644000176200001440000000401714160233303012766 0ustar liggesusersimport(methods, Rcpp, terra) importFrom(sp, spplot, coordinates, wkt, plot, merge, bbox, disaggregate, proj4string) importFrom(grDevices, terrain.colors, heat.colors, rainbow) exportClasses(Extent, BasicRaster, Raster, RasterLayer, RasterBrick, RasterStack, RasterStackBrick) exportMethods("[", "[[", "==", "!=", "!", "%in%", adjacent, aggregate, all.equal, animate, Arith, approxNA, area, as.array, as.character, as.data.frame, as.factor, as.list, as.vector, as.matrix, as.raster, atan2, bandnr, bbox, bind, barplot, boundaries, boxplot, buffer, brick, calc, clamp, click, cellStats, clump, Compare, couldBeLonLat, cover, coordinates, contour, corLocal, cut, crosstab, crop, crs, "crs<-", disaggregate, distance, direction, density, erase, extent, extract, extend, flip, focal, freq, getValues, getValuesBlock, geom, gridDistance, hasValues, hist, head, init, inMemory, interpolate, intersect, image, is.factor, isLonLat, layerize, lines, log, Logic, levels, is.factor, as.factor, asFactor, match, mask, Math, Math2, mean, metadata, merge, modal, mosaic, names, "names<-", ncell, ncol, "ncol<-", nlayers, nrow, "nrow<-", overlay, origin, "origin<-", pairs, persp, plot, plotRGB, predict, proj4string, quantile, RGB, raster, rasterize, ratify, rectify, reclassify, res, "res<-", resample, rotate, "$", "$<-", sampleRandom, sampleRegular, sampleStratified, scale, select, stackSelect, setMinMax, setValues, shift, stretch, spplot, subset, subs, summary, Summary, stack, symdif, t, tail, terrain, text, trim, unique, unstack, union, update, xmin, xmax, xres, ymin, ymax, yres, zonal, yFromRow, xFromCol,colFromX, rowFromY, cellFromXY, cellFromRowCol, cellFromRowColCombine, xyFromCell, yFromCell, xFromCell, rowColFromCell,rowFromCell, colFromCell, readStart, readStop,values, "values<-", weighted.mean, which.min, which.max, whiches.min, whiches.max, Which, wkt, writeStart, writeStop, writeValues, writeRaster, zonal, zoom, xmin, xmax, ymin, ymax, "xmin<-", "xmax<-", "ymin<-", "ymax<-") useDynLib(raster, .registration = TRUE) exportPattern("^[^\\.\\_]") raster/man/0000755000176200001440000000000014173044241012325 5ustar liggesusersraster/man/as.raster.Rd0000644000176200001440000000154614160021141014512 0ustar liggesusers\name{as.raster} \alias{as.raster} \alias{as.raster,RasterLayer-method} \title{Coerce to a 'raster' object} \description{ Implementation of the generic \code{\link[grDevices]{as.raster}} function to create a 'raster' (small r) object. NOT TO BE CONFUSED with the Raster* (big R) objects defined by the raster package! Such objects can be used for plotting with the \code{\link[graphics]{rasterImage}} function. } \usage{ as.raster(x, ...) } \arguments{ \item{x}{ RasterLayer object } \item{...}{ Additional arguments. \code{maxpixels} Integer. To regularly subsample very large objects \code{col} Vector of colors. Default is col=rev(terrain.colors(255))) } } \value{ 'raster' object } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.raster(r) } \keyword{spatial} \keyword{methods} raster/man/overlay.Rd0000644000176200001440000001145614160021141014272 0ustar liggesusers\name{overlay} \docType{methods} \alias{overlay} \alias{overlay,Raster,Raster-method} \alias{overlay,Raster,missing-method} \title{Overlay Raster objects} \description{ Create a new Raster* object, based on two or more Raster* objects. (You can also use a single object, but perhaps \code{\link{calc}} is what you are looking for in that case). You should supply a function \code{fun} to set the way that the RasterLayers are combined. The number of arguments in the function must match the number of Raster objects (or take any number). For example, if you combine two RasterLayers you could use multiply: \code{fun=function(x,y){return(x*y)}} percentage: \code{fun=function(x,y){return(100 * x / y)}}. If you combine three layers you could use \code{fun=function(x,y,z){return((x + y) * z)}} Note that the function must work for vectors (not only for single numbers). That is, it must return the same number of elements as its input vectors. Alternatively, you can also supply a function such as \code{sum}, that takes \code{n} arguments (as \code{'...'}), and perhaps also has a \code{na.rm} argument, like in \code{sum(..., na.rm)}. If a single mutli-layer object is provided, its layers are treated as individual RasterLayer objects if the argument \code{unstack=TRUE} is used. If multiple objects are provided, they should have the same number of layers, or it should be possible to recycle them (e.g., 1, 3, and 9 layers, which would return a RasterBrick with 9 layers). } \usage{ \S4method{overlay}{Raster,Raster}(x, y, ..., fun, filename="", recycle=TRUE, forcefun=FALSE) \S4method{overlay}{Raster,missing}(x, y, ..., fun, filename="", unstack=TRUE, forcefun=FALSE) } \arguments{ \item{x}{Raster* object} \item{y}{Raster* object, or missing (only useful if \code{x} has multiple layers)} \item{...}{Additional Raster objects (and/or arguments for writing files as in \code{\link{writeRaster})}} \item{fun}{Function to be applied. When using RasterLayer objects, the number of arguments of the function should match the number of Raster objects, or it should take any number of arguments. When using multi-layer objects the function should match the number of layers of the RasterStack/Brick object (unless unstack=FALSE) } \item{filename}{Character. Output filename (optional) } \item{recycle}{Logical. Should layers from Raster objects with fewer layers be recycled?} \item{unstack}{Logical. Should layers be unstacked before computation (i.e. does the \code{fun} refer to individual layers in a multilayer object)?} \item{forcefun}{Boolean. If \code{TRUE}, overlay will not attempt to internally use apply (it is rarely necessary to use this argument)} } \details{ Instead of the overlay function you can also use arithmetic functions such as \code{*, /, +, -} with Raster objects (see examples). In that case you cannot specify an output filename. Moreover, the overlay function should be more efficient when using large data files that cannot be loaded into memory, as the use of the complex arithmetic functions might lead to the creation of many temporary files. While you can supply functions such as \code{sum} or \code{mean}, it would be more direct to use the Raster* objects as arguments to those functions (e.g. \code{sum(r1,r2,r3)}) See \code{\link{rasterize}} and \code{\link{extract}} for "overlays" involving Raster* objects and polygons, lines, or points. } \value{ Raster* object } \seealso{\code{ \link[raster]{calc}, \link[raster]{Arith-methods}} } \examples{ r <- raster(ncol=10, nrow=10) r1 <- init(r, fun=runif) r2 <- init(r, fun=runif) r3 <- overlay(r1, r2, fun=function(x,y){return(x+y)}) # long version for multiplication r4 <- overlay(r1, r2, fun=function(x,y){(x*y)} ) #use the individual layers of a RasterStack to get a RasterLayer s <- stack(r1, r2) r5 <- overlay(s, fun=function(x,y) x*y ) # equivalent to r5c <- calc(s, fun=function(x) x[1]*x[2] ) #Combine RasterStack and RasterLayer objects (s2 has four layers. # r1 (one layer) and s (two layers) are recycled) s2 <- stack(r1, r2, r3, r4) b <- overlay(r1, s, s2, fun=function(x,y,z){return(x*y*z)} ) # use a single RasterLayer (same as calc function) r6 <- overlay(r1, fun=sqrt) # multiplication with more than two layers # (make sure the number of RasterLayers matches the arguments of 'fun') r7 <- overlay(r1, r2, r3, r4, fun=function(a,b,c,d){return(a*b+c*d)} ) # equivalent function, efficient if values can be loaded in memory r8 <- r1 * r2 + r3 * r4 # Also works with multi-layer objects. s1 <- stack(r1, r2, r3) x <- overlay(s1, s1, fun=function(x,y)x+y+5) # in this case the first layer of the shorter object is recycled. # i.e., s2 is treated as stack(r1, r3, r1) s2 <- stack(r1, r3) y <- overlay(s1, s2, fun=sum) } \keyword{methods} \keyword{spatial} raster/man/extremeValues.Rd0000644000176200001440000000221614160021141015434 0ustar liggesusers\name{extremeValues} \alias{minValue} \alias{maxValue} \alias{minValue,RasterLayer-method} \alias{minValue,RasterStack-method} \alias{minValue,RasterBrick-method} \alias{maxValue,RasterLayer-method} \alias{maxValue,RasterStack-method} \alias{maxValue,RasterBrick-method} \title{Minimum and maximum values} \description{ Returns the minimum or maximum value of a RasterLayer or layer in a RasterStack } \usage{ minValue(x, ...) maxValue(x, ...) } \arguments{ \item{x}{RasterLayer or RasterStack object} \item{...}{Additional argument: layer number (for RasterStack or RasterBrick objects) } } \value{ a number } \details{ If a Raster* object is created from a file on disk, the min and max values are often not known (depending on the file format). You can use \code{\link[raster]{setMinMax}} to set them in the Raster* object. } \examples{ r <- raster() r <- setValues(r, 1:ncell(r)) minValue(r) maxValue(r) r <- setValues(r, round(100 * runif(ncell(r)) + 0.5)) minValue(r) maxValue(r) r <- raster(system.file("external/test.grd", package="raster")) minValue(r) maxValue(r) } \keyword{spatial} raster/man/blockSize.Rd0000644000176200001440000000241414160021141014530 0ustar liggesusers\name{blockSize} \alias{blockSize} \title{Block size for writing files} \description{ This function can be used to suggest chunk sizes (always a number of entire rows), and corresponding row numbers, to be used when processing Raster* objects in chunks. Normally used together with \code{\link{writeValues}}. } \usage{ blockSize(x, chunksize, n=nlayers(x), minblocks=4, minrows=1) } \arguments{ \item{x}{Raster* object} \item{chunksize}{Integer, normally missing. Can be used to set the block size; unit is number of cells. Block size is then computed in units of number of rows (always >= 1) } \item{n}{Integer. number of layers to consider. The function divides chunksize by n to determine blocksize } \item{minblocks}{Integer. Minimum number of blocks } \item{minrows}{Integer. Minimum number of rows in each block } } \value{ A list with three elements: \code{rows}, the suggested row numbers at which to start the blocks for reading and writing, \code{nrows}, the number of rows in each block, and, \code{n}, the total number of blocks } \seealso{ \code{\link[raster]{writeValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) blockSize(r) } \keyword{ spatial } \keyword{ methods } raster/man/area.Rd0000644000176200001440000000456414171353267013546 0ustar liggesusers\name{area} \alias{area} \alias{area,RasterLayer-method} \alias{area,RasterStackBrick-method} \alias{area,SpatialPolygons-method} \title{Size of cells} \description{ Raster objects: Compute the approximate surface area of cells in an unprojected (longitude/latitude) Raster object. It is an approximation because area is computed as the height (latitudinal span) of a cell (which is constant among all cells) times the width (longitudinal span) in the (latitudinal) middle of a cell. The width is smaller at the poleward side than at the equator-ward side of a cell. This variation is greatest near the poles and the values are thus not very precise for very high latitudes. SpatialPolygons: Compute the area of the spatial features. Works for both planar and angular (lon/lat) coordinate reference systems } \usage{ \S4method{area}{RasterLayer}(x, filename="", na.rm=FALSE, weights=FALSE, ...) \S4method{area}{RasterStackBrick}(x, filename="", na.rm=FALSE, weights=FALSE, ...) \S4method{area}{SpatialPolygons}(x, ...) } \arguments{ \item{x}{Raster* or SpatialPolygons object} \item{filename}{character. Filename for the output Raster object (optional)} \item{na.rm}{logical. If \code{TRUE}, cells that are \code{NA} are ignored} \item{weights}{logical. If \code{TRUE}, the area of each cells is divided by the total area of all cells that are not \code{NA}} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \details{ If \code{x} is a RasterStack/Brick, a RasterBrick will be returned if \code{na.rm=TRUE}. However, if \code{na.rm=FALSE}, a RasterLayer is returned, because the values would be the same for all layers. } \value{ If \code{x} is a Raster* object: RasterLayer or RasterBrick. Cell values represent the size of the cell in km2, or the relative size if \code{weights=TRUE}. If the CRS is not longitude/latitude the values returned are the product of the cell resolution (typically in square meter). If \code{x} is a SpatialPolygons* object: area of each spatial object in squared meters if the CRS is longitude/latitude, or in squared map units (typically meter) } \examples{ r <- raster(nrow=18, ncol=36) a <- area(r) if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) p$area <- round(area(p) / 10000000,1) p$area } } \keyword{methods} \keyword{spatial} raster/man/predict.Rd0000644000176200001440000001717214160021141014244 0ustar liggesusers\name{predict} \docType{methods} \alias{predict} \alias{predict,Raster-method} \title{Spatial model predictions} \description{ Make a Raster object with predictions from a fitted model object (for example, obtained with \code{lm}, \code{glm}). The first argument is a Raster object with the independent (predictor) variables. The \code{\link{names}} in the Raster object should exactly match those expected by the model. This will be the case if the same Raster object was used (via \code{extract}) to obtain the values to fit the model (see the example). Any type of model (e.g. glm, gam, randomForest) for which a predict method has been implemented (or can be implemented) can be used. This approach (predict a fitted model to raster data) is commonly used in remote sensing (for the classification of satellite images) and in ecology, for species distribution modeling. } \usage{ \S4method{predict}{Raster}(object, model, filename="", fun=predict, ext=NULL, const=NULL, index=1, na.rm=TRUE, inf.rm=FALSE, factors=NULL, format, datatype, overwrite=FALSE, progress='', ...) } \arguments{ \item{object}{Raster* object. Typically a multi-layer type (RasterStack or RasterBrick)} \item{model}{fitted model of any class that has a 'predict' method (or for which you can supply a similar method as \code{fun} argument. E.g. glm, gam, or randomForest } \item{filename}{character. Optional output filename } \item{fun}{function. Default value is 'predict', but can be replaced with e.g. predict.se (depending on the type of model), or your own custom function.} \item{ext}{Extent object to limit the prediction to a sub-region of \code{x} } \item{const}{data.frame. Can be used to add a constant for which there is no Raster object for model predictions. Particularly useful if the constant is a character-like factor value for which it is currently not possible to make a RasterLayer } \item{index}{integer. To select the column(s) to use if predict.'model' returns a matrix with multiple columns } \item{na.rm}{logical. Remove cells with \code{NA} values in the predictors before solving the model (and return a \code{NA} value for those cells). This option prevents errors with models that cannot handle \code{NA} values. In most other cases this will not affect the output. An exception is when predicting with a boosted regression trees model because these return predicted values even if some (or all!) variables are \code{NA} } \item{inf.rm}{logical. Remove cells with values that are not finite (some models will fail with -Inf/Inf values). This option is ignored when \code{na.rm=FALSE}} \item{factors}{list with levels for factor variables. The list elements should be named with names that correspond to names in \code{object} such that they can be matched. This argument may be omitted for standard models such as 'glm' as the predict function will extract the levels from the \code{model} object, but it is necessary in some other cases (e.g. cforest models from the party package)} \item{format}{character. Output file type. See \link[raster]{writeRaster} (optional) } \item{datatype}{character. Output data type. See \link[raster]{dataType} (optional) } \item{overwrite}{logical. If TRUE, "filename" will be overwritten if it exists } \item{progress}{character. "text", "window", or "" (the default, no progress bar) } \item{...}{additional arguments to pass to the predict.'model' function } } \seealso{ Use \code{\link[raster]{interpolate}} if your model has 'x' and 'y' as implicit independent variables (e.g., in kriging). } \value{ RasterLayer or RasterBrick } \examples{ # A simple model to predict the location of the R in the R-logo using 20 presence points # and 50 (random) pseudo-absence points. This type of model is often used to predict # species distributions. See the dismo package for more of that. # create a RasterStack or RasterBrick with with a set of predictor layers logo <- brick(system.file("external/rlogo.grd", package="raster")) names(logo) \dontrun{ # the predictor variables par(mfrow=c(2,2)) plotRGB(logo, main='logo') plot(logo, 1, col=rgb(cbind(0:255,0,0), maxColorValue=255)) plot(logo, 2, col=rgb(cbind(0,0:255,0), maxColorValue=255)) plot(logo, 3, col=rgb(cbind(0,0,0:255), maxColorValue=255)) par(mfrow=c(1,1)) } # known presence and absence points p <- matrix(c(48, 48, 48, 53, 50, 46, 54, 70, 84, 85, 74, 84, 95, 85, 66, 42, 26, 4, 19, 17, 7, 14, 26, 29, 39, 45, 51, 56, 46, 38, 31, 22, 34, 60, 70, 73, 63, 46, 43, 28), ncol=2) a <- matrix(c(22, 33, 64, 85, 92, 94, 59, 27, 30, 64, 60, 33, 31, 9, 99, 67, 15, 5, 4, 30, 8, 37, 42, 27, 19, 69, 60, 73, 3, 5, 21, 37, 52, 70, 74, 9, 13, 4, 17, 47), ncol=2) # extract values for points xy <- rbind(cbind(1, p), cbind(0, a)) v <- data.frame(cbind(pa=xy[,1], extract(logo, xy[,2:3]))) #build a model, here an example with glm model <- glm(formula=pa~., data=v) #predict to a raster r1 <- predict(logo, model, progress='text') plot(r1) points(p, bg='blue', pch=21) points(a, bg='red', pch=21) # use a modified function to get a RasterBrick with p and se # from the glm model. The values returned by 'predict' are in a list, # and this list needs to be transformed to a matrix predfun <- function(model, data) { v <- predict(model, data, se.fit=TRUE) cbind(p=as.vector(v$fit), se=as.vector(v$se.fit)) } # predfun returns two variables, so use index=1:2 r2 <- predict(logo, model, fun=predfun, index=1:2) \dontrun{ # You can use multiple cores to speed up the predict function # by calling it via the clusterR function (you may need to install the snow package) beginCluster() r1c <- clusterR(logo, predict, args=list(model)) r2c <- clusterR(logo, predict, args=list(model=model, fun=predfun, index=1:2)) } # principal components of a RasterBrick # here using sampling to simulate an object too large # to feed all its values to prcomp sr <- sampleRandom(logo, 100) pca <- prcomp(sr) # note the use of the 'index' argument x <- predict(logo, pca, index=1:3) plot(x) \dontrun{ # partial least square regression library(pls) model <- plsr(formula=pa~., data=v) # this returns an array: predict(model, v[1:5,]) # write a function to turn that into a matrix pfun <- function(x, data) { y <- predict(x, data) d <- dim(y) dim(y) <- c(prod(d[1:2]), d[3]) y } pp <- predict(logo, model, fun=pfun, index=1:3) # Random Forest library(randomForest) rfmod <- randomForest(pa ~., data=v) ## note the additional argument "type='response'" that is ## passed to predict.randomForest r3 <- predict(logo, rfmod, type='response', progress='window') ## get a RasterBrick with class membership probabilities vv <- v vv$pa <- as.factor(vv$pa) rfmod2 <- randomForest(pa ~., data=vv) r4 <- predict(logo, rfmod2, type='prob', index=1:2) spplot(r4) # cforest (other Random Forest implementation) example with factors argument v$red <- as.factor(round(v$red/100)) logo$red <- round(logo[[1]]/100) library(party) m <- cforest(pa~., control=cforest_unbiased(mtry=3), data=v) f <- list(levels(v$red)) names(f) <- 'red' # the second argument in party:::predict.RandomForest # is "OOB", and not "newdata" or similar. We need to write a wrapper # predict function to deal with this predfun <- function(m, d, ...) predict(m, newdata=d, ...) pc <- predict(logo, m, OOB=TRUE, factors=f, fun=predfun) # knn example, using calc instead of predict library(class) cl <- factor(c(rep(1, nrow(p)), rep(0, nrow(a)))) train <- extract(logo, rbind(p, a)) k <- calc(logo, function(x) as.integer(as.character(knn(train, x, cl)))) } } \keyword{methods} \keyword{spatial} raster/man/iniFile.Rd0000644000176200001440000000222714160021141014164 0ustar liggesusers\name{inifile} \alias{readIniFile} \title{Read a .ini file} \description{ This function reads \code{'.ini'} files. These are text file databases that are organized in [sections] containing pairs of "name = value". } \usage{ readIniFile(filename, token='=', commenttoken=';', aslist=FALSE, case) } \arguments{ \item{filename}{Character. Filename of the .ini file} \item{token}{Character. The character that separates the "name" (variable name) from the "value"} \item{commenttoken}{Character. This token and everything that follows on the same line is considered a 'comment' that is not for machine consumption and is ignored in processing} \item{aslist}{Logical. Should the values be returned as a list} \item{case}{Optional. Function that operates on the text, such as \code{\link{toupper}} or \code{\link{tolower}} } } \details{ This function allows for using inistrings that have "=" as part of a value (but the token cannot be part of the 'name' of a variable!). Sections can be missing. } \value{ A n*3 matrix of characters with columns: section, name, value; or a list if \code{aslist=TRUE}. } \keyword{file} raster/man/Rcpp-classes.Rd0000644000176200001440000000067014160021141015144 0ustar liggesusers\name{Rcpp-class} \docType{class} \alias{SpPoly} \alias{SpPolygons} \alias{SpPolyPart} \alias{SpExtent} \alias{SpPoly-class} \alias{SpPolyPart-class} \alias{SpPolygons-class} \alias{Rcpp_SpExtent-class} \alias{Rcpp_SpPolygons-class} \alias{Rcpp_SpPoly-class} \alias{Rcpp_SpPolyPart-class} \title{ Rcpp classes} \description{ These classes are for internal use only } \keyword{classes} \keyword{spatial} raster/man/stack.Rd0000644000176200001440000000510014160021141013703 0ustar liggesusers\name{stack} \docType{methods} \alias{stack} \alias{stack,character-method} \alias{stack,Raster-method} \alias{stack,list-method} \alias{stack,missing-method} \alias{stack,SpatialPixelsDataFrame-method} \alias{stack,SpatialGridDataFrame-method} \alias{stack,kasc-method} \alias{stack,SpatRaster-method} \title{Create a RasterStack object} \description{ A RasterStack is a collection of RasterLayer objects with the same spatial extent and resolution. A RasterStack can be created from RasterLayer objects, or from raster files, or both. It can also be created from a SpatialPixelsDataFrame or a SpatialGridDataFrame object. } \usage{ \S4method{stack}{character}(x, ..., bands=NULL, varname="", native=FALSE, RAT=TRUE, quick=FALSE) \S4method{stack}{Raster}(x, ..., layers=NULL) \S4method{stack}{missing}(x) \S4method{stack}{list}(x, bands=NULL, native=FALSE, RAT=TRUE, ...) } \arguments{ \item{x}{filename (character), Raster* object, missing (to create an empty RasterStack), SpatialGrid*, SpatialPixels*, or list (of filenames and/or Raster* objects). If \code{x} is a list, additional arguments \code{...} are ignored} \item{bands}{integer. which bands (layers) of the file should be used (default is all layers)} \item{layers}{integer (or character with layer names) indicating which layers of a RasterBrick should be used (default is all layers)} \item{native}{logical. If \code{TRUE} native drivers are used instead of gdal drivers (where available, such as for BIL and Arc-ASCII files)} \item{RAT}{logical. If \code{TRUE} a raster attribute table is created for files that have one} \item{quick}{logical. If \code{TRUE} the extent and resolution of the objects are not compared. This speeds up the creation of the RasteStack but should be use with great caution. Only use this option when you are absolutely sure that all the data in all the files are aligned, and you need to create RasterStack for many (>100) files} \item{varname}{character. To select the variable of interest in a NetCDF file (see \code{\link{raster}})} \item{...}{additional filenames or Raster* objects} } \value{ RasterStack } \seealso{ \code{\link[raster]{addLayer}, \link[raster:addLayer]{dropLayer}, \link[raster]{raster}, \link[raster]{brick}} } \examples{ # file with one layer fn <- system.file("external/test.grd", package="raster") s <- stack(fn, fn) r <- raster(fn) s <- stack(r, fn) nlayers(s) # file with three layers slogo <- stack(system.file("external/rlogo.grd", package="raster")) nlayers(slogo) slogo } \keyword{methods} \keyword{spatial} raster/man/resolution.Rd0000644000176200001440000000143714160021141015012 0ustar liggesusers\name{resolution} \alias{xres} \alias{yres} \alias{res} \alias{xres,BasicRaster-method} \alias{yres,BasicRaster-method} \alias{res,BasicRaster-method} \alias{res<-} \alias{res<-,BasicRaster-method} \title{Resolution} \description{ Get (or set) the x and/or y resolution of a Raster* object } \usage{ xres(x) yres(x) res(x) res(x) <- value } \arguments{ \item{x}{Raster* object} \item{value}{Resolution (single number or vector of two numbers) } } \value{ A single numeric value or two numeric values. } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{ncell}} } \examples{ r <- raster(ncol=18, nrow=18) xres(r) yres(r) res(r) res(r) <- 1/120 # set yres differently res(r) <- c(1/120, 1/60) } \keyword{spatial} raster/man/extractIndex.Rd0000644000176200001440000000462714160021141015255 0ustar liggesusers\name{Extract by index} \docType{methods} \alias{[[,Raster,ANY,ANY-method} \alias{[,Raster,Spatial,missing-method} \alias{[,Raster,RasterLayer,missing-method} \alias{[,Raster,Extent,missing-method} \alias{[,Raster,numeric,numeric-method} \alias{[,Raster,numeric,missing-method} \alias{[,Raster,missing,numeric-method} \alias{[,Raster,matrix,missing-method} \alias{[,Raster,missing,missing-method} \alias{[,Raster,logical,missing-method} \alias{[,Extent,numeric,missing-method} \alias{[,Extent,missing,missing-method} \title{Indexing to extract values of a Raster* object} \description{ These are shorthand methods that call other methods that should normally be used, such as \code{\link{getValues}}, \code{\link{extract}}, \code{\link{crop}}. \code{object[i]} can be used to access values of a Raster* object, using cell numbers. You can also use row and column numbers as index, using \code{object[i,j]} or \code{object[i,]} or \code{object[,j]}. In addition you can supply an Extent, SpatialPolygons, SpatialLines or SpatialPoints object. If \code{drop=TRUE} (the default) cell values are returned (a vector for a RasterLayer, a matrix for a RasterStack or RasterBrick). If \code{drop=FALSE} a Raster* object is returned that has the extent covering the requested cells, and with all other non-requested cells within this extent set to \code{NA}. If you supply a RasterLayer, its values will be used as logical (TRUE/FALSE) indices if both Raster objects have the same extent and resolution; otherwise the cell values within the extent of the RasterLayer are returned. Double brackes '[[ ]]' can be used to extract one or more layers from a multi-layer object. } \section{Methods}{ \describe{ \code{x[i]} \code{x[i,j]} Arguments \tabular{rll}{ \tab \code{x} \tab a Raster* object \cr \tab \code{i} \tab cell number(s), row number(s), a (logical) RasterLayer, Spatial* object \cr \tab \code{j} \tab column number(s) (only available if i is (are) a row number(s)) \cr \tab \code{drop} \tab If \code{TRUE}, cell values are returned. Otherwise, a Raster* object is returned \cr } }} \seealso{ \code{\link{getValues}, \link{setValues}, \link{extract}, \link{crop}, \link{rasterize}} } \examples{ r <- raster(ncol=10, nrow=5) values(r) <- 1:ncell(r) r[1] r[1:10] r[1,] r[,1] r[1:2, 1:2] s <- stack(r, sqrt(r)) s[1:3] s[[2]] } \keyword{methods} \keyword{spatial} raster/man/sampleInt.Rd0000644000176200001440000000134714160021141014543 0ustar liggesusers\name{SampleInt} \alias{sampleInt} \title{Sample integer values} \description{ Take a random sample from a range of integer values between 1 and \code{n}. Its purpose is similar to that of \code{\link[base]{sample}}, but that function fails when \code{n} is very large. } \usage{ sampleInt(n, size, replace=FALSE) } \arguments{ \item{n}{Positive number (integer); the number of items to choose from } \item{size}{Non-negative integer; the number of items to choose} \item{replace}{Logical. Should sampling be with replacement?} } \value{vector of integer numbers} \examples{ sampleInt(1e+12, 10) # this may fail: # sample.int(1e+12, 10) # sample.int(1e+9, 10) } \keyword{spatial} raster/man/reclassify.Rd0000644000176200001440000000465014160021141014753 0ustar liggesusers\name{reclassify} \docType{methods} \alias{reclassify} \alias{reclassify,Raster-method} \title{Reclassify} \description{ Reclassify values of a Raster* object. The function (re)classifies groups of values to other values. For example, all values between 1 and 10 become 1, and all values between 11 and 15 become 2 (see functions \code{\link{subs}} and \code{\link{cut}} for alternative approaches). Reclassification is done with matrix \code{rcl}, in the row order of the reclassify table. Thus, if there are overlapping ranges, the first time a number is within a range determines the reclassification value. } \usage{ \S4method{reclassify}{Raster}(x, rcl, filename='', include.lowest=FALSE, right=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{rcl}{matrix for reclassification. This matrix can have 3 or 2 columns. In a \code{3-column matrix} the first two columns are "from" - "to" for the input values, and the third column "becomes" has the new value for that range. (You can also supply a vector that can be coerced into a n*3 matrix (with \code{byrow=TRUE})). A \code{2-column matrix} represents ("is", "becomes") which can be useful for integer values. In that case, the \code{right} argument is automatically set to \code{NA}} \item{filename}{character. Output filename (optional) } \item{include.lowest}{logical, indicating if a value equal to the lowest value in rcl (or highest value in the second column, for right = FALSE) should be included. The default is \code{FALSE}} \item{right}{logical, indicating if the intervals should be closed on the right (and open on the left) or vice versa. The default is \code{TRUE}. A special case is to use right=NA. In this case both the left and right intervals are open} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ Raster* object } \seealso{ \code{ \link{subs}, \link{clamp}, \link{cut}, \link{calc}} } \examples{ r <- raster(ncols=36, nrows=18) values(r) <- runif(ncell(r)) # reclassify the values into three groups # all values > 0 and <= 0.25 become 1, etc. m <- c(0, 0.25, 1, 0.25, 0.5, 2, 0.5, 1, 3) rclmat <- matrix(m, ncol=3, byrow=TRUE) rc <- reclassify(r, rclmat) # for values >= 0 (instead of > 0), do rc <- reclassify(r, rclmat, include.lowest=TRUE) # equivalent to rc <- reclassify(r, c(-Inf,0.25,1, 0.25,0.5,2, 0.5,Inf,3)) } \keyword{spatial} raster/man/bind.Rd0000644000176200001440000000331614160021141013521 0ustar liggesusers\name{bind} \docType{methods} \alias{bind} \alias{bind,SpatialPolygons,SpatialPolygons-method} \alias{bind,SpatialLines,SpatialLines-method} \alias{bind,SpatialPoints,SpatialPoints-method} \alias{bind,matrix,matrix-method} \alias{bind,matrix,missing-method} \alias{bind,data.frame,data.frame-method} \alias{bind,data.frame,missing-method} \alias{bind,list,missing-method} \title{ Bind Spatial* objects } \description{ Bind (append) Spatial* objects into a single object. All objects must be of the same vector type base class (SpatialPoints, SpatialLines, or SpatialPolygons) } \usage{ \S4method{bind}{SpatialPolygons,SpatialPolygons}(x, y, ..., keepnames=FALSE) \S4method{bind}{SpatialLines,SpatialLines}(x, y, ..., keepnames=FALSE) \S4method{bind}{SpatialPoints,SpatialPoints}(x, y, ..., keepnames=FALSE) \S4method{bind}{data.frame,data.frame}(x, y, ..., variables=NULL) \S4method{bind}{list,missing}(x, y, ..., keepnames=FALSE) } \arguments{ \item{x}{Spatial* object or data.frame, or a list of Spatial* objects} \item{y}{Spatial* object or data.frame, or missing} \item{...}{Additional Spatial* objects} \item{keepnames}{Logical. If \code{TRUE} the row.names are kept (if unique)} \item{variables}{character. Variable (column) names to keep, If \code{NULL}, all variables are kept} } \value{ Spatial* object } \seealso{ \code{\link[sp]{merge}} } \examples{ p <- readRDS(system.file("external/lux.rds", package="raster")) mersch <- p[p$NAME_2=='Mersch', ] diekirch <- p[p$NAME_2=='Diekirch', ] remich <- p[p$NAME_2=='Remich', ] remich$NAME_1 <- NULL x <- bind(mersch, diekirch, remich) plot(x) data.frame(x) } \keyword{methods} \keyword{spatial} raster/man/init.Rd0000644000176200001440000000360114160021141013545 0ustar liggesusers\name{initialize} \alias{init} \alias{init,Raster-method} \title{Initialize a Raster object with values} \description{ Create a new RasterLayer with values reflecting a cell property: 'x', 'y', 'col', 'row', or 'cell'. Alternatively, a function can be used. In that case, cell values are initialized without reference to pre-existing values. E.g., initialize with a random number (\code{fun=\link{runif}}). While there are more direct ways of achieving this for small objects (see examples) for which a vector with all values can be created in memory, the \code{init} function will also work for Raster* objects with many cells. } \usage{ \S4method{init}{Raster}(x, fun, filename="", ...) } \arguments{ \item{x}{Raster* object} \item{fun}{function to be applied. This must be a function that can take the number of cells as a single argument to return a vector of values with a length equal to the number of cells, such as \code{fun=runif}. You can also supply one of the following character values: 'x', 'y', 'row', 'col', or 'cell' to get the x or coordinate, row, col or cell number; you can also use 'chess', to get a chessboard pattern} \item{filename}{character. Optional output filename} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer } \note{ For backwards compatibility, the character values valid for \code{fun} can also be passed as named argument \code{v} } \examples{ r <- raster(ncols=36, nrows=18) x <- init(r, fun='cell') y <- init(r, fun=runif) # there are different ways to set all values to 1 # for large rasters: # set1f <- function(x){rep(1, x)} # z1 <- init(r, fun=set1f, filename=rasterTmpFile(), overwrite=TRUE) # This is equivalent to (but not memory safe): z2 <- setValues(r, rep(1, ncell(r))) # or values(r) <- rep(1, ncell(r)) # or values(r) <- 1 } \keyword{spatial} raster/man/round.Rd0000644000176200001440000000225114160021141013731 0ustar liggesusers\name{round} \docType{methods} \alias{round,RasterLayer-method} \alias{trunc,RasterLayer-method} \alias{ceiling,RasterLayer-method} \alias{floor,RasterLayer-method} \title{Integer values} \description{ These functions take a single RasterLayer argument \code{x} and change its values to integers. \code{ceiling} returns a RasterLayer with the smallest integers not less than the corresponding values of x. \code{floor} returns a RasterLayer with the largest integers not greater than the corresponding values of x. \code{trunc} returns a RasterLayer with the integers formed by truncating the values in x toward 0. \code{round} returns a RasterLayer with values rounded to the specified number of digits (decimal places; default 0). } \section{Methods}{ \describe{ ceiling(x) floor(x) trunc(x, ...) round(x, digits = 0) \item{x}{a RasterLayer object} \item{digits}{integer indicating the precision to be used} \item{...}{additional arguments} } } \details{ see ?base::round } \value{ a RasterLayer object } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- runif(ncell(r)) * 10 s <- round(r) } \keyword{spatial} raster/man/strech.Rd0000644000176200001440000000360114160021141014072 0ustar liggesusers\name{stretch} \alias{stretch} \alias{stretch,Raster-method} \title{Stretch} \description{ Linear stretch of values in a Raster object. Provide the desired output range (minv and maxv) and the lower and upper bounds in the original data, either as quantiles (if \code{minq=0} and \code{maxq=1} you use the minimum and maximum cell values), or as actual values (\code{smin} and \code{smax}; e.g. precomputed quantile values). If \code{smin} and \code{smax} are both not \code{NA}, \code{minq} and \code{maxq} are ignored. } \usage{ \S4method{stretch}{Raster}(x, minv=0, maxv=255, minq=0, maxq=1, smin=NA, smax=NA, samplesize=1000000, filename='', ...) } \arguments{ \item{x}{Raster object} \item{minv}{numeric >= 0 and smaller than maxv. lower bound of stretched value} \item{maxv}{numeric <= 255 and larger than maxv. upper bound of stretched value} \item{minq}{numeric >= 0 and smaller than maxq. lower quantile bound of original value. Ignored if smin is supplied} \item{maxq}{numeric <= 1 and larger than minq. upper quantile bound of original value. Ignored if smax is supplied} \item{smin}{numeric < smax. user supplied lower value for the layers, to be used instead of a quantile computed by the function itself} \item{smax}{numeric > smin. user supplied upper value for the layers, to be used instead of a quantile computed by the function itself} \item{samplesize}{numeric > 1. If samplesize < ncell(x), a regular sample of samplesize is taken from x to compute the quantiles (to speed things up)} \item{filename}{character. Filename for the output Raster object (optional)} \item{...}{ additional arguments as for \code{\link{writeRaster}}} } \value{ Raster } \seealso{stretch argument in \code{\link{plotRGB}}} \examples{ r <- raster(nc=10, nr=10) values(r) <- rep(1:2, 50) stretch(r) s <- stack(r, r*2) stretch(s) } \keyword{spatial} raster/man/factor.Rd0000644000176200001440000000754314160021141014071 0ustar liggesusers\name{factors} \docType{methods} \alias{is.factor} \alias{is.factor,Raster-method} \alias{is.factor,RasterStack-method} \alias{as.factor} \alias{as.factor,RasterLayer-method} \alias{levels} \alias{levels,Raster-method} \alias{levels,RasterStack-method} \alias{levels<-} \alias{levels<-,Raster-method} \alias{asFactor} \alias{asFactor,RasterLayer-method} \alias{factorValues} \alias{ratify} \alias{ratify,Raster-method} \alias{deratify} \title{Factors} \description{ These functions allow for defining a RasterLayer as a categorical variable. Such a RasterLayer is linked to other values via a "Raster Attribute Table" (RAT). Thus the cell values are an index, whereas the actual values of interest are in the RAT. The RAT is a data.frame. The first column in the RAT ("ID") has the unique cell values of the layer; this column should normally not be changed. The other columns can be of any basic type (factor, character, integer, numeric or logical). The functions documented here are mainly available such that files with a RAT can be read and processed; currently there is not too much further support. Whether a layer is defined as a factor or not is currently ignored by almost all functions. An exception is the 'extract' function (when used with option df=TRUE). Function 'levels' returns the RAT for inspection. It can be modified and set using \code{levels <- value} (but use caution as it is easy to mess things up). \code{as.factor} and \code{ratify} create a layer with a RAT table. Function 'deratify' creates a single layer for a (or each) variable in the RAT table. } \usage{ is.factor(x) as.factor(x) levels(x) \S4method{ratify}{Raster}(x, filename="", count=FALSE, ...) factorValues(x, v, layer=1, att=NULL, append.names=FALSE) deratify(x, att=NULL, layer=1, complete=FALSE, drop=TRUE, fun='mean', filename='', ...) asFactor(x, ...) } \arguments{ \item{x}{Raster* object} \item{v}{integer cell values} \item{layer}{integer > 0 indicating which layer to use (in a RasterStack or RasterBrick)} \item{att}{numeric or character. Which variable(s) in the RAT table should be used. If \code{NULL}, all variables are extracted. If using a numeric, skip the first two default columns} \item{append.names}{logical. Should names of data.frame returned by a combination of the name of the layer and the RAT variables? (can be useful for multilayer objects} \item{filename}{character. Optional} \item{count}{logical. If \code{TRUE}, a columns with frequencies is added} \item{...}{additional arguments as for \code{\link{writeRaster}}} \item{complete}{logical. If \code{TRUE}, the layer returned is no longer a factor} \item{drop}{logical. If \code{TRUE} a factor is converted to a numerical value if possible} \item{fun}{character. Used to get a single value for each class for a weighted RAT table. 'mean', 'min', 'max', 'smallest', or 'largest'} } \value{ Raster* object; list (levels); boolean (is.factor); matrix (factorValues) } \note{asFactor is deprecated and should not be used} \examples{ set.seed(0) r <- raster(nrow=10, ncol=10) values(r) <- runif(ncell(r)) * 10 is.factor(r) r <- round(r) f <- as.factor(r) is.factor(f) x <- levels(f)[[1]] x x$code <- letters[10:20] levels(f) <- x levels(f) f r <- raster(nrow=10, ncol=10) values(r) = 1 r[51:100] = 2 r[3:6, 1:5] = 3 r <- ratify(r) rat <- levels(r)[[1]] rat$landcover <- c("Pine", "Oak", "Meadow") rat$code <- c(12,25,30) levels(r) <- rat r # extract values for some cells i <- extract(r, c(1,2, 25,100)) i # get the attribute values for these cells factorValues(r, i) # write to file: # rr <- writeRaster(r, rasterTmpFile(), overwrite=TRUE) # rr # create a single-layer factor x <- deratify(r, "landcover") x is.factor(x) levels(x) } \keyword{methods} \keyword{spatial} raster/man/zApply.Rd0000644000176200001440000000206214160021141014061 0ustar liggesusers\name{zApply} \alias{zApply} \title{z (time) apply} \description{ Experimental function to apply a function over a (time) series of layers of a Raster object } \usage{ zApply(x, by, fun=mean, name='', ...) } \arguments{ \item{x}{Raster* object} \item{by}{aggregation indices or function } \item{fun}{function to compute aggregated values } \item{name}{character label of the new time series } \item{...}{additional arguments} } \value{ Raster* object } \author{Oscar Perpinan Lamigueiro & Robert J. Hijmans} \examples{ # 12 values of irradiation, 1 for each month G0dm=c(2.766,3.491,4.494,5.912,6.989,7.742,7.919,7.027,5.369,3.562,2.814,2.179)*1000; # RasterBrick with 12 layers based on G0dm + noise r <- raster(nc=10, nr=10) s <- brick(lapply(1:12, function(x) setValues(r, G0dm[x]+100*rnorm(ncell(r)) ))) # time tm <- seq(as.Date('2010-01-15'), as.Date('2010-12-15'), 'month') s <- setZ(s, tm, 'months') # library(zoo) # x <- zApply(s, by=as.yearqtr, fun=mean, name='quarters') } \keyword{spatial} raster/man/writeRaster.Rd0000644000176200001440000001342714160021141015124 0ustar liggesusers\name{writeRaster} \alias{writeRaster,RasterLayer,character-method} \alias{writeRaster,RasterStackBrick,character-method} \alias{writeRaster} \title{Write raster data to a file} \description{ Write an entire Raster* object to a file, using one of the many supported formats. See \code{\link[raster]{writeValues}} for writing in chunks (e.g. by row). When writing a file to disk, the file format is determined by the 'format=' argument if supplied, or else by the file extension (if the extension is known). If other cases the default format is used. The default format is 'raster', but this setting can be changed (see \code{\link{rasterOptions}}). } \usage{ \S4method{writeRaster}{RasterLayer,character}(x, filename, format, ...) \S4method{writeRaster}{RasterStackBrick,character}(x, filename, format, bylayer, suffix='numbers', ...) } \arguments{ \item{x}{Raster* object} \item{filename}{Output filename} \item{format}{Character. Output file type. See \code{\link[raster]{writeFormats}}. If this argument is not provided, it is attempted to infer it from the filename extension. If that fails, the default format is used. The default format is 'raster', but this can be changed using \code{\link{rasterOptions}}} \item{...}{Additional arguments: \code{datatype}{Character. Output data type (e.g. 'INT2S' or 'FLT4S'). See \code{\link{dataType}}. If no datatype is specified, 'FLT4S' is used, unless this default value was changed with \code{\link{rasterOptions}}} \code{overwrite}: Logical. If TRUE, "filename" will be overwritten if it exists \code{progress}: Character. Set a value to show a progress bar. Valid values are "text" and "window". \code{NAflag}: Numeric. To overwrite the default value used to represent \code{NA} in a file \code{bandorder}: Character. 'BIL', 'BIP', or 'BSQ'. For 'native' file formats only. For some other formats you can use the 'options' argument (see below) \code{options}: Character. File format specific GDAL options. E.g., when writing a geotiff file you can use: \code{options=c("COMPRESS=NONE", "TFW=YES")} You can use options=c("PROFILE=BASELINE") to create a plain tif with no GeoTIFF tags. This can be useful when writing files to be read by applications intolerant of unrecognised tags. NetCDF files have the following additional, optional, arguments: \code{varname}, \code{varunit}, \code{longname}, \code{xname}, \code{yname}, \code{zname}, \code{zunit} \code{prj}: Logical. If \code{TRUE}, the crs is written to a .prj file. This can be useful when writing to an ascii file or another file type that does not store the crs \code{setStatistics}: logical. If \code{TRUE} (the default) the min and max cell values are written to file (if the format permits it) } \item{bylayer}{if \code{TRUE}, write a separate file for each layer. You can provide a vector of filenames that matches the number of layers. Or you can provide a single filename that will get a unique suffix (see below)} \item{suffix}{'numbers' or 'names' to determine the suffix that each file gets when \code{bylayer=TRUE}; either a number between \code{1} and \code{nlayers(x)} or \code{names(x)}} } \details{ See \code{writeFormats} for supported file types ("formats", "drivers"). The rgdal package is needed, except for these file formats: 'raster', 'BIL', 'BIP', 'BSQ', 'SAGA', 'ascii', 'IDRISI', and 'CDF'. Some of these formats can be used with or without rgdal (idrisi, SAGA, ascii). You need the 'ncdf4' library for the 'CDF' format. In multi-layer files (i.e. files saved from RasterStack or RasterBrick objects), in the native 'raster' format, the band-order can be set to BIL ('Bands Interleaved by Line'), BIP ('Bands Interleaved by Pixels') or BSQ ('Bands SeQuential'). Note that bandorder is not the same as filetype here. Supported file types include: \tabular{llllr}{ \tab \bold{File type} \tab \bold{Long name} \tab \bold{default extension} \tab \bold{Multiband support} \cr \tab \code{raster} \tab 'Native' raster package format \tab .grd \tab Yes \cr \tab \code{ascii} \tab ESRI Ascii \tab .asc \tab No \cr \tab \code{SAGA} \tab SAGA GIS \tab .sdat \tab No \cr \tab \code{IDRISI} \tab IDRISI \tab .rst \tab No \cr \tab \code{CDF} \tab netCDF (requires ncdf4) \tab .nc \tab Yes \cr \tab \code{GTiff} \tab GeoTiff (requires rgdal) \tab .tif \tab Yes \cr \tab \code{ENVI} \tab ENVI .hdr Labelled \tab .envi \tab Yes \cr \tab \code{EHdr} \tab ESRI .hdr Labelled \tab .bil \tab Yes \cr \tab \code{HFA} \tab Erdas Imagine Images (.img) \tab .img \tab Yes \cr } } \value{ This function is used for the side-effect of writing values to a file. } \seealso{\code{\link[raster]{writeFormats}}, \code{\link[raster]{writeValues}} } \examples{ tmp <- tempdir() r <- raster(system.file("external/test.grd", package="raster")) # take a small part r <- crop(r, extent(179880, 180800, 329880, 330840) ) # write to an integer binary file rf <- writeRaster(r, filename=file.path(tmp, "allint.grd"), datatype='INT4S', overwrite=TRUE) # make a brick and save multi-layer file b <- brick(r, sqrt(r)) bf <- writeRaster(b, filename=file.path(tmp, "multi.grd"), bandorder='BIL', overwrite=TRUE) # write to a new geotiff file (depends on rgdal) if (require(rgdal)) { rf <- writeRaster(r, filename=file.path(tmp, "test.tif"), format="GTiff", overwrite=TRUE) bf <- writeRaster(b, filename=file.path(tmp, "multi.tif"), options="INTERLEAVE=BAND", overwrite=TRUE) } # write to netcdf if (require(ncdf4)) { rnc <- writeRaster(r, filename=file.path(tmp, "netCDF.nc"), format="CDF", overwrite=TRUE) } } \keyword{ spatial } \keyword{ methods } raster/man/update.Rd0000644000176200001440000000361414160021141014070 0ustar liggesusers\name{update} \docType{methods} \alias{update} \alias{update,RasterLayer-method} \alias{update,RasterBrick-method} \title{Update raster cells of files (on disk)} \description{ Update cell values of a file (i.e., cell values on disk) associated with a RasterLayer or RasterBrick. User beware: this function _will_ make changes to your file (first make a copy if you are not sure what you are doing). Writing starts at a cell number \code{cell}. You can write a vector of values (in cell order), or a matrix. You can also provide a vector of cell numbers (of the same length as vector \code{v}) to update individual cells. See \code{\link{writeFormats}} for supported formats. } \usage{ \S4method{update}{RasterLayer}(object, v, cell, ...) \S4method{update}{RasterBrick}(object, v, cell, band, ...) } \arguments{ \item{object}{RasterLayer or RasterBrick that is associated with a file} \item{v}{vector or matrix with new values} \item{cell}{cell from where to start writing. Or a vector of cell numbers if v is a vector of the same length}. \item{band}{band (layer) to update (for RasterBrick objects)}. \item{...}{additional arguments. None implemented} } \value{ RasterLayer or RasterBrick } \examples{ \dontrun{ # setting up an example RasterLayer with file r <- raster(nrow=5, ncol=10, vals=0) r <- writeRaster(r, rasterTmpFile(), overwrite=TRUE, datatype='INT2S') as.matrix(r) # update with a vector starting a cell r <- update(r, v=rep(1, 5), cell=6) # 99.99 gets rounded because this is an integer file r <- update(r, v=9.99, cell=50) as.matrix(r) # update with a vector of values and matching vector of cell numbers r <- update(r, v=5:1, cell=c(5,15,25,35,45)) as.matrix(r) # updating with a marix, anchored at a cell number m <- matrix(1:10, ncol=2) r <- update(r, v=m, cell=2) as.matrix(r) } } \keyword{methods} \keyword{spatial} raster/man/xyFromCell.Rd0000644000176200001440000000503714160021141014673 0ustar liggesusers\name{xyFromCell} \alias{xFromCol} \alias{xFromCol,Raster,numeric-method} \alias{xFromCol,Raster,missing-method} \alias{yFromRow} \alias{yFromRow,Raster,numeric-method} \alias{yFromRow,Raster,missing-method} \alias{xFromCell} \alias{xFromCell,Raster,numeric-method} \alias{yFromCell} \alias{yFromCell,Raster,numeric-method} \alias{xyFromCell} \alias{xyFromCell,BasicRaster-method} \alias{xyFromCell,BasicRaster,ANY-method} \alias{xyFromCell,Raster-method} \alias{xyFromCell,Raster-method} \alias{coordinates} \alias{coordinates,Raster-method} \alias{coordinates,Extent-method} \title{Coordinates from a row, column or cell number} \description{ These functions get coordinates of the center of raster cells for a row, column, or cell number of a Raster* object. } \usage{ \S4method{xFromCol}{Raster,numeric}(object, col) \S4method{yFromRow}{Raster,numeric}(object, row) \S4method{xFromCell}{Raster,numeric}(object, cell) \S4method{yFromCell}{Raster,numeric}(object, cell) \S4method{xyFromCell}{BasicRaster,ANY}(object, cell, spatial=FALSE, ...) \S4method{coordinates}{Raster}(obj, ...) \S4method{coordinates}{Extent}(obj, ...) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{col}{column number; or vector of column numbers. If missing, the x coordinates for all columns are returned} \item{row}{row number; or vector of row numbers. If missing, the y coordinates for all rows are returned} \item{cell}{cell number(s)} \item{spatial}{If \code{spatial=TRUE}, \code{xyFromCell} returns a SpatialPoints object instead of a matrix} \item{...}{additional arguments. None implemented} \item{obj}{Raster object} } \details{ Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \value{ xFromCol, yFromCol, xFromCell, yFromCell: vector of x or y coordinates xyFromCell: matrix(x,y) with coordinate pairs coordinates: xy coordinates for all cells } \seealso{ \code{\link{cellFromXY}} } \examples{ #using a new default raster (1 degree global) r <- raster() xFromCol(r, c(1, 120, 180)) yFromRow(r, 90) xyFromCell(r, 10000) xyFromCell(r, c(0, 1, 32581, ncell(r), ncell(r)+1)) #using a file from disk r <- raster(system.file("external/test.grd", package="raster")) r cellFromXY(r, c(180000, 330000)) #xy for corners of a raster: xyFromCell(r, c(1, ncol(r), ncell(r)-ncol(r)+1, ncell(r))) } \keyword{spatial} raster/man/Raster-classes.Rd0000644000176200001440000001410014160021141015471 0ustar liggesusers\name{Raster-class} \docType{class} \alias{BasicRaster-class} \alias{Raster-class} \alias{RasterLayer-class} \alias{RasterLayerSparse-class} \alias{RasterStack-class} \alias{RasterBrick-class} \alias{RasterStackBrick-class} \alias{VectorLayer-class} \alias{SpatialVector-class} \alias{print,Raster-method} \alias{show,BasicRaster-method} \alias{show,RasterLayer-method} \alias{show,RasterStack-method} \alias{show,RasterBrick-method} \alias{print,Spatial-method} \title{ Raster* classes} \description{ A raster is a database organized as a rectangular grid that is sub-divided into rectangular cells of equal area (in terms of the units of the coordinate reference system). The 'raster' package defines a number of "S4 classes" to manipulate such data. The main user level classes are \code{RasterLayer}, \code{RasterStack} and \code{RasterBrick}. They all inherit from \code{BasicRaster} and can contain values for the raster cells. An object of the \code{RasterLayer} class refers to a single layer (variable) of raster data. The object can point to a file on disk that holds the values of the raster cells, or hold these values in memory. Or it can not have any associated values at all. A \code{RasterStack} represents a collection of \code{RasterLayer} objects with the same extent and resolution. Organizing \code{RasterLayer} objects in a \code{RasterStack} can be practical when dealing with multiple layers; for example to summarize their values (see \code{\link[raster]{calc}}) or in spatial modeling (see \code{\link[raster]{predict}}). An object of class \code{RasterBrick} can also contain multiple layers of raster data, but they are more tightly related. An object of class \code{RasterBrick} can refer to only a single (multi-layer) data file, whereas each layer in a \code{RasterStack} can refer to another file (or another band in a multi-band file). This has implications for processing speed and flexibility. A \code{RasterBrick} should process quicker than a \code{RasterStack} (irrespective if values are on disk or in memory). However, a \code{RasterStack} is more flexible as a single object can refer to layers that have values stored on disk as well as in memory. If a layer that does not refer to values on disk (they only exists in memory) is added to a \code{RasterBrick}, it needs to load all its values into memory (and this may not be possible because of memory size limitations). Objects can be created from file or from each other with the following functions: \code{\link[raster]{raster}, \link[raster]{brick}} and \link[raster]{stack}. \code{Raster*} objects can also be created from SpatialPixels* and SpatialGrid* objects from the sp package using \code{as}, or simply with the function \code{\link[raster]{raster}}, \code{\link[raster]{brick}}, or \code{\link[raster]{stack}}. Vice versa, \code{Raster*} objects can be coerced into a sp type object with \code{as( , )}, e.g. \code{as(x, 'SpatialGridDataFrame')} . Common generic methods implemented for these classes include: \code{summary}, \code{show}, \code{dim}, and \code{plot, ...} \code{[} is implemented for RasterLayer. The classes described above inherit from the \code{BasicRaster} class which inherits from \code{BasicRaster}. The \code{BasicRaster} class describes the main properties of a raster such as the number of columns and rows, and it contains an object of the \code{link[raster]{Extent-class}} to describe its spatial extent (coordinates). It also holds the 'coordinate reference system' in a slot of class \code{\link[sp]{CRS-class}} defined in the \code{sp} package. A \code{BasicRaster} cannot contain any raster cell values and is therefore seldomly used. The \code{Raster*} class inherits from \code{BasicRaster}. It is a virtual class; which means that you cannot create an object of this class. It is used only to define methods for all the classes that inherit from it (\code{RasterLayer}, \code{RasterStack} and \code{RasterBrick}). Another virtual class is the \code{RasterStackBrick} class. It is formed by a class union of \code{RasterStack} and \code{RasterBrick}. You cannot make objects of it, but methods defined for objects of this class as arguments will accept objects of the \code{RasterLayer} and \code{RasterStack} as that argument. Classes \code{RasterLayer} and \code{RasterBrick} have a slot with an object of class \code{RasterFile} that describes the properties of the file they point to (if they do). \code{RasterLayer} has a slot with an object of class \code{SingleLayerData}, and the \code{RasterBrick} class has a slot with an object of class \code{MultipleLayerData}. These 'datalayer' classes can contain (some of) the values of the raster cells. These classes are not further described here because users should not need to directly access these slots. The 'setter' functions such as \code{setValues} should be used instead. Using such 'setter' functions is much safer because a change in one slot should often affect the values in other slots. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("RasterLayer", ...)}, or with the helper functions such as \code{raster}. } \section{Slots}{ Slots for RasterLayer and RasterBrick objects \describe{ \item{\code{title}:}{Character} \item{\code{file}:}{Object of class \code{".RasterFile"} } \item{\code{data}:}{Object of class \code{".SingleLayerData"} or \code{".MultipleLayerData"}} \item{\code{history}:}{To record processing history, not yet in use } \item{\code{legend}:}{Object of class \code{.RasterLegend}, Default legend. Should store preferences for plotting. Not yet implemented except that it stores the color table of images, if available} \item{\code{extent}:}{Object of \code{\link{Extent-class}} } \item{\code{ncols}:}{Integer} \item{\code{nrows}:}{Integer} \item{\code{crs}:}{Object of class \code{"CRS"}, i.e. the coordinate reference system. In Spatial* objects this slot is called 'proj4string' } } } \examples{ showClass("RasterLayer") } \keyword{classes} \keyword{spatial} raster/man/union.Rd0000644000176200001440000000424514160021141013737 0ustar liggesusers\name{union} \docType{methods} \alias{union} \alias{union,Extent,Extent-method} \alias{union,SpatialPolygons,SpatialPolygons-method} \alias{union,SpatialPolygons,missing-method} \alias{union,SpatialPoints,SpatialPoints-method} \alias{union,SpatialLines,SpatialLines-method} \title{ Union Extent or SpatialPolygons* objects } \description{ Extent objects: Objects are combined into their union. See \code{\link{crop}} and \code{\link{extend}} to union a Raster object with an Extent object. Two SpatialPolygons* objects. Overlapping polygons (between layers, not within layers) are intersected, other spatial objects are appended. Tabular attributes are joined. See \code{\link{bind}} if you want to combine polygons without intersection. Single SpatialPolygons* object. Overlapping polygons are intersected. Original attributes are lost. New attributes allow for determining how many, and which, polygons overlapped. Union for SpatialLines and SpatialPoints simply combines the two data sets; without any geometric intersections. This is equivalent to \code{\link{bind}}. } \usage{ \S4method{union}{Extent,Extent}(x, y) \S4method{union}{SpatialPolygons,SpatialPolygons}(x, y) \S4method{union}{SpatialPolygons,missing}(x, y) \S4method{union}{SpatialLines,SpatialLines}(x, y) \S4method{union}{SpatialPoints,SpatialPoints}(x, y) } \arguments{ \item{x}{Extent or SpatialPolygons* object} \item{y}{Same as \code{x} or missing} } \value{ Extent or SpatialPolygons object } \seealso{ \code{\link[raster]{intersect}, \link[raster]{extent}, \link[raster]{setExtent}} \code{\link[sp]{merge}} for merging a data.frame with attributes of Spatial objects and \code{\link{+,SpatialPolygons,SpatialPolygons-method}} for an algebraic notation } \examples{ e1 <- extent(-10, 10, -20, 20) e2 <- extent(0, 20, -40, 5) union(e1, e2) #SpatialPolygons if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) p0 <- aggregate(p) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) u <- union(p0, b) plot(u, col=2:4) } } \keyword{methods} \keyword{spatial} raster/man/focalWeight.Rd0000644000176200001440000000223214160021141015035 0ustar liggesusers\name{focalWeight} \alias{focalWeight} \title{Focal weights matrix} \description{ Calculate focal ("moving window") weight matrix for use in the \code{\link{focal}} function. The sum of the values adds up to one. } \usage{ focalWeight(x, d, type=c('circle', 'Gauss', 'rectangle'), fillNA=FALSE) } \arguments{ \item{x}{Raster* object} \item{d}{numeric. If \code{type=circle}, the radius of the circle (in units of the CRS). If \code{type=rectangle} the dimension of the rectangle (one or two numbers). If \code{type=Gauss} the size of sigma, and optionally another number to determine the size of the matrix returned (default is 3 times sigma)} \item{type}{character indicating the type of filter to be returned} \item{fillNA}{logical. If \code{TRUE}, zeros are set to \code{NA} such that they are ignored in the computations. Only applies to \code{type="circle"}} } \value{ matrix that can be used in \code{\link{focal}} } \examples{ r <- raster(ncols=180, nrows=180, xmn=0, crs="+proj=utm +zone=1") # Gaussian filter for square cells gf <- focalWeight(r, .5, "Gauss") focalWeight(r, 2, "circle", fillNA=TRUE) } \keyword{spatial} raster/man/validCell.Rd0000644000176200001440000000142714160021141014505 0ustar liggesusers\name{validCell} \alias{validCell} \alias{validCol} \alias{validRow} \title{Validity of a cell, column or row number} \description{ Simple helper functions to determine if a row, column or cell number is valid for a certain Raster* object } \usage{ validCell(object, cell) validCol(object, colnr) validRow(object, rownr) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{cell}{cell number(s)} \item{colnr}{column number; or vector of column numbers} \item{rownr}{row number; or vector of row numbers} } \value{ logical value } \examples{ #using a new default raster (1 degree global) r <- raster() validCell(r, c(-1, 0, 1)) validRow(r, c(-1, 1, 100, 10000)) } \keyword{spatial} raster/man/raster-package.Rd0000644000176200001440000005425014160021141015501 0ustar liggesusers\name{raster-package} \alias{raster-package} \docType{package} \title{ Overview of the functions in the raster package } \description{ The raster package provides classes and functions to manipulate geographic (spatial) data in 'raster' format. Raster data divides space into cells (rectangles; pixels) of equal size (in units of the coordinate reference system). Such continuous spatial data are also referred to as 'grid' data, and be contrasted with discrete (object based) spatial data (points, lines, polygons). The package should be particularly useful when using very large datasets that can not be loaded into the computer's memory. Functions will work correctly, because they process large files in chunks, i.e., they read, compute, and write blocks of data, without loading all values into memory at once. Below is a list of some of the most important functions grouped by theme. See the vignette for more information and some examples (you can open it by running this command: \code{vignette('Raster')}) } \details{ The package implements classes for Raster data (see \link{Raster-class}) and supports \itemize{ \item Creation of Raster* objects from scratch or from file \item Handling extremely large raster files \item Raster algebra and overlay functions \item Distance, neighborhood (focal) and patch functions \item Polygon, line and point to raster conversion \item Model predictions \item Summarizing raster values \item Easy access to raster cell-values \item Plotting (making maps) \item Manipulation of raster extent, resolution and origin \item Computation of row, column and cell numbers to coordinates and vice versa \item Reading and writing various raster file types } . } \section{I. Creating Raster* objects}{ RasterLayer, RasterStack, and RasterBrick objects are, as a group, referred to as Raster* objects. Raster* objects can be created, from scratch, files, or from objects of other classes, with the following functions: \tabular{ll}{ \code{\link{raster}}\tab To create a RasterLayer \cr \code{\link{stack}} \tab To create a RasterStack (multiple layers)\cr \code{\link{brick}} \tab To create a RasterBrick (multiple layers)\cr \code{\link{subset}} \tab Select layers of a RasterStack/Brick\cr \code{\link{addLayer}} \tab Add a layer to a Raster* object\cr \code{\link{dropLayer}} \tab Remove a layer from a RasterStack or RasterBrick \cr \code{\link{unstack}} \tab Create a list of RasterLayer objects from a RasterStack \cr --------------------------- \tab --------------------------------------------------------------------------------------------------- \cr } } \section{II. Changing the spatial extent and/or resolution of Raster* objects}{ \tabular{ll}{ \code{\link{merge}} \tab Combine Raster* objects with different extents (but same origin and resolution) \cr \code{\link{mosaic}} \tab Combine RasterLayers with different extents and a function for overlap areas \cr \code{\link{crop}} \tab Select a geographic subset of a Raster* object \cr \code{\link{extend}} \tab Enlarge a Raster* object \cr \code{\link{trim}} \tab Trim a Raster* object by removing exterior rows and/or columns that only have NAs\cr \code{\link{aggregate}} \tab Combine cells of a Raster* object to create larger cells \cr \code{\link{disaggregate}} \tab Subdivide cells \cr \code{\link{resample}} \tab Warp values to a Raster* object with a different origin or resolution \cr \code{\link{projectRaster}} \tab project values to a raster with a different coordinate reference system \cr \code{\link{shift}} \tab Move the location of Raster \cr \code{\link{flip}} \tab Flip values horizontally or vertically \cr \code{\link{rotate}} \tab Rotate values around the date-line (for lon/lat data) \cr \code{\link{t}} \tab Transpose a Raster* object\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{III. Raster algebra}{ \tabular{ll}{ \code{\link{Arith-methods}} \tab Arith functions (\code{+, -, *, ^, \%\%, \%/\%, /}) \cr \code{\link{Math-methods}} \tab Math functions like \code{abs, sqrt, trunc, log, log10, exp, sin, round} \cr \code{\link{Logic-methods}} \tab Logic functions (\code{!, &, |}) \cr \code{\link{Summary-methods}} \tab Summary functions (\code{mean, max, min, range, prod, sum, any, all}) \cr \code{\link{Compare-methods}} \tab Compare functions (\code{==, !=, >, <, <=, >=}) \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{IV. Cell based computation}{ \tabular{ll}{ \code{\link{calc}} \tab Computations on a single Raster* object \cr \code{\link{overlay}} \tab Computations on multiple RasterLayer objects \cr \code{\link{cover}} \tab First layer covers second layer except where the first layer is \code{NA} \cr \code{\link{mask}} \tab Use values from first Raster except where cells of the mask Raster are \code{NA}\cr \code{\link{cut}} \tab Reclassify values using ranges \cr \code{\link{subs}} \tab Reclassify values using an 'is-becomes' matrix \cr \code{\link{reclassify}} \tab Reclassify using a 'from-to-becomes' matrix \cr \code{\link{init}} \tab Initialize cells with new values \cr \code{\link{stackApply}} \tab Computations on groups of layers in Raster* object \cr \code{\link{stackSelect}} \tab Select cell values from different layers using an index RasterLayer\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{V. Spatial contextual computation}{ \tabular{ll}{ \code{\link{distance}} \tab Shortest distance to a cell that is not \code{NA}\cr \code{\link{gridDistance}} \tab Distance when traversing grid cells that are not \code{NA} \cr \code{\link{distanceFromPoints}} \tab Shortest distance to any point in a set of points \cr \code{\link{direction}} \tab Direction (azimuth) to or from cells that are not \code{NA}\cr \code{\link{focal}} \tab Focal (neighborhood; moving window) functions \cr \code{\link{localFun}} \tab Local association (using neighborhoods) functions \cr \code{\link{boundaries}} \tab Detection of boundaries (edges)\cr \code{\link{clump}} \tab Find clumps (patches) \cr \code{\link{adjacent}} \tab Identify cells that are adjacent to a set of cells on a raster \cr \code{\link{area}} \tab Compute area of cells (for longitude/latitude data) \cr \code{\link{terrain}} \tab Compute slope, aspect and other characteristics from elevation data \cr \code{\link{Moran}} \tab Compute global or local Moran or Geary indices of spatial autocorrelation \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{VI. Model predictions}{ \tabular{ll}{ \code{\link{predict}} \tab Predict a non-spatial model to a RasterLayer \cr \code{\link{interpolate}} \tab Predict a spatial model to a RasterLayer \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{VII. Data type conversion}{ You can coerce Raster* objects to Spatial* objects using \code{as}, as in \code{as(object, 'SpatialGridDataFrame')} \tabular{ll}{ \code{\link{raster}} \tab RasterLayer from SpatialGrid*, image, or matrix objects\cr \code{\link{rasterize}} \tab Rasterizing points, lines or polygons\cr \code{\link{rasterToPoints}} \tab Create points from a RasterLayer \cr \code{\link{rasterToPolygons}} \tab Create polygons from a RasterLayer \cr \code{\link{rasterToContour}} \tab Contour lines from a RasterLayer \cr \code{\link{rasterFromXYZ}} \tab RasterLayer from regularly spaced points\cr \code{\link{rasterFromCells}} \tab RasterLayer from a Raster object and cell numbers\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{VIII. Summarizing}{ \tabular{ll}{ \code{\link{cellStats}} \tab Summarize a Raster cell values with a function \cr \code{\link{summary}} \tab Summary of the values of a Raster* object (quartiles and mean) \cr \code{\link{freq}} \tab Frequency table of Raster cell values \cr \code{\link{crosstab}} \tab Cross-tabulate two Raster* objects\cr \code{\link{unique}} \tab Get the unique values in a Raster* object \cr \code{\link{zonal}} \tab Summarize a Raster* object by zones in a RasterLayer \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{IX. Accessing values of Raster* object cells}{ Apart from the function listed below, you can also use indexing with \code{[} for cell numbers, and \code{[[} for row / column number combinations \cr \tabular{ll}{ \code{\link{getValues}} \tab Get all cell values (fails with very large rasters), or a row of values (safer) \cr \code{\link{getValuesBlock}} \tab Get values for a block (a rectangular area) \cr \code{\link{getValuesFocal}} \tab Get focal values for one or more rows\cr \code{\link{as.matrix}} \tab Get cell values as a matrix \cr \code{\link{as.array}} \tab Get cell values as an array \cr \code{\link{extract}} \tab Extract cell values from a Raster* object (e.g., by cell, coordinates, polygon)\cr \code{\link{sampleRandom}} \tab Random sample \cr \code{\link{sampleRegular}} \tab Regular sample \cr \code{\link{minValue}} \tab Get the minimum value of the cells of a Raster* object (not always known) \cr \code{\link{maxValue}} \tab Get the maximum value of the cells of a Raster* object (not always known) \cr \code{\link{setMinMax}} \tab Compute the minimum and maximum value of a Raster* object if these are not known \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{X. Plotting}{ See the rasterVis package for additional plotting methods for Raster* objects using methods from 'lattice' and other packages. \tabular{ll}{ \bold{Maps} \tab \cr \code{\link{plot}} \tab Plot a Raster* object. The main method to create a map \cr \code{\link{plotRGB}} \tab Combine three layers (red, green, blue channels) into a single 'real color' image \cr \code{\link{spplot}} \tab Plot a Raster* with the spplot function (sp package) \cr \code{\link{image}} \tab Plot a Raster* with the image function \cr \code{\link{persp}} \tab Perspective plot of a RasterLayer \cr \code{\link{contour}} \tab Contour plot of a RasterLayer \cr \code{\link{filledContour}} \tab Filled contour plot of a RasterLayer \cr \code{\link{text}} \tab Plot the values of a RasterLayer on top of a map \cr .\cr \bold{Interacting with a map} \tab \cr \code{\link{zoom}} \tab Zoom in to a part of a map \cr \code{\link{click}} \tab Query values of Raster* or Spatial* objects by clicking on a map \cr \code{\link{select}} \tab Select a geometric subset of a Raster* or Spatial* object \cr \code{\link{drawPoly}} \tab Create a SpatialPolygons object by drawing it \cr \code{\link{drawLine}} \tab Create a SpatialLines object by drawing it \cr \code{\link{drawExtent}} \tab Create an Extent object by drawing it \cr .\cr \bold{Other plots} \tab \cr \code{\link{plot}} \tab x-y scatter plot of the values of two RasterLayer objects\cr \code{\link{hist}} \tab Histogram of Raster* object values \cr \code{\link{barplot}} \tab barplot of a RasterLayer \cr \code{\link{density}} \tab Density plot of Raster* object values \cr \code{\link{pairs}} \tab Pairs plot for layers in a RasterStack or RasterBrick \cr \code{\link{boxplot}} \tab Box plot of the values of one or multiple layers\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XI. Getting and setting Raster* dimensions }{ Basic parameters of existing Raster* objects can be obtained, and in most cases changed. If there are values associated with a RasterLayer object (either in memory or via a link to a file) these are lost when you change the number of columns or rows or the resolution. This is not the case when the extent is changed (as the number of columns and rows will not be affected). Similarly, with \bold{projection} you can set the projection, but this does not transform the data (see \link{projectRaster} for that). \tabular{ll}{ \code{\link{ncol}}\tab The number of columns \cr \code{\link{nrow}} \tab The number of rows \cr \code{\link{ncell}} \tab The number of cells (can not be set directly, only via ncol or nrow) \cr \code{\link{res}} \tab The resolution (x and y) \cr \code{\link{nlayers}} \tab How many layers does the object have? \cr \code{\link{names}} \tab Get or set the layer names \cr \code{\link{xres}} \tab The x resolution (can be set with res) \cr \code{\link{yres}} \tab The y resolution (can be set with res)\cr \code{\link{xmin}} \tab The minimum x coordinate (or longitude) \cr \code{\link{xmax}} \tab The maximum x coordinate (or longitude) \cr \code{\link{ymin}} \tab The minimum y coordinate (or latitude) \cr \code{\link{ymax}} \tab The maximum y coordinate (or latitude) \cr \code{\link{extent}} \tab The extent (minimum and maximum x and y coordinates) \cr \code{\link{origin}} \tab The origin of a Raster* object\cr \code{\link{crs}} \tab The coordinate reference system (map projection) \cr \code{\link{isLonLat}} \tab Test if an object has a longitude/latitude coordinate reference system \cr \code{\link{filename}} \tab Filename to which a RasterLayer or RasterBrick is linked \cr \code{\link{bandnr}} \tab layer (=band) of a multi-band file that this RasterLayer is linked to \cr \code{\link{nbands}} \tab How many bands (layers) does the file associated with a RasterLayer object have? \cr \code{\link{compareRaster}} \tab Compare the geometry of Raster* objects \cr \code{\link{NAvalue}} \tab Get or set the \code{NA} value (for reading from a file) \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XII. Computing row, column, cell numbers and coordinates}{ Cell numbers start at 1 in the upper-left corner. They increase within rows, from left to right, and then row by row from top to bottom. Likewise, row numbers start at 1 at the top of the raster, and column numbers start at 1 at the left side of the raster. \tabular{ll}{ \code{\link{xFromCol}} \tab x-coordinates from column numbers \cr \code{\link{yFromRow}} \tab y-coordinates from row numbers \cr \code{\link{xFromCell}} \tab x-coordinates from row numbers \cr \code{\link{yFromCell}} \tab y-coordinates from cell numbers \cr \code{\link{xyFromCell}} \tab x and y coordinates from cell numbers \cr \code{\link{colFromX}} \tab Column numbers from x-coordinates (or longitude) \cr \code{\link{rowFromY}} \tab Row numbers from y-coordinates (or latitude) \cr \code{\link{rowColFromCell}} \tab Row and column numbers from cell numbers\cr \code{\link{cellFromXY}} \tab Cell numbers from x and y coordinates \cr \code{\link{cellFromRowCol}} \tab Cell numbers from row and column numbers \cr \code{\link{cellsFromExtent}} \tab Cell numbers from extent object \cr \code{\link{coordinates}} \tab x and y coordinates for all cells \cr \code{\link{validCell}} \tab Is this a valid cell number? \cr \code{\link{validCol}} \tab Is this a valid column number? \cr \code{\link{validRow}} \tab Is this a valid row number? \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XIII. Writing files}{ \tabular{ll}{ \bold{Basic}\cr \code{\link{setValues}} \tab Put new values in a Raster* object \cr \code{\link{writeRaster}} \tab Write all values of Raster* object to disk \cr \code{\link{KML}} \tab Save raster as KML file \cr .\cr \bold{Advanced}\cr \code{\link{blockSize}} \tab Get suggested block size for reading and writing \cr \code{\link{writeStart}} \tab Open a file for writing \cr \code{\link{writeValues}} \tab Write some values \cr \code{\link{writeStop}} \tab Close the file after writing \cr \code{\link{update}} \tab Change the values of an existing file \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XIV. Manipulation of SpatialPolygons* and other vector type Spatial* objects}{ Some of these functions are in the \code{sp} package. The name in \bold{bold} is the equivalent command in ArcGIS. These functions build on the geometry ("spatial features") manipulation functions in package \code{rgeos}. These functions are extended here by also providing automated attribute data handling. \tabular{ll}{ \code{\link{bind}} \tab \bold{append} combine Spatial* objects of the same (vector) type \cr \code{\link{erase}} or "-" \tab \bold{erase} parts of a SpatialPolygons* object\cr \code{\link{intersect}} or "*" \tab \bold{intersect} SpatialPolygons* objects\cr \code{\link{union}} or "+" \tab \bold{union} SpatialPolygons* objects\cr \code{\link{cover}} \tab \bold{update} and \bold{identity} for a SpatialPolygons and another one\cr \code{\link{symdif}} \tab\bold{symmetrical difference} of two SpatialPolygons* objects \cr \code{\link{aggregate}} \tab \bold{dissolve} smaller polygons into larger ones \cr \code{\link[sp]{disaggregate}} \tab \bold{explode}: turn polygon parts into separate polygons (in the \code{sp} package) \cr \code{\link{crop}} \tab \bold{clip} a Spatial* object using a rectangle (Extent object)\cr \code{\link{select}} \tab \bold{select} - interactively select spatial features\cr \code{\link{click}} \tab \bold{identify} attributes by clicking on a map\cr \code{\link[sp]{merge}} \tab \bold{Join table} (in the \code{sp} package) \cr \code{\link[sp]{over}} \tab spatial queries between Spatial* objects \cr \code{\link{extract}} \tab spatial queries between Spatial* and Raster* objects \cr \code{\link{as.data.frame}} \tab coerce coordinates of \code{SpatialLines} or \code{SpatialPolygons} into a data.frame\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XV. Extent objects}{ \tabular{ll}{ \code{\link{extent}} \tab Create an extent object \cr \code{\link{intersect}} \tab Intersect two extent objects \cr \code{\link{union}} \tab Combine two extent objects \cr \code{\link{round}} \tab round/floor/ceiling of the coordinates of an Extent object \cr \code{\link{alignExtent}} \tab Align an extent with a Raster* object \cr \code{\link{drawExtent}} \tab Create an Extent object by drawing it on top of a map (see plot) \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XVI. Miscellaneous}{ \tabular{ll}{ \code{\link{rasterOptions}} \tab Show, set, save or get session options \cr \code{\link{getData}} \tab Download and geographic data\cr \code{\link{pointDistance}} \tab Distance between points \cr \code{\link{readIniFile}} \tab Read a (windows) 'ini' file \cr \code{\link{hdr}} \tab Write header file for a number of raster formats \cr \code{\link{trim}} \tab Remove leading and trailing blanks from a character string \cr \code{\link{extension}} \tab Get or set the extension of a filename \cr \code{\link{cv}} \tab Coefficient of variation \cr \code{\link{modal}} \tab Modal value \cr \code{\link{sampleInt}} \tab Random sample of (possibly very large) range of integer values \cr \code{\link{showTmpFiles}} \tab Show temporary files \cr \code{\link{removeTmpFiles}} \tab Remove temporary files \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XVII. For programmers}{ \tabular{ll}{ \code{\link{canProcessInMemory}} \tab Test whether a file can be created in memory \cr \code{\link{pbCreate}} \tab Initialize a progress bar \cr \code{\link{pbStep}} \tab Take a progress bar step \cr \code{\link{pbClose}} \tab Close a progress bar \cr \code{\link{readStart}} \tab Open file connections for efficient multi-chunk reading \cr \code{\link{readStop}} \tab Close file connections \cr \code{\link{rasterTmpFile}} \tab Get a name for a temporary file \cr \code{\link{inMemory}} \tab Are the cell values in memory? \cr \code{\link{fromDisk}} \tab Are the cell values read from a file? \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \author{Except where indicated otherwise, the functions in this package were written by Robert J. Hijmans} \section{Acknowledgments}{ Extensive contributions were made by Jacob van Etten, Jonathan Greenberg, Matteo Mattiuzzi, and Michael Sumner. Significant help was also provided by Phil Heilman, Agustin Lobo, Oscar Perpinan Lamigueiro, Stefan Schlaffer, Jon Olav Skoien, Steven Mosher, and Kevin Ummel. Contributions were also made by Jochen Albrecht, Neil Best, Andrew Bevan, Roger Bivand, Isabelle Boulangeat, Lyndon Estes, Josh Gray, Tim Haering, Herry Herry, Paul Hiemstra, Ned Hornig, Mayeul Kauffmann, Bart Kranstauber, Rainer Krug, Alice Laborte, John Lewis, Lennon Li, Justin McGrath, Babak Naimi, Carsten Neumann, Joshua Perlman, Richard Plant, Edzer Pebesma, Etienne Racine, David Ramsey, Shaun Walbridge, Julian Zeidler and many others. } \keyword{package} \keyword{spatial} raster/man/names.Rd0000644000176200001440000000150014160021141013701 0ustar liggesusers\name{names} \alias{labels,Raster-method} \alias{names} \alias{names<-} \alias{names,Raster-method} \alias{names,RasterStack-method} \alias{names<-,Raster-method} \title{Names of raster layers} \description{ Get or set the names of the layers of a Raster* object } \usage{ \S4method{names}{Raster}(x) \S4method{names}{Raster}(x)<-value \S4method{labels}{Raster}(object) } \arguments{ \item{x}{Raster* object} \item{object}{Raster* object} \item{value}{character (vector)} } \value{ Character } \seealso{ \code{\link{nlayers}, \link[raster]{bands}} } \examples{ r <- raster(ncols=5, nrows=5) values(r) <- 1:ncell(r) s <- stack(r, r, r) nlayers(s) names(s) names(s) <- c('a', 'b', 'c') names(s)[2] <- 'hello world' names(s) s labels(s) } \keyword{spatial} raster/man/sampleRegular.Rd0000644000176200001440000000334614160021141015413 0ustar liggesusers\name{sampleRegular} \alias{sampleRegular} \alias{sampleRegular,Raster-method} \title{Regular sample} \description{ Take a systematic sample from a Raster* object. } \usage{ \S4method{sampleRegular}{Raster}(x, size, ext=NULL, cells=FALSE, xy=FALSE, asRaster=FALSE, sp=FALSE, useGDAL=FALSE, ...) } \arguments{ \item{x}{Raster object} \item{size}{positive integer giving the number of items to choose.} \item{ext}{Extent. To limit regular sampling to the area within that box} \item{cells}{logical. Also return sampled cell numbers (if asRaster=FALSE) } \item{xy}{logical. If \code{TRUE}, coordinates of sampled cells are also returned} \item{asRaster}{logical. If \code{TRUE}, a RasterLayer or RasterBrick is returned, rather than the sampled values} \item{sp}{logical. If \code{TRUE}, a SpatialPointsDataFrame is returned} \item{useGDAL}{logical. If \code{TRUE}, GDAL is used to sample in some cases. This is quicker, but can result in values for a different set of cells than when \code{useGDAL=FALSE}. Only for rasters that are accessed via rgdal, and are not rotated. When \code{TRUE} arguments \code{cells}, \code{xy}, and \code{sp} are ignored (i.e., \code{FALSE} } \item{...}{additional arguments. None implemented} } \value{ A vector (single layer object), matrix (multi-layered object; or if \code{cells=TRUE}, or \code{xy=TRUE}), Raster* object (if \code{asRaster=TRUE}), or SpatialPointsDataFrame (if \code{sp=TRUE}) } \seealso{\code{\link{sampleRandom}}, \link{sampleStratified}} \examples{ r <- raster(system.file("external/test.grd", package="raster")) v <- sampleRegular(r, size=100) x <- sampleRegular(r, size=100, asRaster=TRUE) } \keyword{spatial} raster/man/extent.Rd0000644000176200001440000000326414160021141014116 0ustar liggesusers\name{extent} \alias{extent} \alias{extent,Extent-method} \alias{extent,BasicRaster-method} \alias{extent,Spatial-method} \alias{extent,sf-method} \alias{extent,bbox-method} \alias{extent,matrix-method} \alias{extent,numeric-method} \alias{extent,list-method} \alias{extent,GridTopology-method} \alias{bbox,Raster-method} \alias{bbox,Extent-method} \title{Extent} \description{ This function returns an Extent object of a Raster* or Spatial* object (or an Extent object), or creates an Extent object from a 2x2 matrix (first row: xmin, xmax; second row: ymin, ymax), vector (length=4; order= xmin, xmax, ymin, ymax) or list (with at least two elements, with names 'x' and 'y') \code{bbox} returns a \code{sp} package like 'bbox' object (a matrix) } \usage{ extent(x, ...) } \arguments{ \item{x}{Raster* or Extent object, a matrix, a bbox, or a vector of four numbers } \item{...}{Additional arguments. When x is a single number representing 'xmin', you can pass three additional numbers (xmax, ymin, ymax) When \code{x} is a Raster* object, you can pass four additional arguments to crop the extent: \code{r1, r2, c1, c2}, representing the first and last row and column number } } \value{ Extent object } \author{Robert J. Hijmans; Etienne Racine wrote the extent function for a list} \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{drawExtent}} } \examples{ r <- raster() extent(r) extent(c(0, 20, 0, 20)) #is equivalent to extent(0, 20, 0, 20) extent(matrix(c(0, 0, 20, 20), nrow=2)) x <- list(x=c(0,1,2), y=c(-3,5)) extent(x) #crop the extent by row and column numbers extent(r, 1, 20, 10, 30) } \keyword{spatial} raster/man/Summary-methods.Rd0000644000176200001440000000325614160021141015706 0ustar liggesusers\name{Summary-methods} \docType{methods} \alias{Summary-methods} \alias{mean,Raster-method} \alias{median,Raster-method} \alias{Summary,Raster-method} \title{ Summary methods } \description{ The following summary methods are available for Raster* objects: \code{mean, median, max, min, range, prod, sum, any, all} All methods take \code{na.rm} as an additional logical argument. Default is \code{na.rm=FALSE}. If \code{TRUE}, \code{NA} values are removed from calculations. These methods compute a summary statistic based on cell values of RasterLayers and the result of these methods is always a single RasterLayer (except for range, which returns a RasterBrick with two layers). See \code{\link{calc}} for functions not included here (e.g. median) or any other custom functions. You can mix RasterLayer, RasterStack and RasterBrick objects with single numeric or logical values. However, because generic functions are used, the method applied is chosen based on the first argument: '\code{x}'. This means that if \code{r} is a RasterLayer object, \code{mean(r, 5)} will work, but \code{mean(5, r)} will not work. To summarize all cells within a single RasterLayer, see \code{\link[raster]{cellStats}} and \code{\link[raster:extremeValues]{maxValue}} and \code{\link[raster:extremeValues]{minValue}} } \value{a RasterLayer} \seealso{ \code{\link{calc}} } \examples{ r1 <- raster(nrow=10, ncol=10) r1 <- setValues(r1, runif(ncell(r1))) r2 <- setValues(r1, runif(ncell(r1))) r3 <- setValues(r1, runif(ncell(r1))) r <- max(r1, r2, r3) r <- range(r1, r2, r3, 1.2) s <- stack(r1, r2, r3) r <- mean(s, 2) } \keyword{methods} \keyword{spatial} raster/man/pointDistance.Rd0000644000176200001440000000445014160021141015411 0ustar liggesusers\name{pointDistance} \alias{pointDistance} \title{Distance between points} \description{ Calculate the geographic distance between two (sets of) points on the WGS ellipsoid (\code{lonlat=TRUE}) or on a plane (\code{lonlat=FALSE}). If both sets do not have the same number of points, the distance between each pair of points is given. If both sets have the same number of points, the distance between each point and the corresponding point in the other set is given, except if \code{allpairs=TRUE}. } \usage{ pointDistance(p1, p2, lonlat, allpairs=FALSE, ...) } \arguments{ \item{p1}{x and y coordinate of first (set of) point(s), either as c(x, y), matrix(ncol=2), or SpatialPoints*. } \item{p2}{x and y coordinate of second (set of) second point(s) (like for \code{p1}). If this argument is missing, a distance matrix is computed for \code{p1} } \item{lonlat}{logical. If \code{TRUE}, coordinates should be in degrees; else they should represent planar ('Euclidean') space (e.g. units of meters) } \item{allpairs}{logical. Only relevant if the number of points in \code{x} and \code{y} is the same. If \code{FALSE} the distance between each point in \code{x} with the corresponding point in \code{y} is returned. If \code{TRUE} a full distance matrix is returned } \item{...}{Additional arguments. None implemented } } \value{ A single value, or a vector, or matrix of values giving the distance in meters (lonlat=TRUE) or map-units (for instance, meters in the case of UTM) If \code{p2} is missing, a distance matrix is returned } \seealso{\code{\link{distanceFromPoints}, \link{distance}, \link{gridDistance}}, \code{\link[sp]{spDistsN1}}. The \code{geosphere} package has many additional distance functions and other functions that operate on spherical coordinates} \author{Robert J. Hijmans and Jacob van Etten. The distance for longitude/latitude data uses GeographicLib by C.F.F. Karney} \examples{ a <- cbind(c(1,5,55,31),c(3,7,20,22)) b <- cbind(c(4,2,8,65),c(50,-90,20,32)) pointDistance(c(0, 0), c(1, 1), lonlat=FALSE) pointDistance(c(0, 0), c(1, 1), lonlat=TRUE) pointDistance(c(0, 0), a, lonlat=TRUE) pointDistance(a, b, lonlat=TRUE) #Make a distance matrix dst <- pointDistance(a, lonlat=TRUE) # coerce to dist object dst <- as.dist(dst) } \keyword{ spatial } raster/man/Compare-methods.Rd0000644000176200001440000000313614160021141015634 0ustar liggesusers\name{Compare-methods} \docType{methods} \alias{Compare-methods} \alias{Compare,Extent,Extent-method} \alias{Compare,Raster,Raster-method} \alias{Compare,Raster,logical-method} \alias{Compare,Raster,numeric-method} \alias{Compare,logical,Raster-method} \alias{Compare,numeric,Raster-method} \alias{==,BasicRaster,BasicRaster-method} \alias{!=,BasicRaster,BasicRaster-method} \title{Compare Raster* objects} \description{ These methods compare the location and resolution of Raster* objects. That is, they compare their spatial extent, projection, and number of rows and columns. For \code{BasicRaster} objects you can use \code{==} and \code{!=}, the values returned is a single logical value \code{TRUE} or \code{FALSE} For RasterLayer objects, these operators also compare the values associated with the objects, and the result is a RasterLayer object with logical (Boolean) values. The following methods have been implemented for RasterLayer objects: \code{==, !=, >, <, <=, >=} } \value{ A logical value or a RasterLayer object, and in some cases the side effect of a new file on disk. } \examples{ r1 <- raster() r1 <- setValues(r1, round(10 * runif(ncell(r1)))) r2 <- setValues(r1, round(10 * runif(ncell(r1)))) as(r1, 'BasicRaster') == as(r2, 'BasicRaster') r3 <- r1 == r2 b <- extent(0, 360, 0, 180) r4 <- setExtent(r2, b) as(r2, 'BasicRaster') != as(r4, 'BasicRaster') # The following would give an error. You cannot compare RasterLayer # that do not have the same BasicRaster properties. #r3 <- r1 > r4 } \keyword{methods} \keyword{math} raster/man/select.Rd0000644000176200001440000000342214160021141014062 0ustar liggesusers\name{select} \docType{methods} \alias{select} \alias{select,Raster-method} \alias{select,Spatial-method} \title{ Geometric subsetting } \description{ Geometrically subset Raster* or Spatial* objects by drawing on a plot (map). } \usage{ \S4method{select}{Raster}(x, use='rec', ...) \S4method{select}{Spatial}(x, use='rec', draw=TRUE, col='cyan', size=2, ...) } \arguments{ \item{x}{Raster*, SpatialPoints*, SpatialLines*, or SpatialPolygons*} \item{use}{character: 'rec' or 'pol'. To use a rectangle or a polygon for selecting} \item{draw}{logical. Add the selected features to the plot?} \item{col}{color to use to draw the selected features (when \code{draw=TRUE)}} \item{size}{integer > 0. Size to draw the selected features with (when \code{draw=TRUE)})} \item{...}{additional arguments. None implemented} } \seealso{ \code{\link{click}, \link{crop}} } \value{ Raster* or Spatial* object } \examples{ \dontrun{ # select a subset of a RasterLayer r <- raster(nrow=10, ncol=10) values(r) <- 1:ncell(r) plot(r) s <- select(r) # now click on the map twice # plot the selection on a new canvas: x11() plot(s) # select a subset of a SpatialPolygons object p1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60), c(-180,-20)) hole <- rbind(c(-150,-20), c(-100,-10), c(-110,20), c(-150,-20)) p2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55), c(-10,0)) p3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45), c(-125,0)) pols <- SpatialPolygons( list( Polygons(list(Polygon(p1), Polygon(hole)), 1), Polygons(list(Polygon(p2)), 2), Polygons(list(Polygon(p3)), 3))) pols@polygons[[1]]@Polygons[[2]]@hole <- TRUE plot(pols, col=rainbow(3)) ps <- select(pols) # now click on the map twice ps } } \keyword{spatial} raster/man/localFun.Rd0000644000176200001440000000277714160021141014362 0ustar liggesusers\name{localFun} \docType{methods} \alias{localFun} \alias{localFun,RasterLayer,RasterLayer-method} \title{Local functions} \description{ Local functions for two RasterLayer objects (using a focal neighborhood) } \usage{ \S4method{localFun}{RasterLayer,RasterLayer}(x, y, ngb=5, fun, filename='', ...) } \arguments{ \item{x}{RasterLayer or RasterStack/RasterBrick} \item{y}{object of the same class as \code{x}, and with the same number of layers} \item{ngb}{integer. rectangular neighbourhood size. Either a single integer or a vector of two integers c(rows, cols), such as c(3,3) to have a 3 x 3 focal window} \item{fun}{function} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \note{The first two arguments that \code{fun} needs to accept are vectors representing the local cells of RasterLayer \code{x} and \code{y} (each of length \code{ngb * ngb}). It also must have an ellipsis (\code{...}) argument} \value{ RasterLayer } \seealso{ \code{\link{corLocal}}, \code{\link{localFun}} } \examples{ set.seed(0) b <- stack(system.file("external/rlogo.grd", package="raster")) x <- flip(b[[2]], 'y') + runif(ncell(b)) y <- b[[1]] + runif(ncell(b)) f <- localFun(x, y, fun=cor) \dontrun{ # local regression: rfun <- function(x, y, ...) { m <- lm(y~x) # return R^2 summary(m)$r.squared } ff <- localFun(x, y, fun=rfun) plot(f, ff) } } \keyword{methods} \keyword{spatial} raster/man/compareCRS.Rd0000644000176200001440000000233314160021141014601 0ustar liggesusers\name{compareCRS} \alias{compareCRS} \title{ Partially compare two CRS objects } \description{ Compare CRS objects } \usage{ compareCRS(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) } \arguments{ \item{x}{CRS object, or object from which it can be extracted with \code{\link{projection}}, or PROJ.4 format character string} \item{y}{same as \code{x}} \item{unknown}{logical. Return \code{TRUE} if \code{x} or \code{y} is \code{TRUE}} \item{verbatim}{logical. If \code{TRUE} compare \code{x} and \code{y}, verbatim (not partially)} \item{verbose}{logical. If \code{TRUE}, messages about the comparison may be printed} } \value{ logical } \seealso{\code{sp::identicalCRS}, \code{\link{crs} }} \examples{ compareCRS("+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84", "+proj=longlat +datum=WGS84") compareCRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0", "+proj=longlat +datum=WGS84") compareCRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0", "+proj=longlat +datum=WGS84", verbatim=TRUE) compareCRS("+proj=longlat +datum=WGS84", NA) compareCRS("+proj=longlat +datum=WGS84", NA, unknown=TRUE) } \keyword{ spatial } raster/man/drawExtent.Rd0000644000176200001440000000136414160021141014733 0ustar liggesusers\name{drawExtent} \alias{drawExtent} \title{ Create an Extent object by drawing on a map} \description{ Click on two points of a plot (map) to obtain an object of class \code{\link{Extent}} ('bounding box') } \usage{ drawExtent(show=TRUE, col="red") } \arguments{ \item{show}{logical. If \code{TRUE}, the extent will be drawn on the map} \item{col}{sets the color of the lines of the extent } } \value{ Extent } \examples{ \dontrun{ r1 <- raster(nrow=10, ncol=10) values(r1) <- runif(ncell(r1)) plot(r1) # after running the following line, click on the map twice e <- drawExtent() # after running the following line, click on the map twice mean(values(crop(r1, drawExtent()))) } } \keyword{ spatial } raster/man/cut.Rd0000644000176200001440000000145114160021141013376 0ustar liggesusers\name{cut} \docType{methods} \alias{cut} \alias{cut,Raster-method} \title{Convert values to classes} \description{ Cut uses the base function \code{\link[base]{cut}} to classify the values of a Raster* object according to which interval they fall in. The intervals are defined by the argument \code{breaks}. The leftmost interval corresponds to level one, the next leftmost to level two and so on. } \usage{ cut(x, ...) } \arguments{ \item{x}{A Raster* object} \item{...}{additional arguments. See \link[base]{cut}} } \value{ Raster* object } \seealso{ \code{ \link{subs}, \link{reclassify}, \link{calc}} } \examples{ r <- raster(ncols=36, nrows=18) values(r) <- rnorm(ncell(r)) breaks <- -2:2 * 3 rc <- cut(r, breaks=breaks) } \keyword{spatial} raster/man/merge.Rd0000644000176200001440000000451614160021141013707 0ustar liggesusers\name{merge} \docType{methods} \alias{merge} \alias{merge,Raster,Raster-method} \alias{merge,RasterStackBrick,missing-method} \alias{merge,Extent,ANY-method} \title{ Merge Raster* objects } \description{ Merge Raster* objects to form a new Raster object with a larger spatial extent. If objects overlap, the values get priority in the same order as the arguments, but \code{NA} values are ignored (except when \code{overlap=FALSE}). See \code{\link[raster]{subs}} to merge a \code{Raster*} object and a \code{data.frame}. } \usage{ \S4method{merge}{Raster,Raster}(x, y, ..., tolerance=0.05, filename="", overlap=TRUE, ext=NULL) \S4method{merge}{RasterStackBrick,missing}(x, ..., tolerance=0.05, filename="", ext=NULL) \S4method{merge}{Extent,ANY}(x, y, ...) } \arguments{ \item{x}{Raster* or Extent object} \item{y}{Raster* if \code{x} is a Raster* object (or missing). If \code{x} is an Extent, \code{y} can be an Extent or object from which an Extent can be extracted} \item{...}{additional Raster or Extent objects (and/or arguments for writing files as in \code{\link{writeRaster})}} \item{tolerance}{numeric. permissible difference in origin (relative to the cell resolution). See \code{\link[base]{all.equal}}} \item{filename}{character. Output filename (optional)} \item{overlap}{logical. If \code{FALSE} values of overlapping objects are based on the first layer, even if they are \code{NA}} \item{ext}{Extent object (optional) to limit the output to that extent} } \details{ The Raster objects must have the same origin and resolution. In areas where the Raster objects overlap, the values of the Raster object that is first in the sequence of arguments will be retained. If you would rather use the average of cell values, or do another computation, you can use \code{\link[raster]{mosaic}} instead of merge. } \value{ RasterLayer or RasterBrick } \examples{ r1 <- raster(xmx=-150, ymn=60, ncols=30, nrows=30) values(r1) <- 1:ncell(r1) r2 <- raster(xmn=-100, xmx=-50, ymx=50, ymn=30) res(r2) <- c(xres(r1), yres(r1)) values(r2) <- 1:ncell(r2) rm <- merge(r1, r2) # if you have many RasterLayer objects in a list # you can use do.call: x <- list(r1, r2) # add arguments such as filename # x$filename <- 'test.tif' m <- do.call(merge, x) } \keyword{methods} \keyword{spatial} raster/man/flowpath.Rd0000644000176200001440000000151614160021141014431 0ustar liggesusers\name{flowPath} \alias{flowPath} \title{Flow path} \description{ Compute the flow path (drainage path) starting at a given point. See package \code{gdistance} for more path computations. } \usage{ flowPath(x, p, ...) } \arguments{ \item{x}{RasterLayer of flow direction (as can be created with \code{\link{terrain}}} \item{p}{starting point. Either two numbers: x (longitude) and y (latitude) coordinates; or a single cell number } \item{...}{additional arguments (none implemented)} } \value{ numeric (cell numbers) } \author{Ashton Shortridge} \examples{ data(volcano) v <- raster(volcano, xmn=2667400, xmx=2668010, ymn=6478700, ymx=6479570, crs="+init=epsg:27200") fd <- terrain(v, opt = "flowdir") path <- flowPath(fd, 2407) xy <- xyFromCell(fd, path) plot(v) lines(xy) } \keyword{spatial} raster/man/rectify.Rd0000644000176200001440000000163714160021141014256 0ustar liggesusers\name{rectify} \alias{rectify} \alias{rectify,Raster-method} \title{rectify a Raster object} \description{ rectify changes a rotated Raster* object into a non-rotated (rectangular) object. This is wrapper function around \code{\link{resample}}. } \usage{ \S4method{rectify}{Raster}(x, ext, res, method='ngb', filename='', ...) } \arguments{ \item{x}{Raster* object to be rectified} \item{ext}{Optional. Extent object or object from which an Extent object can be extracted} \item{res}{Optional. Single or two numbers to set the resolution} \item{method}{Method used to compute values for the new RasterLayer, should be "bilinear" for bilinear interpolation, or "ngb" for nearest neighbor } \item{filename}{Character. Output filename } \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick object } \keyword{spatial} raster/man/rasterTmpFile.Rd0000644000176200001440000000362614160021141015372 0ustar liggesusers\name{rasterTmpFile} \alias{rasterTmpFile} \alias{removeTmpFiles} \alias{showTmpFiles} \title{Temporary files} \description{ Functions in the raster package create temporary files if the values of an output Raster* object cannot be stored in memory (RAM). This can happen when no filename is provided to a function and in functions where you cannot provide a filename (e.g. when using 'raster algebra'). Temporary files are automatically removed at the start of each session. During a session you can use \code{showTmpFiles} to see what is there and \code{removeTmpFiles} to delete all the temporary files. \code{rasterTmpFile} returns a temporary filename. These can be useful when developing your own functions. These filenames consist of \code{prefix_date_time_pid_rn} where \code{pid} is the process id returned by \code{\link{Sys.getpid}} and \code{rn} is a 5 digit random number. This should make tempfiles unique if created at different times and also when created in parallel processes (different pid) that use \code{\link{set.seed}} and call rasterTmpFile at the same time. It is possible, however, to create overlapping names (see the examples), which is undesirable and can be avoided by setting the prefix argument. } \usage{ rasterTmpFile(prefix='r_tmp_') showTmpFiles() removeTmpFiles(h=24) } \arguments{ \item{prefix}{Character. Prefix to the filename (which will be followed by 10 random numbers)} \item{h}{Numeric. The minimum age of the files in number of hours (younger files are not deleted)} } \value{ \code{rasterTmpFile} returns a valid file name \code{showTmpFiles} returns the names (.grd only) of the files in the temp directory \code{removeTmpFiles} returns nothing } \seealso{ \code{\link{rasterOptions}}, \code{\link[base]{tempfile}} } \examples{ \dontrun{ rasterTmpFile('mytemp_') showTmpFiles() removeTmpFiles(h=24) }} \keyword{ spatial } raster/man/rasterToPoints.Rd0000644000176200001440000000216314160021141015604 0ustar liggesusers\name{rasterToPoints} \alias{rasterToPoints} \title{ Raster to points conversion} \description{ Raster to point conversion. Cells with NA are not converted. A function can be used to select a subset of the raster cells (by their values). } \usage{ rasterToPoints(x, fun=NULL, spatial=FALSE, ...) } \arguments{ \item{x}{A Raster* object } \item{fun}{Function to select a subset of raster values} \item{spatial}{Logical. If \code{TRUE}, the function returns a SpatialPointsDataFrame object } \item{...}{Additional arguments. Currently only \code{progress} to specify a progress bar. "text", "window", or "" (the default, no progress bar)} } \details{ \code{fun} should be a simple function returning a logical value. E.g.: \code{fun=function(x){x==1}} or \code{fun=function(x){x>3}} } \value{ A matrix with three columns: x, y, and v (value), or a SpatialPointsDataFrame object } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) * 10 r[r>8] <- NA p <- rasterToPoints(r) p <- rasterToPoints(r, fun=function(x){x>6}) #plot(r) #points(p) } \keyword{ spatial } raster/man/rasterToContour.Rd0000644000176200001440000000152414160021141015761 0ustar liggesusers\name{rasterToContour} \alias{rasterToContour} \title{ Raster to contour lines conversion} \description{ RasterLayer to contour lines. This is a wrapper around \code{\link[grDevices]{contourLines}} } \usage{ rasterToContour(x, maxpixels=100000, ...) } \arguments{ \item{x}{ a RasterLayer object } \item{maxpixels}{ Maximum number of raster cells to use; this function fails when too many cells are used} \item{...}{Any argument that can be passed to \code{\link[grDevices]{contourLines}} } } \details{ Most of the code was taken from maptools::ContourLines2SLDF, by Roger Bivand & Edzer Pebesma } \value{ SpatialLinesDataFrame } \examples{ f <- system.file("external/test.grd", package="raster") r <- raster(f) x <- rasterToContour(r) class(x) plot(r) plot(x, add=TRUE) } \keyword{ spatial } raster/man/zonal.Rd0000644000176200001440000000432014160021141013724 0ustar liggesusers\name{zonal} \alias{zonal} \alias{zonal,RasterLayer,RasterLayer-method} \alias{zonal,RasterStackBrick,RasterLayer-method} \title{Zonal statistics} \description{ Compute zonal statistics, that is summarized values of a Raster* object for each "zone" defined by a RasterLayer. If \code{stat} is a true \code{function}, \code{zonal} will fail (gracefully) for very large Raster objects, but it will in most cases work for functions that can be defined as by a character argument ('mean', 'sd', 'min', 'max', or 'sum'). In addition you can use 'count' to count the number of cells in each zone (only useful with \code{na.rm=TRUE}, otherwise \code{freq(z)} would be more direct. If a function is used, it should accept a \code{na.rm} argument (or at least a \code{...} argument) } \usage{ \S4method{zonal}{RasterLayer,RasterLayer}(x, z, fun='mean', digits=0, na.rm=TRUE, ...) \S4method{zonal}{RasterStackBrick,RasterLayer}(x, z, fun='mean', digits=0, na.rm=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{z}{RasterLayer with codes representing zones} \item{fun}{function to be applied to summarize the values by zone. Either as character: 'mean', 'sd', 'min', 'max', 'sum'; or, for relatively small Raster* objects, a proper function} \item{digits}{integer. Number of digits to maintain in 'zones'. By default averaged to an integer (zero digits)} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values in \code{x} are ignored} \item{...}{additional arguments. One implemented: \code{progress}, as in \code{\link{writeRaster}}} } \value{ A matrix with a value for each zone (unique value in \code{zones}) } \seealso{ See \code{\link{cellStats}} for 'global' statistics (i.e., all of \code{x} is considered a single zone), and \code{\link{extract}} for summarizing values for polygons} \examples{ r <- raster(ncols=10, nrows=10) values(r) <- runif(ncell(r)) * 1:ncell(r) z <- r values(z) <- rep(1:5, each=20) # for large files, use a character value rather than a function zonal(r, z, 'sum') # for smaller files you can also provide a function \dontrun{ zonal(r, z, mean) zonal(r, z, min) } # multiple layers zonal(stack(r, r*10), z, 'sum') } \keyword{spatial} raster/man/rotated.Rd0000644000176200001440000000054514160021141014250 0ustar liggesusers\name{rotated} \alias{rotated} \title{Do the raster cells have a rotation?} \description{ Do the raster cells have a rotation? } \usage{ rotated(x) } \arguments{ \item{x}{A Raster* object} } \value{ Logical value } \seealso{ \code{\link{rectify}}} \examples{ r <- raster() rotated(r) } \keyword{spatial} raster/man/scalebar.Rd0000644000176200001440000000252314160021141014360 0ustar liggesusers\name{scalebar} \alias{scalebar} \title{scalebar} \description{ Add a scalebar to a plot } \usage{ scalebar(d, xy = NULL, type = "line", divs = 2, below = "", lonlat = NULL, label, adj=c(0.5, -0.5), lwd = 2, ...) } \arguments{ \item{d}{distance covered by scalebar} \item{xy}{x and y coordinate to place the plot. Can be NULL. Use \code{xy=click()} to make this interactive } \item{type}{"line" or "bar"} \item{divs}{Number of divisions for a bar type. 2 or 4} \item{below}{Text to go below scalebar (e.g., "kilometers")} \item{lonlat}{Logical or NULL. If logical, \code{TRUE} indicates if the plot is using longitude/latitude coordinates. If \code{NULL} this is guessed from the plot's coordinates} \item{adj}{adjustment for text placement} \item{label}{Vector of three numbers to label the scale bar (beginning, midpoint, end)} \item{lwd}{line width for the "line" type scalebar} \item{...}{arguments to be passed to other methods } } \value{ None. Use for side effect of a scalebar added to a plot } \seealso{ \code{\link[raster]{plot}} } \author{Robert J. Hijmans; partly based on a function by Josh Gray } \examples{ f <- system.file("external/test.grd", package="raster") r <- raster(f) plot(r) scalebar(1000) scalebar(1000, xy=c(178000, 333500), type='bar', divs=4) } \keyword{spatial} raster/man/dataType.Rd0000644000176200001440000000522714160021141014363 0ustar liggesusers\name{dataType} \alias{dataType} \alias{dataType<-} \title{Data type } \description{ Get the datatype of a RasterLayer object. The datatype determines the interpretation of values written to disk. Changing the datatype of a Raster* object does not directly affect the way they are stored in memory. For native file formats (.grd/.gri files) it does affect how values are read from file. This is not the case for file formats that are read via rgdal (such as .tif and .img files) or netcdf. If you change the datatype of a RasterLayer and then read values from a native format file these may be completely wrong, so only do this for debugging or when the information in the header file was wrong. To set the datatype of a new file, you can give a 'datatype' argument to the functions that write values to disk (e.g. \code{\link{writeRaster}}). } \usage{ dataType(x) dataType(x) <- value } \arguments{ \item{x}{ A \code{RasterLayer} object } \item{value}{ A data type (see below) } } \details{ Setting the data type is useful if you want to write values to disk. In other cases use functions such as round() Datatypes are described by 5 characters. The first three indicate whether the values are integers, decimal number or logical values. The fourth character indicates the number of bytes used to save the values on disk, and the last character indicates whether the numbers are signed (i.e. can be negative and positive values) or not (only zero and positive values allowed) The following datatypes are available: \tabular{lll}{ \bold{Datatype definition} \tab \bold{minimum possible value} \tab \bold{maximum possible value} \cr \code{LOG1S} \tab FALSE (0)\tab TRUE (1) \cr \code{INT1S} \tab -127 \tab 127 \cr \code{INT1U} \tab 0 \tab 255 \cr \code{INT2S} \tab -32,767\tab 32,767 \cr \code{INT2U} \tab 0 \tab 65,534 \cr \code{INT4S} \tab -2,147,483,647 \tab 2,147,483,647 \cr \code{INT4U} \tab 0 \tab 4,294,967,296 \cr \code{FLT4S} \tab -3.4e+38 \tab 3.4e+38 \cr \code{FLT8S} \tab -1.7e+308 \tab 1.7e+308 \cr } For all integer types, except the single byte types, the lowest (signed) or highest (unsigned) value is used to store \code{NA}. Single byte files do not have \code{NA} values. Logical values are stored as signed single byte integers, they do have an \code{NA} value (-127) \code{INT4U} is available but they are best avoided as R does not support 32-bit unsigned integers. } \value{ Raster* object } \examples{ r <- raster(system.file("external/test.grd", package="raster")) dataType(r) \dontrun{ s <- writeRaster(r, 'new.grd', datatype='INT2U', overwrite=TRUE) dataType(s) } } \keyword{ spatial } raster/man/coords.Rd0000644000176200001440000000307514160021141014100 0ustar liggesusers\name{Extreme coordinates} \alias{xmin} \alias{xmax} \alias{ymin} \alias{ymax} \alias{xmin<-} \alias{xmax<-} \alias{ymin<-} \alias{ymax<-} \alias{xmin,BasicRaster-method} \alias{xmax,BasicRaster-method} \alias{ymin,BasicRaster-method} \alias{ymax,BasicRaster-method} \alias{xmin,Extent-method} \alias{xmax,Extent-method} \alias{ymin,Extent-method} \alias{ymax,Extent-method} \alias{xmin,Spatial-method} \alias{xmax,Spatial-method} \alias{ymin,Spatial-method} \alias{ymax,Spatial-method} \alias{xmin<-,Extent,numeric-method} \alias{xmin<-,BasicRaster,numeric-method} \alias{xmax<-,Extent,numeric-method} \alias{xmax<-,BasicRaster,numeric-method} \alias{ymin<-,Extent,numeric-method} \alias{ymin<-,BasicRaster,numeric-method} \alias{ymax<-,Extent,numeric-method} \alias{ymax<-,BasicRaster,numeric-method} \title{Coordinates of the Extent of a Raster object} \description{ These functions return or set the extreme coordinates of a Raster* object; and return them for Spatial* objects. } \usage{ xmin(x) xmax(x) ymin(x) ymax(x) xmin(x, ...) <- value xmax(x, ...) <- value ymin(x, ...) <- value ymax(x, ...) <- value } \arguments{ \item{x}{Raster* or Extent object} \item{value}{numeric. x or y coordinate} \item{...}{additional arguments. None implemented} } \value{ numeric } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{dimensions}} } \examples{ r <- raster(xmn=-0.5, xmx = 9.5, ncols=10) xmin(r) xmax(r) ymin(r) ymax(r) xmin(r) <- -180 xmax(r) <- 180 } \keyword{spatial} raster/man/gainoffset.Rd0000644000176200001440000000231714160021141014732 0ustar liggesusers\name{Gain and offset} \alias{gain} \alias{offs} \alias{gain<-} \alias{offs<-} \title{Gain and offset of values on file} \description{ These functions can be used to get or set the gain and offset parameters used to transform values when reading them from a file. The gain and offset parameters are applied to the raw values using the formula below: \code{value <- value * gain + offset} The default value for gain is 1 and for offset is 0. 'gain' is sometimes referred to as 'scale'. Note that setting gain and/or offset are intended to be used with values that are stored in a file. For a Raster* object with values in memory, assigning gain or offset values will lead to the inmediate computation of new values; in such cases it would be clearer to use \code{\link[raster]{Arith-methods}}. } \usage{ gain(x) gain(x) <- value offs(x) offs(x) <- value } \arguments{ \item{x}{Raster* object} \item{value}{Single numeric value } } \value{ Raster* object or numeric value(s) } \examples{ r <- raster(system.file("external/test.grd", package="raster")) gain(r) offs(r) r[1505:1510] gain(r) <- 10 offs(r) <- 5 r[1505:1510] } \keyword{ spatial } \keyword{ methods } raster/man/persp.Rd0000644000176200001440000000241114160021141013731 0ustar liggesusers\name{persp} \docType{methods} \alias{persp} \alias{persp,RasterLayer-method} \alias{persp,RasterStackBrick-method} \title{Perspective plot} \description{ Perspective plot of a RasterLayer. This is an implementation of a generic function in the graphics package. } \usage{ \S4method{persp}{RasterLayer}(x, maxpixels=1e+05, ext=NULL, ...) \S4method{persp}{RasterStackBrick}(x, y=1, maxpixels=10000, ext=NULL, ...) } \arguments{ \item{x}{Raster* object} \item{y}{integer \code{> 0 & <= nlayers(x)} to select the layer of \code{x} if \code{x} is a RasterLayer or RasterBrick} \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting} \item{ext}{Extent. Can be used to zoom in to a region (see also \code{\link{zoom}} and \code{\link{crop}(x, \link{drawExtent}())}} \item{...}{Any argument that can be passed to \code{\link[graphics]{persp}} (graphics package)} } \seealso{ \code{\link[rasterVis:plot3d]{plot3D}}, \code{\link[graphics]{persp}}, \code{\link[raster]{contour}}, \code{\link[raster]{plot}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) persp(r) } \keyword{methods} \keyword{spatial} raster/man/mask.Rd0000644000176200001440000000545414160021141013545 0ustar liggesusers\name{mask} \docType{methods} \alias{mask} \alias{mask,RasterLayer,RasterLayer-method} \alias{mask,RasterStackBrick,RasterLayer-method} \alias{mask,RasterLayer,RasterStackBrick-method} \alias{mask,RasterStackBrick,RasterStackBrick-method} \alias{mask,Raster,Spatial-method} \alias{mask,Raster,sf-method} \title{Mask values in a Raster object} \description{ Create a new Raster* object that has the same values as \code{x}, except for the cells that are \code{NA} (or other \code{maskvalue}) in a 'mask'. These cells become \code{NA} (or other \code{updatevalue}). The mask can be either another Raster* object of the same extent and resolution, or a Spatial* object (e.g. SpatialPolygons) in which case all cells that are not covered by the Spatial object are set to \code{updatevalue}. You can use \code{inverse=TRUE} to set the cells that are not \code{NA} (or other \code{maskvalue}) in the mask, or not covered by the Spatial* object, to \code{NA} (or other \code{updatvalue}). } \usage{ \S4method{mask}{RasterLayer,RasterLayer}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{RasterStackBrick,RasterLayer}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{RasterLayer,RasterStackBrick}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{RasterStackBrick,RasterStackBrick}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{Raster,Spatial}(x, mask, filename="", inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{mask}{Raster* object or a Spatial* object} \item{filename}{character. Optional output filename} \item{inverse}{logical. If \code{TRUE}, areas on mask that are _not_ the \code{maskvalue} are masked} \item{maskvalue}{numeric. The value in \code{mask} that indicates the cells of \code{x} that should become \code{updatevalue} (default = \code{NA})} \item{updatevalue}{numeric. The value that cells of \code{x} should become if they are not covered by \code{mask} (and not \code{NA})} \item{updateNA}{logical. If \code{TRUE}, \code{NA} values outside the masked area are also updated to the the \code{updatevalue} (only relevant if the \code{updatevalue} is not \code{NA}} \item{...}{additional arguments as in \code{\link{writeRaster}}} } \value{Raster* object} \seealso{\code{\link{rasterize}, \link{crop}}} \examples{ r <- raster(ncol=10, nrow=10) m <- raster(ncol=10, nrow=10) values(r) <- runif(ncell(r)) * 10 values(m) <- runif(ncell(r)) m[m < 0.5] <- NA mr <- mask(r, m) m2 <- m > .7 mr2 <- mask(r, m2, maskvalue=TRUE) } \keyword{methods} \keyword{spatial} raster/man/spEasy.Rd0000644000176200001440000000300314160021141014042 0ustar liggesusers\name{spEasy} \alias{spLines} \alias{spPolygons} \title{Create SpatialLines* or SpatialPolygons*} \description{ Helper functions to simplify the creation of SpatialLines* or SpatialPolygons* objects from coordinates. } \usage{ spLines(x, ..., attr=NULL, crs="") spPolygons(x, ..., attr=NULL, crs="") } \arguments{ \item{x}{matrix of list with matrices. Each matrix must have two columns with x and y coordinates (or longitude and latitude, in that order). Multi-line or multi-polygon objects can be formed by combining matrices in a list} \item{...}{additional matrices and/or lists with matrices} \item{attr}{data.frame with the attributes to create a *DataFrame object. The number of rows must match the number of lines/polgyons} \item{crs}{the coordinate reference system (PROJ4 or WKT notation)} } \value{ SpatialLines* or SpatialPolygons* } \examples{ x1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60)) x2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55)) x3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45)) x4 <- rbind(c(41,-41.5), c(51,-35), c(62,-41), c(51,-50)) a <- spLines(x1, x2, x3) b <- spLines(x1, list(x2, x3), attr=data.frame(id=1:2), crs='+proj=longlat +datum=WGS84') b hole <- rbind(c(-150,-20), c(-100,-10), c(-110,20), c(-130,10)) d <- spPolygons(list(x1,hole), x2, list(x3, x4)) att <- data.frame(ID=1:3, name=c('a', 'b', 'c')) e <- spPolygons(list(x1,hole), x2, list(x3, x4), attr=att, crs='+proj=longlat +datum=WGS84') e } \keyword{spatial} raster/man/extract.Rd0000644000176200001440000002244414160021141014262 0ustar liggesusers\name{extract} \docType{methods} \alias{extract} \alias{extract,Raster,vector-method} \alias{extract,Raster,matrix-method} \alias{extract,Raster,data.frame-method} \alias{extract,Raster,SpatialPoints-method} \alias{extract,Raster,SpatialLines-method} \alias{extract,Raster,SpatialPolygons-method} \alias{extract,Raster,sf-method} \alias{extract,Raster,Extent-method} \alias{extract,SpatialPolygons,SpatialPoints-method} \alias{extract,SpatialPolygons,data.frame-method} \alias{extract,SpatialPolygons,matrix-method} \title{Extract values from Raster objects} \description{ Extract values from a Raster* object at the locations of spatial vector data. There are methods for points, lines, and polygons (classes from `sp` or `sf`), for a matrix or data.frame of points. You can also use cell numbers and Extent (rectangle) objects to extract values. If \code{y} represents points, \code{extract} returns the values of a Raster* object for the cells in which a set of points fall. If \code{y} represents lines, the \code{extract} method returns the values of the cells of a Raster* object that are touched by a line. If \code{y} represents polygons, the \code{extract} method returns the values of the cells of a Raster* object that are covered by a polygon. A cell is covered if its center is inside the polygon (but see the \code{weights} option for considering partly covered cells; and argument \code{small} for getting values for small polygons). It is also possible to extract values for point locations from SpatialPolygons. } \usage{ \S4method{extract}{Raster,matrix}(x, y, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, ...) \S4method{extract}{Raster,SpatialLines}(x, y, fun=NULL, na.rm=FALSE, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, along=FALSE, sp=FALSE, ...) \S4method{extract}{Raster,SpatialPolygons}(x, y, fun=NULL, na.rm=FALSE, exact=FALSE, weights=FALSE, normalizeWeights=TRUE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...) \S4method{extract}{SpatialPolygons,SpatialPoints}(x, y, ...) } \arguments{ \item{x}{Raster* object} \item{y}{points represented by a two-column matrix or data.frame, or \code{\link{SpatialPoints}*}; \code{\link{SpatialPolygons}*}; \code{\link[sp]{SpatialLines}}; \code{sf} spatial vector objects; \code{\link{Extent}}; or a numeric vector representing cell numbers} \item{method}{character. \code{'simple'} or \code{'bilinear'}. If \code{'simple'} values for the cell a point falls in are returned. If \code{'bilinear'} the returned values are interpolated from the values of the four nearest raster cells.} \item{buffer}{numeric. The radius of a buffer around each point from which to extract cell values. If the distance between the sampling point and the center of a cell is less than or equal to the buffer, the cell is included. The buffer can be specified as a single value, or as a vector of the length of the number of points. If the data are not projected (latitude/longitude), the unit should be meters. Otherwise it should be in map-units (typically also meters).} \item{small}{logical. If \code{TRUE} and \code{y} represents points and a \code{buffer} argument is used, the function always return a number, also when the buffer does not include the center of a single cell. The value of the cell in which the point falls is returned if no cell center is within the buffer. If \code{y} represents polygons, a value is also returned for relatively small polygons (e.g. those smaller than a single cell of the Raster* object), or polygons with an odd shape, for which otherwise no values are returned because they do not cover any raster cell centers. In some cases, you could alternatively use the centroids of such polygons, for example using \code{extract(x, coordinates(y))} or \code{extract(x, coordinates(y), method='bilinear')}.} \item{fun}{function to summarize the values (e.g. \code{mean}). The function should take a single numeric vector as argument and return a single value (e.g. mean, min or max), and accept a \code{na.rm} argument. Thus, standard R functions not including an na.rm argument must be wrapped as in this example: fun=function(x,...)length(x). If \code{y} represents points, \code{fun} is only used when a buffer is used (and hence multiple values per spatial feature would otherwise be returned).} \item{na.rm}{logical. Only useful when an argument \code{fun} is supplied. If \code{na.rm=TRUE} (the default value), NA values are removed before fun is applied. This argument may be ignored if the function used has a \code{...} argument and ignores an additional \code{na.rm} argument} \item{cellnumbers}{logical. If \code{cellnumbers=TRUE}, cell-numbers will also be returned (if no \code{fun} argument is supplied, and when extracting values with points, if \code{buffer} is \code{NULL})} \item{df}{logical. If \code{df=TRUE}, results will be returned as a data.frame. The first column is a sequential ID, the other column(s) are the extracted values} \item{exact}{logical. If \code{TRUE} the fraction of each cell that is (partly) covered by the polygon is extracted, not only the cells of which the centers are covered. This option is particularly useful if the polygons are small relative to the cells size of the Raster* object} \item{weights}{logical. If \code{TRUE} the fraction of a cell that is covered is returned or used by \code{fun}. These can be used as weights can be used for averaging; see examples. If \code{exact} is \code{FALSE}, this is the approximate fraction of each cell that is covered by the polygon, rounded to 1/100 } \item{normalizeWeights}{logical. If \code{TRUE}, weights are normalized such that they add up to one for each polygon} \item{factors}{logical. If \code{TRUE}, factor values are returned, else their integer representation is returned} \item{layer}{integer. First layer for which you want values (if \code{x} is a multilayer object)} \item{nl}{ integer. Number of layers for which you want values (if \code{x} is a multilayer object)} \item{along}{ boolean. Should returned values be ordered to go along the lines?} \item{sp}{ boolean. Should the extracted values be added to the data.frame of the Spatial* object \code{y}? This only applies if \code{y} is a Spatial* object and, for SpatialLines and SpatialPolygons, if \code{fun} is not NULL. In this case the returned value is the expanded Spatial object} \item{...}{additional arguments (none implemented)} } \value{ A vector for RasterLayer objects, and a matrix for RasterStack or RasterBrick objects. A list (or a data.frame if \code{df=TRUE}) if \code{y} is a SpatialPolygons* or SpatialLines* object or if a \code{buffer} argument is used (but not a \code{fun} argument). If \code{sp=TRUE} and \code{y} is a Spatial* object and \code{fun} is not NULL a Spatial* object is returned. The order of the returned values corresponds to the order of object \code{y}. If \code{df=TRUE}, this is also indicated in the first variable ('ID'). } \seealso{ \code{\link{getValues}, \link{getValuesFocal}} } \examples{ r <- raster(ncol=36, nrow=18, vals=1:(18*36)) ############################### # extract values by cell number ############################### extract(r, c(1:2, 10, 100)) s <- stack(r, sqrt(r), r/r) extract(s, c(1, 10, 100), layer=2, n=2) ############################### # extract values with points ############################### xy <- cbind(-50, seq(-80, 80, by=20)) extract(r, xy) sp <- SpatialPoints(xy) extract(r, sp, method='bilinear') # examples with a buffer extract(r, xy[1:3,], buffer=1000000) extract(r, xy[1:3,], buffer=1000000, fun=mean) ## illustrating the varying size of a buffer (expressed in meters) ## on a longitude/latitude raster z <- extract(r, xy, buffer=1000000) s <- raster(r) for (i in 1:length(z)) { s[z[[i]]] <- i } ## compare with raster that is not longitude/latitude crs(r) <- "+proj=utm +zone=17" xy[,1] <- 50 z <- extract(r, xy, buffer=8) for (i in 1:length(z)) { s[z[[i]]] <- i } plot(s) # library(maptools) # data(wrld_simpl) # plot(wrld_simpl, add=TRUE) ############################### # extract values with lines ############################### r <- raster(ncol=36, nrow=18, vals=1:(18*36)) cds1 <- rbind(c(-50,0), c(0,60), c(40,5), c(15,-45), c(-10,-25)) cds2 <- rbind(c(80,20), c(140,60), c(160,0), c(140,-55)) lines <- spLines(cds1, cds2) extract(r, lines) ############################### # extract values with polygons ############################### cds1 <- rbind(c(-180,-20), c(-160,5), c(-60, 0), c(-160,-60), c(-180,-20)) cds2 <- rbind(c(80,0), c(100,60), c(120,0), c(120,-55), c(80,0)) polys <- spPolygons(cds1, cds2) v <- extract(r, polys) # mean for each polygon unlist(lapply(v, function(x) if (!is.null(x)) mean(x, na.rm=TRUE) else NA )) # v <- extract(r, polys, cellnumbers=TRUE) # weighted mean # v <- extract(r, polys, weights=TRUE, fun=mean) # equivalent to: # v <- extract(r, polys, weights=TRUE) # sapply(v, function(x) if (!is.null(x)) {sum(apply(x, 1, prod)) / sum(x[,2])} else NA) ############################### # extract values with an extent ############################### e <- extent(150,170,-60,-40) extract(r, e) #plot(r) #plot(e, add=T) } \keyword{methods} \keyword{spatial} raster/man/crop.Rd0000644000176200001440000000476014160021141013554 0ustar liggesusers\name{crop} \alias{crop} \alias{crop,Raster-method} \alias{crop,Spatial-method} \alias{crop,Raster,ANY-method} \alias{crop,Spatial,ANY-method} \title{Crop} \description{ crop returns a geographic subset of an object as specified by an Extent object (or object from which an extent object can be extracted/created). If \code{x} is a Raster* object, the Extent is aligned to \code{x}. Areas included in \code{y} but outside the extent of \code{x} are ignored (see \code{\link{extend}} if you want a larger area). } \usage{ \S4method{crop}{Raster}(x, y, filename="", snap='near', datatype=NULL, ...) \S4method{crop}{Spatial}(x, y, ...) } \arguments{ \item{x}{Raster* object or SpatialPolygons*, SpatialLines*, or SpatialPoints* object} \item{y}{Extent object, or any object from which an Extent object can be extracted (see Details)} \item{filename}{Character, output filename. Optional} \item{snap}{Character. One of 'near', 'in', or 'out', for use with \code{\link{alignExtent}}} \item{datatype}{Character. Output \code{\link{dataType}} (by default it is the same as the input datatype)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \note{values within the extent of a Raster* object can be set to NA with \link[raster]{mask}} \details{ Objects from which an Extent can be extracted/created include RasterLayer, RasterStack, RasterBrick and objects of the Spatial* classes from the sp package. You can check this with the \code{\link[raster]{extent}} function. New Extent objects can also be created with function \code{\link{extent}} and \code{\link{drawExtent}} by clicking twice on a plot. To crop by row and column numbers you can create an extent like this (for Raster \code{x}, row 5 to 10, column 7 to 12) \code{crop(x, extent(x, 5, 10, 7, 12))} } \value{ RasterLayer or RasterBrick object; or SpatialLines or SpatialPolygons object. } \seealso{ \code{\link[raster]{extend}}, \code{\link[raster]{merge}} } \examples{ r <- raster(nrow=45, ncol=90) values(r) <- 1:ncell(r) e <- extent(-160, 10, 30, 60) rc <- crop(r, e) # use row and column numbers: rc2 <- crop(r, extent(r, 5, 10, 7, 15)) # crop Raster* with Spatial* object b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(r) rb <- crop(r, b) # crop a SpatialPolygon* object with another one if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) pb <- crop(p, b) } } \keyword{spatial} raster/man/intersect.Rd0000644000176200001440000000575214160021141014613 0ustar liggesusers\name{intersect} \docType{methods} \alias{intersect} \alias{intersect,Extent,ANY-method} \alias{intersect,Raster,ANY-method} \alias{intersect,SpatialPoints,ANY-method} \alias{intersect,SpatialPolygons,SpatialPolygons-method} \alias{intersect,SpatialPolygons,SpatialLines-method} \alias{intersect,SpatialPolygons,SpatialPoints-method} \alias{intersect,SpatialPolygons,ANY-method} \alias{intersect,SpatialLines,SpatialPolygons-method} \alias{intersect,SpatialLines,SpatialLines-method} \title{ Intersect } \description{ It depends on the classes of the \code{x} and \code{y} what is returned. If \code{x} is a Raster* object the extent of \code{y} is used, irrespective of the class of \code{y}, and a Raster* is returned. This is equivalent to \code{\link{crop}}. If \code{x} is a Spatial* object, a new Spatial* object is returned. If \code{x} or \code{y} has a data.frame, these are also returned (after merging if necessary) as part of a Spatial*DataFrame, and this is how \code{intersect} is different from \code{rgeos::gIntersection} on which it depends. Intersecting SpatialPoints* with SpatialPoints* uses the extent (bounding box) of \code{y} to get the intersection. Intersecting of SpatialPoints* and SpatialLines* is not supported because of numerical inaccuracies with that. You can use \code{\link{buffer}}, to create SpatialPoygons* from SpatialLines* and use that in intersect. Or try \code{\link[rgeos:topo-bin-gIntersection]{gIntersection}}. } \usage{ \S4method{intersect}{Extent,ANY}(x, y) \S4method{intersect}{Raster,ANY}(x, y) \S4method{intersect}{SpatialPoints,ANY}(x, y) \S4method{intersect}{SpatialPolygons,SpatialPolygons}(x, y) \S4method{intersect}{SpatialPolygons,SpatialLines}(x, y) \S4method{intersect}{SpatialPolygons,SpatialPoints}(x, y) \S4method{intersect}{SpatialLines,SpatialPolygons}(x, y) \S4method{intersect}{SpatialLines,SpatialLines}(x, y) } \arguments{ \item{x}{Extent, Raster*, SpatialPolygons*, SpatialLines* or SpatialPoints* object} \item{y}{same as for \code{x}} } \value{ if \code{x} is an Extent object: Extent if \code{x} is a Raster* object: Raster* if \code{x} is a SpatialPoints* object: SpatialPoints* if \code{x} is a SpatialPolygons* object: SpatialPolygons* if \code{x} is a SpatialLines* object and if \code{y} is a SpatialLines* object: SpatialPoints* if \code{x} is a SpatialLines* object and if \code{y} is a SpatialPolygons* object: SpatialLines* } \seealso{ \code{\link{union}, \link[raster]{extent}, \link{crop}} } \examples{ e1 <- extent(-10, 10, -20, 20) e2 <- extent(0, 20, -40, 5) intersect(e1, e2) #SpatialPolygons if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') projection(b) <- projection(p) i <- intersect(p, b) plot(p) plot(b, add=TRUE, col='red') plot(i, add=TRUE, col='blue', lwd=2) } } \keyword{methods} \keyword{spatial} raster/man/buffer.Rd0000644000176200001440000000343314160021141014056 0ustar liggesusers\name{buffer} \alias{buffer} \alias{buffer,RasterLayer-method} \alias{buffer,Spatial-method} \title{buffer} \description{ Calculate a buffer around all cells that are not \code{NA} or around SpatialPoints, Lines, or Polygons. Note that the distance unit of the buffer \code{width} parameter is meters if the RasterLayer is not projected (\code{+proj=longlat}), and in map units (typically also meters) when it is projected. Except for SpatialLines and SpatialPolygons that are currently handled by rgeos, and can only deal with planar coordinate reference systems. } \usage{ \S4method{buffer}{RasterLayer}(x, width=0, filename='', doEdge=FALSE, ...) \S4method{buffer}{Spatial}(x, width=1, dissolve=TRUE, ...) } \arguments{ \item{x}{RasterLayer or Spatial* object} \item{width}{numeric > 0. Unit is meter if \code{x} has a longitude/latitude CRS, or mapunits in other cases} \item{filename}{character. Filename for the output RasterLayer (optional)} \item{doEdge}{logical. If \code{TRUE}, the \code{\link{boundaries}} function is called first. This may be efficient in cases where you compute a buffer around very large areas because \code{boundaries} determines the edge cells that matter for distance computation} \item{dissolve}{logical. If \code{TRUE}, buffer geometries of overlapping polygons are dissolved and all geometries are aggregated and attributes (the data.frame) are dropped} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{RasterLayer or SpatialPolygons* object} \seealso{ \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} } \examples{ r <- raster(ncol=36,nrow=18) values(r) <- NA r[500] <- 1 b <- buffer(r, width=5000000) #plot(b) } \keyword{spatial} raster/man/zvalues.Rd0000644000176200001440000000126214160021141014274 0ustar liggesusers\name{z-values} \alias{getZ} \alias{setZ} \title{Get or set z-values} \description{ Initial functions for a somewhat more formal approach to get or set z values (e.g. time) associated with layers of Raster* objects. In development. } \usage{ setZ(x, z, name='time') getZ(x) } \arguments{ \item{x}{Raster* object} \item{z}{vector of z values of any type (e.g. of class 'Date')} \item{name}{character label} } \value{ setZ: Raster* object getZ: vector } \examples{ r <- raster(ncol=10, nrow=10) s <- stack(lapply(1:3, function(x) setValues(r, runif(ncell(r))))) s <- setZ(s, as.Date('2000-1-1') + 0:2) s getZ(s) } \keyword{spatial} raster/man/distanceFromPoints.Rd0000644000176200001440000000262414160021141016421 0ustar liggesusers\name{distanceFromPoints} \alias{distanceFromPoints} \title{Distance from points} \description{ The function calculates the distance from a set of points to all cells of a Raster* object. The distance unit is in meters if the coordinate reference system (crs) of the Raster* object is (\code{+proj=longlat}) or assumed to be if the crs is \code{NA}. In all other cases it is in the units defined by the crs (which typically is meters). } \usage{ distanceFromPoints(object, xy, filename='', ...) } \arguments{ \item{object}{Raster object} \item{xy}{matrix of x and y coordinates, or a SpatialPoints* object.} \item{filename}{character. Optional filename for the output RasterLayer} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \details{ Distances for \code{longlat} data are computed on the WGS84 spheroid using GeographicLib (Karney, 2013) } \references{ C.F.F. Karney, 2013. Algorithms for geodesics, J. Geodesy 87: 43-55. \doi{10.1007/s00190-012-0578-z}. } \value{RasterLayer} \seealso{ \code{\link{crs}}, \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} } \examples{ r <- raster(ncol=36,nrow=18) xy <- c(0,0) d1 <- distanceFromPoints(r, xy) crs(r) = '+proj=utm +zone=12 +datum=WGS84' d2 <- distanceFromPoints(r, xy) par(mfrow=c(1,2)) plot(d1) plot(d2) } \keyword{spatial} raster/man/cellFrom.Rd0000644000176200001440000000640714160021141014354 0ustar liggesusers\name{cellFrom} \alias{cellFromRowCol} \alias{cellFromRowCol,BasicRaster,numeric,numeric-method} \alias{colFromX} \alias{colFromX,BasicRaster,numeric-method} \alias{rowFromY} \alias{rowFromY,BasicRaster,numeric-method} \alias{cellFromXY} \alias{cellFromXY,BasicRaster,ANY-method} \alias{cellFromRow} \alias{cellFromCol} \alias{cellFromRowColCombine} \alias{cellFromRowColCombine,BasicRaster,numeric,numeric-method} \alias{fourCellsFromXY} \alias{cellFromLine} \alias{cellFromPolygon} \title{Get cell, row, or column number} \description{ Get cell number(s) of a Raster* object from row and/or column numbers. Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \usage{ cellFromRowCol(object, row, col, ...) cellFromRowColCombine(object, row, col, ...) cellFromRow(object, rownr) cellFromCol(object, colnr) colFromX(object, x) rowFromY(object, y) cellFromXY(object, xy) cellFromLine(object, lns) cellFromPolygon(object, p, weights=FALSE) fourCellsFromXY(object, xy, duplicates=TRUE) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{colnr}{column number; or vector of column numbers} \item{rownr}{row number; or vector of row numbers} \item{col}{column number; or vector of column numbers} \item{row}{row number; or vector of row numbers} \item{x}{x coordinate(s)} \item{y}{y coordinate(s)} \item{xy}{matrix of x and y coordinates, or a SpatialPoints or SpatialPointsDataFrame object} \item{lns}{SpatialLines object} \item{p}{SpatialPolygons object} \item{weights}{Logical. If \code{TRUE}, the fraction of each cell that is covered is also returned} \item{duplicates}{Logical. If \code{TRUE}, the same cell number can be returned twice (if the point in the middle of a division between two cells) or four times (if a point is in the center of a cell)} \item{...}{additional arguments (none implemented)} } \details{ \code{cellFromRowCol} returns the cell numbers obtained for each row / col number pair. In contrast, \code{cellFromRowColCombine} returns the cell numbers obtained by the combination of all row and column numbers supplied as arguments. \code{fourCellsFromXY} returns the four cells that are nearest to a point (if the point falls on the raster). Also see \code{\link{adjacent}}. } \value{ vector of row, column or cell numbers. \code{cellFromLine} and \code{cellFromPolygon} return a list, \code{fourCellsFromXY} returns a matrix. } \seealso{ \code{\link{xyFromCell}, \link{cellsFromExtent}, \link{rowColFromCell}} } \examples{ r <- raster(ncols=10, nrows=10) cellFromRowCol(r, 5, 5) cellFromRowCol(r, 1:2, 1:2) cellFromRowColCombine(r, 1:3, 1:2) cellFromCol(r, 1) cellFromRow(r, 1) colFromX(r, 0.5) rowFromY(r, 0.5) cellFromXY(r, cbind(c(0.5,5), c(15, 88))) fourCellsFromXY(r, cbind(c(0.5,5), c(15, 88))) cds1 <- rbind(c(-180,-20), c(-160,5), c(-60, 0), c(-160,-60), c(-180,-20)) cds2 <- rbind(c(80,0), c(100,60), c(120,0), c(120,-55), c(80,0)) pols <- SpatialPolygons(list(Polygons(list(Polygon(cds1)), 1), Polygons(list(Polygon(cds2)), 2))) cellFromPolygon(r, pols) } \keyword{spatial} raster/man/subset.Rd0000644000176200001440000000240314160021141014106 0ustar liggesusers\name{subset} \alias{subset} \alias{subset,Raster-method} \alias{subset,RasterStack-method} \title{Subset layers in a Raster* object} \description{ Extract a set of layers from a RasterStack or RasterBrick object. } \usage{ \S4method{subset}{Raster}(x, subset, drop=TRUE, filename='', ...) \S4method{subset}{RasterStack}(x, subset, drop=TRUE, filename='', ...) } \arguments{ \item{x}{RasterBrick or RasterStack object} \item{subset}{integer or character. Should indicate the layers (represented as integer or by their name)} \item{drop}{If \code{TRUE}, a selection of a single layer will be returned as a RasterLayer} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ Raster* object } \seealso{ \code{\link[raster:addLayer]{dropLayer}}} \examples{ s <- stack(system.file("external/rlogo.grd", package="raster")) sel <- subset(s, 2:3) # Note that this is equivalent to sel2 <- s[[2:3]] # and in this particular case: sel3 <- dropLayer(s, 1) nlayers(s) nlayers(sel) # effect of 'drop=FALSE' when selecting a single layer sel <- subset(s, 2) class(sel) sel <- subset(s, 2, drop=FALSE) class(sel) } \keyword{ spatial } raster/man/roundExtent.Rd0000644000176200001440000000167514160021141015132 0ustar liggesusers\name{Extent math} \alias{floor,Extent-method} \alias{ceiling,Extent-method} \title{round Extent coordinates} \description{ use \code{round(x, digits=0)} to round the coordinates of an Extent object to the number of digits specified. This can be useful when dealing with a small imprecision in the data (e.g. 179.9999 instead of 180). \code{floor} and \code{ceiling} move the coordiantes to the outer or inner whole integer numbers. It is also possible to use Arithmetic functions with Extent objects (but these work perhaps unexpectedly!) See \code{\link[raster]{Math-methods}} for these (and many more) methods with Raster* objects. } \usage{ \S4method{floor}{Extent}(x) \S4method{ceiling}{Extent}(x) } \arguments{ \item{x}{Extent object } } \seealso{\code{\link[raster]{Math-methods}}} \examples{ e <- extent(c(0.999999, 10.000011, -60.4, 60)) round(e) ceiling(e) floor(e) } \keyword{ spatial } raster/man/which.minmax.Rd0000644000176200001440000000341514160021141015177 0ustar liggesusers\name{which.min} \docType{methods} \alias{which.min} \alias{which.max} \alias{whiches.min} \alias{whiches.max} \alias{which.min,RasterLayer-method} \alias{which.max,RasterLayer-method} \alias{which.min,RasterStackBrick-method} \alias{which.max,RasterStackBrick-method} \alias{whiches.min,RasterStackBrick-method} \alias{whiches.max,RasterStackBrick-method} \title{Where is the min or max value?} \description{Which cells have the minumum / maximum value (for a RasterLayer), or which layer has the minimum/maximum value (for a RasterStack or RasterBrick)? which.min and which.max return the index of the first layer that has the min or max value for a cell. This can be problematic if there are ties. In you want the index of all the layers that have the min or max value, use whiches.min or whiches.max (only for objects with less than 10 layers). } \usage{ which.min(x) which.max(x) whiches.min(x, ...) whiches.max(x, ...) } \arguments{ \item{x}{Raster* object} \item{...}{additional arguments (none implemented)} } \value{ (which.*): vector of cell numbers (if \code{x} is a RasterLayer). If \code{x} is a RasterStack or RasterBrick, a RasterLayer giving the number of the first layer with the minimum or maximum value for a cell. (whiches.*). An integer in which each digit represents a layer. For example, 35 means "layers 3 and 5" } \note{ There is a limit to accurate integer number representation. Therefore, do not use \code{whiches.*} with more than 15 layers. } \seealso{ \code{\link{Which}}} \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) r <- which.min(b) i <- which.min(b[[3]]) xy <- xyFromCell(b, i) plot(b[[3]]) points(xy) x <- whiches.min(b) freq(x) } \keyword{spatial} raster/man/projection.Rd0000644000176200001440000000343514160235672015003 0ustar liggesusers\name{projection} \alias{wkt} \alias{wkt,ANY-method} \alias{wkt,Raster-method} \alias{crs} \alias{crs,ANY-method} \alias{crs<-} \alias{projection} \alias{projection<-} \alias{proj4string} \alias{proj4string,BasicRaster-method} \alias{proj4string,CRS-method} \alias{proj4string<-} \alias{as.character,CRS-method} \alias{is.na,CRS-method} \alias{crs<-,BasicRaster-method} \alias{crs<-,Spatial-method} \title{ Get or set a coordinate reference system (projection) } \description{ Get or set the coordinate reference system (CRS) of a Raster* object. } \usage{ \S4method{crs}{ANY}(x, asText=FALSE, ...) \S4method{wkt}{Raster}(obj) crs(x, ...) <- value projection(x, asText=TRUE) projection(x) <- value } \arguments{ \item{x}{Raster* or Spatial object } \item{obj}{Raster*, Spatial, or CRS object } \item{asText}{logical. If \code{TRUE}, the projection is returned as text. Otherwise a \code{\link[sp]{CRS-class}} object is returned} \item{...}{additional arguments. None implemented} \item{value}{\code{CRS} object or a character string describing a projection and datum in the PROJ.4 format } } \value{ Raster*, Spatial*, or character object } \note{ \code{crs} replaces earlier function \code{projection}. For compatibility with \code{sp} you can use \code{proj4string} instead of \code{crs}. \code{wkt} returns the "well-known-text" representation of the crs. } \seealso{ \code{\link[raster]{projectRaster}, \link[rgdal]{CRS-class}, \link[sp]{spTransform}, \link[rgdal]{projInfo}}} \details{ projections are done by with the PROJ.4 library exposed by rgdal } \examples{ r <- raster() crs(r) crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +datum=WGS84" crs(r) w <- wkt(r) w cat(w, "\n") } \keyword{ spatial } raster/man/KML.Rd0000644000176200001440000000470014160021141013226 0ustar liggesusers\name{KML} \alias{KML} \alias{KML,Spatial-method} \alias{KML,RasterLayer-method} \alias{KML,RasterStackBrick-method} \title{Write a KML or KMZ file} \description{ Export raster data to a KML file and an accompanying PNG image file. Multi-layer objects can be used to create an animation. The function attempts to combine these into a single (and hence more convenient) KMZ file (a zip file containing the KML and PNG files). See package plotKML for more advanced functionality } \usage{ \S4method{KML}{RasterLayer}(x, filename, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) \S4method{KML}{RasterStackBrick}(x, filename, time=NULL, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) \S4method{KML}{Spatial}(x, filename, zip='', overwrite=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{filename}{output filename} \item{time}{character vector with time lables for multilayer objects. The length of this vector should be nlayers(x) to indicate "when" or nlayers(x)+1 to indicate "begin-end"} \item{col}{color scheme to be used (see \link[graphics]{image})} \item{colNA}{The color to use for the background (default is transparent)} \item{maxpixels}{maximum number of pixels. If ncell(raster) > maxpixels, sampleRegular is used to reduce the number of pixels} \item{blur}{Integer (default=1). Higher values help avoid blurring of isolated pixels (at the expense of a png file that is blur^2 times larger)} \item{zip}{If there is no zip program on your path (on windows), you can supply the full path to a zip.exe here, in order to make a KMZ file} \item{overwrite}{logical. If \code{TRUE}, overwrite the file if it exists} \item{...}{If \code{x} is a Raster* object, additional arguments that can be passed to \link[graphics]{image}} } \value{ None. Used for the side-effect files written to disk. } \author{This function was adapted for the raster package by Robert J. Hijmans, with ideas from Tony Fischbach, and based on functions in the maptools package by Duncan Golicher, David Forrest and Roger Bivand.} \examples{ \dontrun{ # Meuse data from the sp package data(meuse.grid) b <- rasterFromXYZ(meuse.grid) projection(b) <- "+init=epsg:28992" # transform to longitude/latitude p <- projectRaster(b, crs="+proj=longlat +datum=WGS84", method='ngb') KML(p, file='meuse.kml') } } \keyword{spatial} raster/man/barplot.Rd0000644000176200001440000000275614160021141014257 0ustar liggesusers\name{barplot} \docType{methods} \alias{barplot} \alias{barplot,RasterLayer-method} \title{Bar plot of a RasterLayer} \description{Create a barplot of the values of a RasterLayer. For large datasets a regular sample with a size of approximately \code{maxpixels} is used.} \usage{ \S4method{barplot}{RasterLayer}(height, maxpixels=1000000, digits=0, breaks=NULL, col=rainbow, ...) } \arguments{ \item{height}{RasterLayer} \item{maxpixels}{integer. To regularly subsample very large objects} \item{digits}{integer used to determine how to \code{\link{round}} the values before tabulating. Set to \code{NULL} or to a large number if you do not want any rounding } \item{breaks}{breaks used to group the data as in \code{\link[base]{cut}}} \item{col}{a color generating function such as \code{\link{rainbow}}, or a vector of colors} \item{...}{additional arguments for plotting as in \code{\link[graphics]{barplot}}} } \seealso{ \code{\link{hist}, \link{boxplot}} } \value{ A numeric vector (or matrix, when \code{beside = TRUE}) of the coordinates of the bar midpoints, useful for adding to the graph. See \code{\link[graphics]{barplot}} } \examples{ f <- system.file("external/test.grd", package="raster") r <- raster(f) barplot(r, digits=-2, las=2, ylab='Frequency') op <- par(no.readonly = TRUE) par(mai = c(1, 2, .5, .5)) barplot(r, breaks=10, col=c('red', 'blue'), horiz=TRUE, digits=NULL, las=1) par(op) } \keyword{methods} \keyword{spatial} raster/man/sampleStratified.Rd0000644000176200001440000000330114160021141016077 0ustar liggesusers\name{sampleStratified} \alias{sampleStratified} \alias{sampleStratified,RasterLayer-method} \title{Stratified random sample} \description{ Take a stratified random sample from the cell values of a Raster* object (without replacement). An attempt is made to sample \code{size} cells from each stratum. The values in the RasterLayer \code{x} are rounded to integers; with each value representing a stratum. } \usage{ \S4method{sampleStratified}{RasterLayer}(x, size, exp=10, na.rm=TRUE, xy=FALSE, ext=NULL, sp=FALSE, ...) } \arguments{ \item{x}{Raster* object, with values (rounded to integers) representing strata} \item{size}{positive integer giving the number of items to choose} \item{exp}{numeric >= 1. 'Expansion factor' that is multiplied with size to get an intial sample. Can be increased when you get an insufficient number of samples for small strata} \item{na.rm}{logical. If \code{TRUE} (the default), \code{NA} values are removed from random sample} \item{xy}{logical. Return coordinates of cells rather than cell numbers} \item{ext}{Extent object. To limit regular sampling to the area within the extent} \item{sp}{logical. If \code{TRUE}, a SpatialPointsDataFrame is returned} \item{...}{Additional arguments. None implemented} } \details{ The function may not work well when the size (number of cells) of some strata is relatively small. } \value{ matrix of cell numbers (and optionally coordinates) by stratum } \seealso{\code{\link{sampleRandom}, \link{sampleRegular}}} \examples{ r <- raster(ncol=10, nrow=10) names(r) <- 'stratum' values(r) <- round((runif(ncell(r))+0.5)*3) sampleStratified(r, size=3) } \keyword{spatial} raster/man/hist.Rd0000644000176200001440000000253014160021141013551 0ustar liggesusers\name{hist} \docType{methods} \alias{hist} \alias{hist,Raster-method} \title{Histogram} \description{ Create a histogram of the values of a RasterLayer. For large datasets a sample is used. } \usage{ \S4method{hist}{Raster}(x, layer, maxpixels=100000, plot=TRUE, main, ...) } \arguments{ \item{x}{Raster* object} \item{layer}{integer (or character) to indicate layer number (or name). Can be used to subset the layers to plot in a multilayer Raster* object} \item{maxpixels}{integer. To regularly subsample very large objects} \item{plot}{logical. Plot the histogram or only return the histogram values} \item{main}{character. Main title(s) for the plot. Default is the value of \code{\link{names}}} \item{...}{Additional arguments. See under Methods and at \code{\link[graphics]{hist}}} } \value{ This function is principally used for the side-effect of plotting a histogram, but it also returns an S3 object of class 'histogram' (invisibly if \code{plot=TRUE}). } \seealso{ \code{\link{pairs}, \link{boxplot}} } \examples{ r1 <- raster(nrows=50, ncols=50) r1 <- setValues(r1, runif(ncell(r1))) r2 <- setValues(r1, runif(ncell(r1))) rs <- r1 + r2 rp <- r1 * r2 par(mfrow=c(2,2)) plot(rs, main='sum') plot(rp, main='product') hist(rs) a = hist(rp) a } \keyword{methods} \keyword{spatial} raster/man/transpose.Rd0000644000176200001440000000073314160021141014623 0ustar liggesusers\name{transpose} \docType{methods} \alias{t} \alias{t,RasterLayer-method} \alias{t,RasterStackBrick-method} \title{Transpose} \description{ Transpose a Raster* object } \usage{ t(x) } \arguments{ \item{x}{a Raster* object} } \value{ RasterLayer or RasterBrick } \seealso{ transpose: \code{\link{flip}, \link[raster]{rotate}} } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- 1:ncell(r) rt <- t(r) } \keyword{spatial} raster/man/crosstab.Rd0000644000176200001440000000305514160021141014425 0ustar liggesusers\name{crosstab} \docType{methods} \alias{crosstab} \alias{crosstab,Raster,Raster-method} \alias{crosstab,RasterStackBrick,missing-method} \title{Cross-tabulate} \description{ Cross-tabulate two RasterLayer objects, or mulitiple layers in a RasterStack or RasterBrick to create a contingency table. } \usage{ \S4method{crosstab}{Raster,Raster}(x, y, digits=0, long=FALSE, useNA=FALSE, progress='', ...) \S4method{crosstab}{RasterStackBrick,missing}(x, digits=0, long=FALSE, useNA=FALSE, progress='', ...) } \arguments{ \item{x}{Raster* object} \item{y}{Raster* object if \code{x} is a RasterLayer; Can be missing if \code{x} is a RasterStack or RasterBrick} \item{digits}{integer. The number of digits for rounding the values before cross-tabulation} \item{long}{logical. If \code{TRUE} the results are returned in 'long' format data.frame instead of a table} \item{useNA}{logical, indicting if the table should includes counts of \code{NA} values} \item{progress}{character. "text", "window", or "" (the default, no progress bar), only for large files that cannot be processed in one step} \item{...}{additional arguments. none implemented} } \value{ A table or data.frame } \seealso{ \code{\link[raster]{freq}}, \code{\link[raster]{zonal}} } \examples{ r <- raster(nc=5, nr=5) values(r) <- runif(ncell(r)) * 2 s <- setValues(r, runif(ncell(r)) * 3) crosstab(r,s) rs <- r/s r[1:5] <- NA s[20:25] <- NA x <- stack(r, s, rs) crosstab(x, useNA=TRUE, long=TRUE) } \keyword{methods} \keyword{spatial} raster/man/addLayer.Rd0000644000176200001440000000173514160021141014335 0ustar liggesusers\name{addLayer} \alias{addLayer} \alias{addLayer,Raster-method} \alias{dropLayer} \alias{dropLayer,RasterStack-method} \alias{dropLayer,RasterBrick-method} \title{Add or drop a layer} \description{ Add a layer to a Raster* object or drop a layer from a RasterStack or RasterBrick. The object returned is always a RasterStack (unless nothing to add or drop was provided, in which case the original object is returned). } \usage{ addLayer(x, ...) dropLayer(x, i, ...) } \arguments{ \item{x}{Raster* object} \item{i}{integer. Indices of the layers to be dropped} \item{...}{Additional arguments. The layers to add for addLayer. None implemented for dropLayer)} } \value{ RasterStack } \seealso{ \code{\link[raster]{subset}}} \examples{ file <- system.file("external/test.grd", package="raster") s <- stack(file, file, file) r <- raster(file) s <- addLayer(s, r/2, r*2) s s <- dropLayer(s, c(3, 5)) nlayers(s) } \keyword{ spatial } raster/man/clearValues.Rd0000644000176200001440000000072714160021141015056 0ustar liggesusers \name{clearValues} \alias{clearValues} \title{Clear values} \description{ Clear cell values of a Raster* object from memory } \usage{ clearValues(x) } \arguments{ \item{x}{Raster* object } } \seealso{ \code{\link{values}}, \code{\link[raster]{replacement} }} \value{ a Raster* object } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- 1:ncell(r) r <- clearValues(r) } \keyword{ spatial } \keyword{ methods } raster/man/origin.Rd0000644000176200001440000000150114160021141014066 0ustar liggesusers\name{origin} \alias{origin} \alias{origin,BasicRaster-method} \alias{origin<-} \alias{origin<-,BasicRaster-method} \title{Origin} \description{ Origin returns (or sets) the coordinates of the point of origin of a Raster* object. This is the point closest to (0, 0) that you could get if you moved towards that point in steps of the x and y resolution. } \usage{ origin(x, ...) origin(x) <- value } \arguments{ \item{x}{Raster* object} \item{value}{numeric vector of length 1 or 2} \item{...}{additional arguments. None implemented} } \value{ A vector of two numbers (x and y coordinates), or a changed origin for \code{x}. } \seealso{ \code{\link[raster]{extent}}} \examples{ r <- raster(xmn=-0.5, xmx = 9.5, ncols=10) origin(r) r origin(r) <- 0 r } \keyword{spatial} raster/man/datasource.Rd0000644000176200001440000000252414160021141014737 0ustar liggesusers\name{datasource} \alias{fromDisk} \alias{inMemory} \alias{inMemory,BasicRaster-method} \alias{hasValues} \alias{hasValues,BasicRaster-method} \title{Are values in memory and/or on disk?} \description{ These are helper functions for programmers and for debugging that provide information about whether a Raster object has associated values, and if these are in memory or on disk. \code{fromDisk} is \code{TRUE} if the data source is a file on disk; and \code{FALSE} if the object only exists in memory. \code{inMemory}i is \code{TRUE} if all values are currently in memory (RAM); and \code{FALSE} if not (in which case they either are on disk, or there are no values). \code{hasValues} is \code{TRUE} if the object has cell values. } \usage{ fromDisk(x) \S4method{inMemory}{BasicRaster}(x) \S4method{hasValues}{BasicRaster}(x) } \arguments{ \item{x}{ Raster* object } } \value{ Logical } \examples{ rs <- raster(system.file("external/test.grd", package="raster")) inMemory(rs) fromDisk(rs) rs <- readAll(rs) inMemory(rs) fromDisk(rs) rs <- rs + 1 inMemory(rs) fromDisk(rs) rs <- raster(rs) inMemory(rs) fromDisk(rs) rs <- setValues(rs, 1:ncell(rs)) inMemory(rs) fromDisk(rs) #rs <- writeRaster(rs, filename=rasterTmpFile(), overwrite=TRUE) #inMemory(rs) #fromDisk(rs) } \keyword{ spatial } raster/man/dimensions.Rd0000644000176200001440000000200514160021141014747 0ustar liggesusers\name{dim} \alias{dim} \alias{dim,RasterStackBrick-method} \alias{dim,BasicRaster-method} \alias{dim<-,BasicRaster-method} \alias{dim<-,RasterLayer-method} \alias{dim<-,RasterBrick-method} \docType{methods} \title{Dimensions of a Raster* object} \description{ Get or set the number of rows, columns, and layers of a Raster* object. You cannot use this function to set the dimensions of a RasterStack object. When setting the dimensions, you can provide a row number, or a vector with the row and the column number (for a RasterLayer and a RasterBrick), or a row and column number and the number of layers (only for a RasterBrick) } \usage{ \S4method{dim}{BasicRaster}(x) } \arguments{ \item{x}{Raster(* object} } \value{ Integer or Raster* object } \seealso{ \code{ \link{ncell}, \link{extent}, \link{res} } } \examples{ r <- raster() dim(r) dim(r) <- c(18) dim(r) dim(r) <- c(18, 36) dim(r) b <- brick(r) dim(b) dim(b) <- c(10, 10, 5) dim(b) } \keyword{spatial} raster/man/rowSums.Rd0000644000176200001440000000153614160021141014266 0ustar liggesusers\name{rowSums} \docType{methods} \alias{rowSums} \alias{rowSums,Raster-method} \alias{colSums} \alias{colSums,Raster-method} \title{rowSums and colSums for Raster objects} \description{ Sum values of Raster objects by row or column. } \usage{ \S4method{rowSums}{Raster}(x, na.rm=FALSE, dims=1L,...) \S4method{colSums}{Raster}(x, na.rm=FALSE, dims=1L,...) } \arguments{ \item{x}{Raster* object} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values are ignored} \item{dims}{this argument is ignored} \item{...}{additional arguments (none implemented)} } \value{ vector (if \code{x} is a RasterLayer) or matrix } \seealso{ See \code{\link{cellStats}} for summing all cells values } \examples{ r <- raster(ncols=2, nrows=5) values(r) <- 1:10 as.matrix(r) rowSums(r) colSums(r) } \keyword{spatial} raster/man/which.Rd0000644000176200001440000000253014160021141013704 0ustar liggesusers\name{which} \docType{methods} \alias{Which} \alias{Which,RasterLayer-method} \title{Which cells are TRUE?} \description{ \code{Which} returns a RasterLayer with \code{TRUE} or \code{FALSE} setting cells that are \code{NA} to \code{FALSE} (unless \code{na.rm=FALSE}). If the RasterLayer has numbers, all values that are 0 become \code{FALSE} and all other values become \code{TRUE}. The function can also return the cell numbers that are \code{TRUE} } \usage{ \S4method{Which}{RasterLayer}(x, cells=FALSE, na.rm=TRUE, ...) } \arguments{ \item{x}{RasterLayer} \item{cells}{logical. If \code{TRUE}, cell numbers are returned, otherwise a RasterLayer is returned} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values are treated as \code{FALSE}, otherwise they remain \code{NA} (only when \code{cells=FALSE})} \item{...}{Additional arguments (none implemented)} } \seealso{ \code{\link{which.max}}, \code{\link{which.min}} } \value{ RasterLayer } \examples{ r <- raster(ncol=10, nrow=10) set.seed(0) values(r) <- runif(ncell(r)) r[r < 0.2 ] <- 0 r[r > 0.8] <- 1 r[r > 0 & r < 1 ] <- 0.5 Which(r, cells=TRUE) Which(r > 0.5, cells=TRUE) s1 <- r > 0.5 s2 <- Which(r > 0.5) s1[1:15] s2[1:15] # this expression x1 <- Which(r, na.rm=FALSE) # is the inverse of x2 <- r==0 } \keyword{spatial} raster/man/colortable.Rd0000644000176200001440000000141014160021141014724 0ustar liggesusers\name{colortable} \alias{colortable} \alias{colortable<-} \title{colortable} \description{ Get or set the colortable of a RasterLayer. A colortable is a vector of 256 colors in the RGB triple format as returned by the \code{\link{rgb}} function (e.g. "#C4CDDA"). When setting the colortable, it is assumed that the values are integers in the range [0,255] } \usage{ colortable(x) colortable(x) <- value } \arguments{ \item{x}{RasterLayer object} \item{value}{vector of 256 character values} } \seealso{ \code{\link[raster]{plotRGB}} } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- sample(0:255, ncell(r), replace=TRUE) ctab <- sample(rainbow(256)) colortable(r) <- ctab plot(r) head(colortable(r)) } \keyword{spatial} raster/man/summary.Rd0000644000176200001440000000135114160021141014277 0ustar liggesusers\name{Summary} \docType{methods} \alias{summary,RasterLayer-method} \alias{summary,RasterStackBrick-method} \title{Summary} \description{ Summarize a Raster* object. A sample is used for very large files. } \usage{ \S4method{summary}{RasterLayer}(object, maxsamp=100000, ...) } \arguments{ \item{object}{Raster* object} \item{maxsamp}{positive integer. Sample size used for large datasets} \item{...}{additional arguments. None implemented} } \value{matrix with (an estimate of) the median, minimum and maximum values, the first and third quartiles, and the number of cells with \code{NA} values} \seealso{ \code{\link{cellStats}, link[raster]{quantile}} } \keyword{methods} \keyword{spatial} raster/man/nlayers.Rd0000644000176200001440000000130414160021141014255 0ustar liggesusers\name{nlayers} \alias{nlayers} \alias{nlayers,BasicRaster-method} \alias{nlayers,Raster-method} \alias{nlayers,RasterStack-method} \alias{nlayers,RasterBrick-method} \alias{nlayers,Spatial-method} \title{Number of layers} \description{ Get the number of layers in a Raster* object, typically used with a (multilayer) RasterStack or RasterBrick object } \usage{ nlayers(x) } \arguments{ \item{x}{Raster* object} } \value{ integer } \seealso{ \code{\link[raster]{names}} } \examples{ r <- raster(ncols=10, nrows=10) values(r) <- 1:ncell(r) s <- stack(r, r, r) nlayers(s) s <- stack(s,s) nlayers(s) s <- dropLayer(s, 2:3) nlayers(s) } \keyword{spatial} raster/man/stackApply.Rd0000644000176200001440000000423014160021141014714 0ustar liggesusers\name{stackApply} \docType{methods} \alias{stackApply} \title{Apply a function on subsets of a RasterStack or RasterBrick} \description{ Apply a function on subsets of a RasterStack or RasterBrick. The layers to be combined are indicated with the vector \code{indices}. The function used should return a single value, and the number of layers in the output Raster* equals the number of unique values in \code{indices}. For example, if you have a RasterStack with 6 layers, you can use \code{indices=c(1,1,1,2,2,2)} and \code{fun=sum}. This will return a RasterBrick with two layers. The first layer is the sum of the first three layers in the input RasterStack, and the second layer is the sum of the last three layers in the input RasterStack. Indices are recycled such that \code{indices=c(1,2)} would also return a RasterBrick with two layers (one based on the odd layers (1,3,5), the other based on the even layers (2,4,6)). See \code{\link{calc}} if you want to use a more efficient function that returns multiple layers based on _all_ layers in the Raster* object. } \usage{ stackApply(x, indices, fun, filename='', na.rm=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{indices}{integer. Vector of length \code{nlayers(x)} (shorter vectors are recycled) containing all integer values between 1 and the number of layers of the output Raster*} \item{fun}{function that returns a single value, e.g. \code{mean} or \code{min}, and that takes a \code{na.rm} argument (or can pass through arguments via \code{...})} \item{na.rm}{logical. If \code{TRUE}, \code{NA} cells are removed from calculations} \item{filename}{character. Optional output filename} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ A new Raster* object, and in some cases the side effect of a new file on disk. } \seealso{\code{\link{calc}, \link{stackSelect}}} \examples{ r <- raster(ncol=10, nrow=10) values(r) <- 1:ncell(r) s <- brick(r,r,r,r,r,r) s <- s * 1:6 b1 <- stackApply(s, indices=c(1,1,1,2,2,2), fun=sum) b1 b2 <- stackApply(s, indices=c(1,2,3,1,2,3), fun=sum) b2 } \keyword{methods} \keyword{spatial} raster/man/movingFun.Rd0000644000176200001440000000343714160021141014561 0ustar liggesusers\name{movingFun} \alias{movingFun} \title{Moving functions} \description{ Helper function to compute 'moving' functions, such as the 'moving average' } \usage{ movingFun(x, n, fun=mean, type='around', circular=FALSE, na.rm=FALSE) } \arguments{ \item{x}{A vector of numbers} \item{n}{Size of the 'window', i.e. the number of sequential elements to use in the function} \item{fun}{A function like mean, min, max, sum} \item{type}{Character. One of 'around', 'to', or 'from'. The choice indicates which values should be used in the computation. The focal element is always used. If \code{type} is 'around', the other elements are before and after the focal element. Alternatively, you can select the elements preceding the focal element ('to') or those coming after it {'from'}. For example, to compute the movingFun with \code{n=3} for element 5 of a vector; 'around' used elements 4,5,6; 'to' used elements 3,4,5, and 'from' uses elements 5,6,7} \item{circular}{Logical. If \code{TRUE}, the data are considered to have a circular nature (e.g. months of the year), and the last elements in vector \code{x} are used in the computation of the moving function of the first element(s) of the vector, and the first elements are used in the computation of the moving function for the last element(s)} \item{na.rm}{Logical. If \code{TRUE}, \code{NA} values should be ingored (by \code{fun})} } \value{ Numeric } \author{Robert J. Hijmans, inspired by Diethelm Wuertz' rollFun function in the fTrading package} \examples{ movingFun(1:12, 3, mean) movingFun(1:12, 3, mean, 'to') movingFun(1:12, 3, mean, 'from') movingFun(1:12, 3, mean, circular=TRUE) v <- c(0,1,2,3,3,3,3,4,4,4,5,5,6,7,7,8,9,NA) movingFun(v, n=5) movingFun(v, n=5, na.rm=TRUE) } \keyword{spatial} raster/man/approxNA.Rd0000644000176200001440000000623514160021141014340 0ustar liggesusers\name{approxNA} \docType{methods} \alias{approxNA} \alias{approxNA,RasterStackBrick-method} \title{Estimate values for cell values that are \code{NA} by interpolating between layers} \description{ approxNA uses the \code{stats} function \code{\link{approx}} to estimate values for cells that are \code{NA} by interpolation across layers. Layers are considered equidistant, unless an argument 'z' is used, or \code{\link{getZ}} returns values, in which case these values are used to determine distance between layers. For estimation based on neighbouring cells see \code{\link{focal}} } \usage{ \S4method{approxNA}{RasterStackBrick}(x, filename="", method="linear", yleft, yright, rule=1, f=0, ties=mean, z=NULL, NArule=1, ...) } \arguments{ \item{x}{RasterStack or RasterBrick object} \item{filename}{character. Output filename (optional)} \item{method}{specifies the interpolation method to be used. Choices are "linear" or "constant" (step function; see the example in \code{\link{approx}}} \item{yleft}{the value to be returned before a non-\code{NA} value is encountered. The default is defined by the value of rule given below} \item{yright}{the value to be returned after the last non-\code{NA} value is encountered. The default is defined by the value of rule given below} \item{rule}{an integer (of length 1 or 2) describing how interpolation is to take place at for the first and last cells (before or after any non-\code{NA} values are encountered). If rule is 1 then NAs are returned for such points and if it is 2, the value at the closest data extreme is used. Use, e.g., \code{rule = 2:1}, if the left and right side extrapolation should differ} \item{f}{for method = "constant" a number between 0 and 1 inclusive, indicating a compromise between left- and right-continuous step functions. If y0 and y1 are the values to the left and right of the point then the value is \code{y0*(1-f)+y1*f} so that \code{f = 0)} is right-continuous and \code{f = 1} is left-continuous} \item{ties}{Handling of tied 'z' values. Either a function with a single vector argument returning a single number result or the string "ordered"} \item{z}{numeric vector to indicate the distance between layers (e.g., time, depth). The default is 1:nlayers(x) } \item{NArule}{single integer used to determine what to do when only a single layer with a non-\code{NA} value is encountered (and linear interpolation is not possible). The default value of 1 indicates that all layers will get this value for that cell; all other values do not change the cell values} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ RasterBrick } \seealso{ \code{ \link{focal}} } \examples{ r <- raster(ncols=5, nrows=5) r1 <- setValues(r, runif(ncell(r))) r2 <- setValues(r, runif(ncell(r))) r3 <- setValues(r, runif(ncell(r))) r4 <- setValues(r, runif(ncell(r))) r5 <- setValues(r, NA) r6 <- setValues(r, runif(ncell(r))) r1[6:10] <- NA r2[5:15] <- NA r3[8:25] <- NA s <- stack(r1,r2,r3,r4,r5,r6) s[1:5] <- NA x1 <- approxNA(s) x2 <- approxNA(s, rule=2) x3 <- approxNA(s, rule=2, z=c(1,2,3,5,14,15)) } \keyword{spatial} raster/man/metadata.Rd0000644000176200001440000000275414160021141014372 0ustar liggesusers\name{metadata} \alias{metadata} \alias{metadata,Raster-method} \alias{metadata<-} \title{ Metadata } \description{ Get or set a metadata to a Raster object } \usage{ \S4method{metadata}{Raster}(x) metadata(x) <- value } \arguments{ \item{x}{Raster* object } \item{value}{list with named elements. Each element may be another list of named elements (but these nested lists are not allowed to be lists themselves)} } \note{ The metadata can contain single values or vectors of basic data types (character, integer, numeric) and Date. Some other types may also be supported. You cannot use a matrix or data.frame as a meta-data element. } \value{ Raster* object or list } \examples{ r <- raster(nc=10, nr=10) values(r) <- 1:ncell(r) m <- list(wave=list(a=1, b=2, c=c('cool', 'important')), that=list(red='44', blue=1:5, days=as.Date(c('2014-1-15','2014-2-15'))), this='888 miles from here', today=NA) metadata(r) <- m \dontrun{ x <- writeRaster(r, rasterTmpFile(), overwrite=TRUE) metax <- metadata(x) identical(metax, m) # nested too deep badmeta1 <- list(wave=list(a=1, b=2, c='x'), that=list(red='4', blue=list(bad=5))) metadata(r) <- badmeta1 # missing names badmeta2 <- list(wave=list(1, 2, c='x'), that=list(red='44', blue=14), this='8m') metadata(r) <- badmeta2 # matrix not allowed badmeta3 <- list(wave=list(a=1, b=matrix(1:4, ncol=2), c='x'), that=list(red='4')) metadata(r) <- badmeta3 } } \keyword{ spatial } raster/man/layerize.Rd0000644000176200001440000000326614160021141014435 0ustar liggesusers\name{layerize} \docType{methods} \alias{layerize} \alias{layerize,RasterLayer,missing-method} \alias{layerize,RasterLayer,RasterLayer-method} \title{Layerize} \description{ Create a RasterBrick with a Boolean layer for each class (value, or subset of the values) in a RasterLayer. For example, if the cell values of a RasterLayer indicate what vegetation type they are, this function will create a layer (presence/absence; dummy variable) for each of these classes. Classes and cell values are always truncated to integers. You can supply a second spatially overlapping RasterLayer with larger cells (do not use smaller cells!). In this case the cell values are counts for each class. A similar result might be obtained more efficiently by using layerize with a single RasterLayer followed by \code{\link{aggregate}(x, , sum)}. } \usage{ \S4method{layerize}{RasterLayer,missing}(x, classes=NULL, falseNA=FALSE, filename='', ...) \S4method{layerize}{RasterLayer,RasterLayer}(x, y, classes=NULL, filename='', ...) } \arguments{ \item{x}{RasterLayer} \item{y}{RasterLayer or missing} \item{classes}{numeric. The values (classes) for which layers should be made. If \code{NULL} all classes are used} \item{falseNA}{logical. If \code{TRUE}, cells that are not of the class represented by a layer are \code{NA} rather then \code{FALSE}} \item{filename}{character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterBrick } \examples{ r <- raster(nrow=20, ncol=20) values(r) <- c(rep(NA, 50), rep(1:5, 70)) b <- layerize(r) r2 <- raster(nrow=5, ncol=5) b2 <- layerize(r, r2) } \keyword{spatial} raster/man/match.Rd0000644000176200001440000000225714160021141013704 0ustar liggesusers\name{match} \docType{methods} \alias{match} \alias{match,Raster-method} \alias{\%in\%} \alias{\%in\%,Raster-method} \title{Value matching for Raster* objects} \description{ \code{match} returns a Raster* object with the position of the matched values. The cell values are the index of the table argument. \code{\%in\%} returns a logical Raster* object indicating if the cells values were matched or not. } \usage{ match(x, table, nomatch = NA_integer_, incomparables = NULL) x \%in\% table } \arguments{ \item{x}{Raster* object} \item{table}{vector of the values to be matched against} \item{nomatch}{the value to be returned in the case when no match is found. Note that it is coerced to integer} \item{incomparables}{a vector of values that cannot be matched. Any value in x matching a value in this vector is assigned the nomatch value. For historical reasons, FALSE is equivalent to NULL} } \value{ Raster* object } \seealso{ \code{\link{calc}, \link[base]{match}} } \examples{ r <- raster(nrow=10, ncol=10) values(r) <- 1:100 m <- match(r, c(5:10, 50:55)) n <- r \%in\% c(5:10, 50:55) } \keyword{spatial} \keyword{methods} raster/man/cluster.Rd0000644000176200001440000001156214160021141014270 0ustar liggesusers\name{cluster} \alias{beginCluster} \alias{endCluster} \alias{clusterR} \title{Use a multi-core cluster} \description{ \code{beginCluster} creates, and \code{endCluster} deletes a 'snow' cluster object. This object can be used for multi-core computing with those 'raster' functions that support it. \code{beginCluster} determines the number of nodes (cores) that are available and uses all of them (unless the argument \code{n} is used). NOTE: beginCluster may fail when the package 'nws' is installed. You can fix that by removing the 'nws' package, or by setting the cluster type manually, e.g. \code{beginCluster(type="SOCK")} endCluster closes the cluster and removes the object. The use of the cluster is automatic in these functions: \code{\link{projectRaster}}, \code{\link{resample}} and in \code{\link{extract}} when using polygons. \code{clusterR} is a flexible interface for using cluster with other functions. This function only works with functions that have a Raster* object as first argument and that operate on a cell by cell basis (i.e., there is no effect of neigboring cells) and return an object with the same number of cells as the input raster object. The first argument of the function called must be a Raster* object. There can only be one Raster* object argument. For example, it works with \code{\link{calc}} and it also works with \code{\link{overlay}} as long as you provide a single RasterStack or RasterBrick as the first argument. This function is particularly useful to speed up computations in functions like predict, interpolate, and perhaps calc. Among other functions, it does _not_ work with merge, crop, mosaic, (dis)aggregate, resample, projectRaster, focal, distance, buffer, direction. But note that projectRaster has a build-in capacity for clustering that is automatically used if beginCluster() has been called. } \usage{ beginCluster(n, type='SOCK', nice, exclude) endCluster() clusterR(x, fun, args=NULL, export=NULL, filename='', cl=NULL, m=2, ...) } \arguments{ \item{n}{Integer. The number of nodes to be used (optional)} \item{type}{Character. The cluster type to be used} \item{nice}{Integer. To set the prioirty for the workers, between -20 and 20 (UNIX like platforms only)} \item{exclude}{Character. Packages to exclude from loading on the nodes (because they may fail there) but are required/loaded on the master } \item{x}{Raster* object} \item{fun}{function that takes \code{x} as its first argument} \item{args}{list with the arguments for the function (excluding \code{x}, which should always be the first argument} \item{export}{character. Vector of variable names to export to the cluster nodes such that the are visible to fun (e.g. a parameter that is not passed as an argument)} \item{filename}{character. Output filename (optional)} \item{cl}{cluster object (do not use it if beginCluster() has been called} \item{m}{tuning parameter to determine how many blocks should be used. The number is rounded and multiplied with the number of nodes.} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \note{ If you want to write your own cluster-enabled functions see \code{\link{getCluster}, \link{returnCluster}}, and the vignette about writing functions. } \value{ beginCluster and endCluster: None. The side effect is to create or delete a cluster object. clusterR: as for the function called with argument \code{fun} } \examples{ \dontrun{ # set up the cluster object for parallel computing beginCluster() r <- raster() values(r) <- 1:ncell(r) x <- clusterR(r, sqrt, verbose=T) f1 <- function(x) calc(x, sqrt) y <- clusterR(r, f1) s <- stack(r, r*2, r*3) f2 <- function(d,e,f) (d + e) / (f * param) param <- 122 ov <- clusterR(s, overlay, args=list(fun=f2), export='param') pts <- matrix(c(0,0, 45,45), ncol=2, byrow=T) d <- clusterR(r, distanceFromPoints, args=list(xy=pts)) values(r) <- runif(ncell(r)) m <- c(0, 0.25, 1, 0.25, 0.5, 2, 0.5, 1, 3) m <- matrix(m, ncol=3, byrow=TRUE) rc1 <- clusterR(r, reclassify, args=list(rcl=m, right=FALSE), filename=rasterTmpFile(), datatype='INT2S', overwrite=TRUE) # equivalent to: rc2 <- reclassify(r, rcl=m, right=FALSE, filename=rasterTmpFile(), datatype='INT2S', overwrite=TRUE) # example with the calc function a <- 10 f3 <- function(x) sum(x)+a z1 <- clusterR(s, calc, args=list(fun=f3), export='a') # for some raster functions that use another function as an argument # you can write your own parallel function instead of using clusterR # get cluster object created with beginCluster cl <- getCluster() library(parallel) clusterExport(cl, "a") z2 <- calc(s, fun=function(x){ parApply(cl, x, 1, f3)} ) # set flag that cluster is available again returnCluster() # # done with cluster object endCluster() } } \author{Matteo Mattiuzzi and Robert J. Hijmans} \keyword{ spatial } raster/man/text.Rd0000644000176200001440000000325714160021141013575 0ustar liggesusers\name{text} \docType{methods} \alias{text} \alias{text,RasterLayer-method} \alias{text,RasterStackBrick-method} \alias{text,SpatialPoints-method} \alias{text,SpatialPolygons-method} \title{Add labels to a map} \description{ Plots labels, that is a textual (rather than color) representation of values, on top an existing plot (map). } \usage{ \S4method{text}{RasterLayer}(x, labels, digits=0, fun=NULL, halo=FALSE, ...) \S4method{text}{RasterStackBrick}(x, labels, digits=0, fun=NULL, halo=FALSE, ...) \S4method{text}{SpatialPolygons}(x, labels, halo=FALSE, ...) \S4method{text}{SpatialPoints}(x, labels, halo=FALSE, ...) } \arguments{ \item{x}{Raster*, SpatialPoints* or SpatialPolygons* object} \item{labels}{character. Optional. Vector of labels with \code{length(x)} or a variable name from \code{names(x)}} \item{digits}{integer. how many digits should be used?} \item{fun}{function to subset the values plotted (as in \code{\link{rasterToPoints}})} \item{halo}{logical. If \code{TRUE} a 'halo' is printed around the text. If \code{TRUE}, additional arguments \code{hc='white'} and \code{hw=0.1} can be modified to set the colour and width of the halo} \item{...}{additional arguments to pass to graphics function \code{\link[graphics]{text}} } } \seealso{ \code{\link[graphics]{text}, \link[raster]{plot}} } \examples{ r <- raster(nrows=4, ncols=4) r <- setValues(r, 1:ncell(r)) plot(r) text(r) plot(r) text(r, halo=TRUE, hc='blue', col='white', hw=0.2) plot(r, col=bpy.colors(5)) text(r, fun=function(x){x<5 | x>12}, col=c('red', 'white'), vfont=c("sans serif", "bold"), cex=2) } \keyword{methods} \keyword{spatial} raster/man/draw.Rd0000644000176200001440000000156614160021141013547 0ustar liggesusers\name{draw} \alias{drawPoly} \alias{drawLine} \title{ Draw a line or polygon } \description{ Draw a line or polygon on a plot (map) and save it for later use. After calling the function, start clicking on the map. To finish, right-click and select 'stop'. } \usage{ drawPoly(sp=TRUE, col='red', lwd=2, ...) drawLine(sp=TRUE, col='red', lwd=2, ...) } \arguments{ \item{sp}{logical. If \code{TRUE}, the output will be a sp object (SpatialPolygons or SpatialLines). Otherwise a matrix of coordinates is returned} \item{col}{the color of the lines to be drawn} \item{lwd}{the width of the lines to be drawn} \item{...}{additional arguments padded to locator} } \value{ If \code{sp==TRUE} a SpatialPolygons or SpatialLines object; otherwise a matrix of coordinates } \seealso{ \code{\link[graphics]{locator}} } \keyword{ spatial } raster/man/trim.Rd0000644000176200001440000000254514160021141013563 0ustar liggesusers\name{trim} \alias{trim} \alias{trim,Raster-method} \alias{trim,character-method} \alias{trim,matrix-method} \alias{trim,data.frame-method} \title{Trim} \description{ Trim (shrink) a Raster* object by removing outer rows and columns that all have the same value (e.g. NA). Or remove the whitespace before or after a string of characters (or a matrix, or the character values in a data.frame). } \usage{ \S4method{trim}{Raster}(x, padding=0, values=NA, filename='', ...) \S4method{trim}{character}(x, internal=FALSE, ...) } \arguments{ \item{x}{Raster* object or a character string} \item{values}{numeric. Value(s) based on which a Raster* should be trimmed} \item{padding}{integer. Number of outer rows/columns to keep} \item{filename}{character. Optional output filename} \item{internal}{logical. If \code{TRUE}, sequential internal spaces are replaced by a single space} \item{...}{If \code{x} is a Raster* object: additional arguments as for \code{\link{writeRaster}}} } \value{ A RasterLayer or RasterBrick object (if \code{x} is a Raster* object) or a character string (if \code{x} is a character string). } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster(ncol=18,nrow=18) r[39:49] <- 1 r[113:155] <- 2 r[200] <- 6 s <- trim(r) trim(" hi folks ! ") } \keyword{spatial} raster/man/rasterize.Rd0000644000176200001440000001760614160021141014624 0ustar liggesusers\name{rasterize} \docType{methods} \alias{rasterize} \alias{rasterize,matrix,Raster-method} \alias{rasterize,data.frame,Raster-method} \alias{rasterize,sf,Raster-method} \alias{rasterize,SpatialPoints,Raster-method} \alias{rasterize,SpatialLines,Raster-method} \alias{rasterize,SpatialPolygons,Raster-method} \alias{rasterize,Extent,Raster-method} \title{Rasterize points, lines, or polygons} \description{ Transfer values associated with 'object' type spatial data (points, lines, polygons) to raster cells. For polygons, values are transferred if the polygon covers the center of a raster cell. For lines, values are transferred to all cells that are touched by a line. You can combine this behaviour by rasterizing polygons as lines first and then as polygons. If \code{x} represents points, each point is assigned to a grid cell. Points that fall on a border between cells are placed in the cell to the right and/or in the cell below. The value of a grid cell is determined by the values associated with the points and function \code{fun}. } \usage{ \S4method{rasterize}{matrix,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...) \S4method{rasterize}{SpatialPoints,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...) \S4method{rasterize}{SpatialLines,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", ...) \S4method{rasterize}{SpatialPolygons,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", getCover=FALSE, silent=TRUE, ...) } \arguments{ \item{x}{points (a SpatialPoints* object, or a two-column matrix (or data.frame)), SpatialLines*, SpatialPolygons*, or an Extent object } \item{y}{Raster* object} \item{field}{numeric or character. The value(s) to be transferred. This can be a single number, or a vector of numbers that has the same length as the number of spatial features (points, lines, polygons). If \code{x} is a Spatial*DataFrame, this can be the column name of the variable to be transferred. If missing, the attribute index is used (i.e. numbers from 1 to the number of features). You can also provide a vector with the same length as the number of spatial features, or a matrix where the number of rows matches the number of spatial features} \item{fun}{function or character. To determine what values to assign to cells that are covered by multiple spatial features. You can use functions such as \code{min, max}, or \code{mean}, or one of the following character values: \code{'first'}, \code{'last'}, \code{'count'}. The default value is \code{'last'}. In the case of SpatialLines*, \code{'length'} is also allowed (currently for planar coordinate systems only). If \code{x} represents points, \code{fun} must accept a \code{na.rm} argument, either explicitly or through 'dots'. This means that \code{fun=length} fails, but \code{fun=function(x,...)length(x)} works, although it ignores the \code{na.rm} argument. To use the \code{na.rm} argument you can use a function like this: fun=function(x, na.rm){if (na.rm) length(na.omit(x)) else (length(x)}, or use a function that removes \code{NA} values in all cases, like this function to compute the number of unique values per grid cell "richness": \code{fun=function(x, ...) {length(unique(na.omit(x)))} }. If you want to count the number of points in each grid cell, you can use \code{ fun='count'} or \code{fun=function(x,...){length(x)}}. You can also pass multiple functions using a statement like \code{fun=function(x, ...) c(length(x),mean(x))}, in which case the returned object is a RasterBrick (multiple layers). } \item{background}{numeric. Value to put in the cells that are not covered by any of the features of \code{x}. Default is \code{NA}} \item{mask}{logical. If \code{TRUE} the values of the input Raster object are 'masked' by the spatial features of \code{x}. That is, cells that spatially overlap with the spatial features retain their values, the other cells become \code{NA}. Default is \code{FALSE}. This option cannot be used when \code{update=TRUE}} \item{update}{logical. If \code{TRUE}, the values of the Raster* object are updated for the cells that overlap the spatial features of \code{x}. Default is \code{FALSE}. Cannot be used when \code{mask=TRUE}} \item{updateValue}{numeric (normally an integer), or character. Only relevant when \code{update=TRUE}. Select, by their values, the cells to be updated with the values of the spatial features. Valid character values are \code{'all'}, \code{'NA'}, and \code{'!NA'}. Default is \code{'all'}} \item{filename}{character. Output filename (optional)} \item{na.rm}{If \code{TRUE}, \code{NA} values are removed if \code{fun} honors the \code{na.rm} argument} \item{getCover}{logical. If \code{TRUE}, the fraction of each grid cell that is covered by the polygons is returned (and the values of \code{field, fun, mask}, and \code{update} are ignored. The fraction covered is estimated by dividing each cell into 100 subcells and determining presence/absence of the polygon in the center of each subcell} \item{silent}{Logical. If \code{TRUE}, feedback on the polygon count is suppressed. Default is \code{FALSE}} \item{...}{Additional arguments for file writing as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick } \seealso{ \code{\link{extract}} } \examples{ ############################### # rasterize points ############################### r <- raster(ncols=36, nrows=18) n <- 1000 set.seed(123) x <- runif(n) * 360 - 180 y <- runif(n) * 180 - 90 xy <- cbind(x, y) # get the (last) indices r0 <- rasterize(xy, r) # presence/absensce (NA) (is there a point or not?) r1 <- rasterize(xy, r, field=1) # how many points? r2 <- rasterize(xy, r, fun=function(x,...)length(x)) vals <- runif(n) # sum of the values associated with the points r3 <- rasterize(xy, r, vals, fun=sum) # with a SpatialPointsDataFrame vals <- 1:n p <- data.frame(xy, name=vals) coordinates(p) <- ~x+y r <- rasterize(p, r, 'name', fun=min) #r2 <- rasterize(p, r, 'name', fun=max) #plot(r, r2, cex=0.5) ############################### # rasterize lines ############################### cds1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60)) cds2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55)) cds3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45)) lines <- spLines(cds1, cds2, cds3) r <- raster(ncols=90, nrows=45) r <- rasterize(lines, r) \dontrun{ plot(r) plot(lines, add=TRUE) r <- rasterize(lines, r, fun='count') plot(r) values(r) <- 1:ncell(r) r <- rasterize(lines, r, mask=TRUE) plot(r) values(r) <- 1 r[lines] <- 10 plot(r) } ############################### # rasterize polygons ############################### p1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60), c(-180,-20)) hole <- rbind(c(-150,-20), c(-100,-10), c(-110,20), c(-150,-20)) p1 <- list(p1, hole) p2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55), c(-10,0)) p3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45), c(-125,0)) pols <- spPolygons(p1, p2, p3) r <- raster(ncol=90, nrow=45) r <- rasterize(pols, r, fun=sum) \dontrun{ plot(r) plot(pols, add=T) # add a polygon p5 <- rbind(c(-180,10), c(0,90), c(40,90), c(145,-10), c(-25, -15), c(-180,0), c(-180,10)) addpoly <- SpatialPolygons(list(Polygons(list(Polygon(p5)), 1))) addpoly <- as(addpoly, "SpatialPolygonsDataFrame") addpoly@data[1,1] <- 10 r2 <- rasterize(addpoly, r, field=1, update=TRUE, updateValue="NA") plot(r2) plot(pols, border="blue", lwd=2, add=TRUE) plot(addpoly, add=TRUE, border="red", lwd=2) # get the percentage cover of polygons in a cell r3 <- raster(ncol=36, nrow=18) r3 <- rasterize(pols, r3, getCover=TRUE) } } \keyword{methods} \keyword{spatial} raster/man/corLocal.Rd0000644000176200001440000000404014160021141014336 0ustar liggesusers\name{corLocal} \docType{methods} \alias{corLocal} \alias{corLocal,RasterLayer,RasterLayer-method} \alias{corLocal,RasterStackBrick,RasterStackBrick-method} \title{Local correlation coefficient} \description{ Local correlation coefficient for two RasterLayer objects (using a focal neighborhood) or for two RasterStack or Brick objects (with the same number of layers (> 2)) } \usage{ \S4method{corLocal}{RasterLayer,RasterLayer}(x, y, ngb=5, method=c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) \S4method{corLocal}{RasterStackBrick,RasterStackBrick}(x, y, method=c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) } \arguments{ \item{x}{RasterLayer or RasterStack/RasterBrick} \item{y}{object of the same class as \code{x}, and with the same number of layers} \item{ngb}{neighborhood size. Either a single integer or a vector of two integers c(nrow, ncol)} \item{method}{character indicating which correlation coefficient is to be used. One of \code{"pearson"}, \code{"kendall"}, or \code{"spearman"}} \item{test}{logical. If \code{TRUE}, return a p-value} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \note{\code{NA} values are omitted} \value{ RasterLayer } \seealso{ \code{\link{cor}}, \code{\link{cor.test}} } \examples{ b <- stack(system.file("external/rlogo.grd", package="raster")) b <- aggregate(b, 2, mean) set.seed(0) b[[2]] <- flip(b[[2]], 'y') + runif(ncell(b)) b[[1]] <- b[[1]] + runif(ncell(b)) x <- corLocal(b[[1]], b[[2]], test=TRUE ) # plot(x) # only cells where the p-value < 0.1 xm <- mask(x[[1]], x[[2]] < 0.1, maskvalue=FALSE) plot(xm) # for global correlation, use the cor function x <- as.matrix(b) cor(x, method="spearman") # use sampleRegular for large datasets x <- sampleRegular(b, 1000) cor.test(x[,1], x[,2]) # RasterStack or Brick objects y <- corLocal(b, flip(b, 'y')) } \keyword{methods} \keyword{spatial} raster/man/alignExtent.Rd0000644000176200001440000000215114160021141015063 0ustar liggesusers\name{alignExtent} \alias{alignExtent} \title{Align an extent (object of class Extent)} \description{ Align an Extent object with the (boundaries of the) cells of a Raster* object } \usage{ alignExtent(extent, object, snap='near') } \arguments{ \item{extent}{Extent object} \item{object}{Raster* object} \item{snap}{Character. One of 'near', 'in', or 'out', to determine in which direction the extent should be aligned. To the nearest border, inwards or outwards} } \value{ Extent object } \details{ Aligning an Extent object to another object assures that it gets the same origin and resolution. This should only be used to adjust objects because of imprecision in the data. alignExtent should not be used to force data to match that really does not match (use e.g. \code{\link{resample}} or (dis)aggregate for this). } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{drawExtent}}, \code{\link[raster]{Extent-class}} } \examples{ r <- raster() e <- extent(-10.1, 9.9, -20.1, 19.9) ea <- alignExtent(e, r) e extent(r) ea } \keyword{spatial} raster/man/RGB.Rd0000644000176200001440000000347214160021141013222 0ustar liggesusers\name{RGB} \docType{methods} \alias{RGB} \alias{RGB,RasterLayer-method} \title{Create a Red-Green-Blue Raster object} \description{ Make a Red-Green-Blue object that can be used to create images. } \usage{ \S4method{RGB}{RasterLayer}(x, filename='', col=rainbow(25), breaks=NULL, alpha=FALSE, colNA='white', zlim=NULL, zlimcol=NULL, ext=NULL, ...) } \value{RasterBrick} \arguments{ \item{x}{RasterLayer} \item{filename}{character. Output filename (optional)} \item{col}{A color palette, that is a vector of n contiguous colors generated by functions like \link{rainbow}, \link{heat.colors}, \link{topo.colors}, \link[sp]{bpy.colors} or one or your own making, perhaps using \code{\link{colorRampPalette}}. If none is provided, \code{rev(terrain.colors(255))} is used unless \code{x} has a 'color table'} \item{breaks}{numeric. A set of finite numeric breakpoints for the colours: must have one more breakpoint than colour and be in increasing order} \item{alpha}{If \code{TRUE} a fourth layer to set the background transparency is added} \item{colNA}{color for the background (\code{NA} values)} \item{zlim}{vector of lenght 2. Range of values to plot} \item{zlimcol}{If \code{NULL} the values outside the range of zlim get the color of the extremes of the range. If zlimcol has any other value, the values outside the zlim range get the color of \code{NA} values (see colNA)} \item{ext}{An \code{\link{Extent}} object to zoom in to a region of interest (see \code{\link{drawExtent}})} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \seealso{ \code{\link[raster]{plotRGB}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) x <- RGB(r) plot(x, col=gray(0:9/10)) plotRGB(x) } \keyword{methods} \keyword{spatial} raster/man/isLonLat.Rd0000644000176200001440000000256314160021141014335 0ustar liggesusers\name{isLonLat} \alias{isLonLat} \alias{isLonLat,BasicRaster-method} \alias{isLonLat,Spatial-method} \alias{isLonLat,CRS-method} \alias{isLonLat,character-method} \alias{isLonLat,ANY-method} \alias{couldBeLonLat} \alias{couldBeLonLat,BasicRaster-method} \alias{couldBeLonLat,Spatial-method} \alias{couldBeLonLat,ANY-method} \title{Is this longitude/latitude data?} \description{ Test whether a Raster* or other object has a longitude/latitude coordinate reference system (CRS) by inspecting the PROJ.4 coordinate reference system description. \code{couldBeLonLat} also returns \code{TRUE} if the CRS is \code{NA} but the x coordinates are within -365 and 365 and the y coordinates are within -90.1 and 90.1. } \usage{ \S4method{isLonLat}{BasicRaster}(x, ...) \S4method{isLonLat}{Spatial}(x, ...) \S4method{couldBeLonLat}{BasicRaster}(x, warnings=TRUE, ...) \S4method{couldBeLonLat}{Spatial}(x, warnings=TRUE, ...) } \arguments{ \item{x}{Raster* or Spatial* object} \item{warnings}{logical. If \code{TRUE}, a warning is given if the CRS is \code{NA} or when the CRS is longitude/latitude but the coordinates do not match that} \item{...}{additional arguments. None implemented} } \value{ Logical } \examples{ r <- raster() isLonLat(r) crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84" isLonLat(r) } \keyword{spatial} raster/man/Arith-methods.Rd0000644000176200001440000000614614160021141015321 0ustar liggesusers\name{Arith-methods} \docType{methods} \alias{Arith-methods} \alias{Arith,Extent,numeric-method} \alias{Arith,Raster,Raster-method} \alias{Arith,Raster,missing-method} \alias{Arith,RasterLayer,logical-method} \alias{Arith,RasterLayer,numeric-method} \alias{Arith,RasterLayerSparse,numeric-method} \alias{Arith,RasterStackBrick,logical-method} \alias{Arith,RasterStackBrick,numeric-method} \alias{Arith,logical,RasterLayer-method} \alias{Arith,logical,RasterStackBrick-method} \alias{Arith,numeric,Extent-method} \alias{Arith,numeric,RasterLayer-method} \alias{Arith,numeric,RasterLayerSparse-method} \alias{Arith,numeric,RasterStackBrick-method} \alias{+,SpatialPolygons,SpatialPolygons-method} \alias{+,SpatialLines,SpatialLines-method} \alias{+,SpatialPoints,SpatialPoints-method} \alias{-,SpatialPolygons,SpatialPolygons-method} \alias{*,SpatialPolygons,SpatialPolygons-method} \title{Arithmetic with Raster* objects} \description{ Standard arithmetic operators for computations with Raster* objects and numeric values. The following operators are available: \code{ +, -, *, /, ^, \%\%, \%/\% } The input Raster* objects should have the same extent, origin and resolution. If only the extent differs, the computation will continue for the intersection of the Raster objects. Operators are applied on a cell by cell basis. For a RasterLayer, numeric values are recycled by row. For a RasterStack or RasterBrick, recycling is done by layer. RasterLayer objects can be combined RasterStack/Brick objects, in which case the RasterLayer is 'recycled'. When using multiple RasterStack or RasterBrick objects, the number of layers of these objects needs to be the same. In addition to arithmetic with Raster* objects, the following operations are supported for SpatialPolygons* objects. Given SpatialPolygon objects \code{x} and \code{y}: \code{x+y} is the same as \code{\link{union}(x, y)}. For SpatialLines* and SpatialPoints* it is equivalent to \code{\link{bind}(x, y)} \code{x*y} is the same as \code{\link{intersect}(x, y)} \code{x-y} is the same as \code{\link{erase}(x, y)} } \details{ If the values of the output Raster* cannot be held in memory, they will be saved to a temporary file. You can use \code{\link{options}} to set the default file format, datatype and progress bar. } \value{ A Raster* object, and in some cases the side effect of a new file on disk. } \seealso{ \code{\link[raster]{Math-methods}}, \code{\link[raster]{overlay}}, \code{\link[raster]{calc}} } \examples{ r1 <- raster(ncols=10, nrows=10) values(r1) <- runif(ncell(r1)) r2 <- setValues(r1, 1:ncell(r1) / ncell(r1) ) r3 <- r1 + r2 r2 <- r1 / 10 r3 <- r1 * (r2 - 1 + r1^2 / r2) # recycling by row r4 <- r1 * 0 + 1:ncol(r1) # multi-layer object mutiplication, no recycling b1 <- brick(r1, r2, r3) b2 <- b1 * 10 # recycling by layer b3 <- b1 + c(1, 5, 10) # addition of the cell-values of two RasterBrick objects b3 <- b2 + b1 # summing two RasterBricks and one RasterLayer. The RasterLayer is 'recycled' b3 <- b1 + b2 + r1 } \keyword{methods} \keyword{math} \keyword{spatial} raster/man/as.list.Rd0000644000176200001440000000076414160021141014166 0ustar liggesusers\name{as.list} \alias{as.list,Raster-method} \title{Create a list of RasterLayer objects} \description{ Create a list of RasterLayer objects from Raster* objects } \usage{ \S4method{as.list}{Raster}(x, ...) } \arguments{ \item{x}{ Raster* object } \item{...}{additional Raster* objects} } \value{ list } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.list(r) s <- stack(r,r*2,r*3) as.list(s, r) } \keyword{spatial} \keyword{methods} raster/man/weighted.mean.Rd0000644000176200001440000000271414160021141015325 0ustar liggesusers\name{weighted.mean} \alias{weighted.mean} \alias{weighted.mean,RasterStackBrick,vector-method} \alias{weighted.mean,RasterStackBrick,RasterStackBrick-method} \title{Weighted mean of rasters} \description{ Computes the weighted mean for each cell of a number or raster layers. The weights can be spatially variable or not. } \usage{ \S4method{weighted.mean}{RasterStackBrick,vector}(x, w, na.rm=FALSE, filename='', ...) \S4method{weighted.mean}{RasterStackBrick,RasterStackBrick}(x, w, na.rm=FALSE,filename='', ...) } \arguments{ \item{x}{RasterStack or RasterBrick} \item{w}{A vector of weights (one number for each layer), or for spatially variable weights, a RasterStack or RasterBrick with weights (should have the same extent, resolution and number of layers as x)} \item{na.rm}{Logical. Should missing values be removed?} \item{filename}{Character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer } \seealso{ \code{\link{Summary-methods}}, \code{\link[stats]{weighted.mean}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) # give least weight to first layer, most to last layer wm1 <- weighted.mean(b, w=1:3) # spatially varying weights # weigh by column number w1 <- init(b, v='col') # weigh by row number w2 <- init(b, v='row') w <- stack(w1, w2, w2) wm2 <- weighted.mean(b, w=w) } raster/man/rasterFromXYZ.Rd0000644000176200001440000000353014160021141015342 0ustar liggesusers\name{rasterFromXYZ} \alias{rasterFromXYZ} \title{ Create a Raster* object from x, y, z values } \description{ Create a Raster* object from x, y and z values. x and y represent spatial coordinates and must be on a regular grid. If the resolution is not supplied, it is assumed to be the minimum distance between x and y coordinates, but a resolution of up to 10 times smaller is evaluated if a regular grid can otherwise not be created. z values can be single or multiple columns (variables) If the exact properties of the RasterLayer are known beforehand, it may be preferable to simply create a new RasterLayer with the raster function instead, compute cell numbers and assign the values with these (see example below). } \usage{ rasterFromXYZ(xyz, res=c(NA,NA), crs="", digits=5) } \arguments{ \item{xyz}{matrix or data.frame with at least three columns: x and y coordinates, and values (z). There may be several 'z' variables (columns)} \item{res}{numeric. The x and y cell resolution (optional)} \item{crs}{CRS object or a character string describing a projection and datum in PROJ.4 format} \item{digits}{numeric, indicating the requested precision for detecting whether points are on a regular grid (a low number of digits is a low precision)} } \value{ RasterLayer or RasterBrick } \seealso{See \code{\link{rasterize} for points that are not on a regular grid} } \examples{ r <- raster(nrow=5, ncol=5, xmn=0, xmx=10, ymn=0, ymx=10, crs="") set.seed(1) values(r) <- sample(1:25) r[r < 15] <- NA xyz <- rasterToPoints(r) rst <- rasterFromXYZ(xyz) # equivalent to: rr <- raster(nrow=5, ncol=5, xmn=0, xmx=10, ymn=0, ymx=10) cells <- cellFromXY(rr, xyz[,1:2]) rr[cells] <- xyz[,3] # multiple layers xyzz <- cbind(xyz, a=1:nrow(xyz), b=nrow(xyz):1) b <- rasterFromXYZ(xyzz) } \keyword{methods} \keyword{spatial} raster/man/disaggregate.Rd0000644000176200001440000000306614160021141015235 0ustar liggesusers\name{disaggregate} \alias{disaggregate} \alias{disaggregate,Raster-method} \title{Disaggregate} \description{ Disaggregate a RasterLayer to create a new RasterLayer with a higher resolution (smaller cells). The values in the new RasterLayer are the same as in the larger original cells unless you specify \code{method="bilinear"}, in which case values are locally interpolated (using the \code{\link[raster]{resample}} function). } \usage{ \S4method{disaggregate}{Raster}(x, fact=NULL, method='', filename='', ...) } \arguments{ \item{x}{a Raster object} \item{fact}{integer. amount of disaggregation expressed as number of cells (horizontally and vertically). This can be a single integer or two integers c(x,y), in which case the first one is the horizontal disaggregation factor and y the vertical disaggreation factor. If a single integer value is supplied, cells are disaggregated with the same factor in x and y direction} \item{method}{Character. \code{''} or \code{'bilinear'}. If \code{'bilinear'}, values are locally interpolated (using the \code{\link[raster]{resample}} function} \item{filename}{Character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ Raster object } \seealso{ \code{\link[raster]{aggregate}} } \author{Robert J. Hijmans and Jim Regetz} \examples{ r <- raster(ncols=10, nrows=10) rd <- disaggregate(r, fact=c(10, 2)) ncol(rd) nrow(rd) values(r) <- 1:ncell(r) rd <- disaggregate(r, fact=c(4, 2), method='bilinear') } \keyword{spatial} raster/man/flip.Rd0000644000176200001440000000201614160021141013533 0ustar liggesusers\name{flip} \docType{methods} \alias{flip} \alias{flip,RasterLayer-method} \alias{flip,RasterStackBrick-method} \title{Flip} \description{ Flip the values of a Raster* object by inverting the order of the rows (direction=y) or the columns direction='x'. } \usage{ \S4method{flip}{RasterLayer}(x, direction='y', filename='', ...) \S4method{flip}{RasterStackBrick}(x, direction='y', filename='', ...) } \arguments{ \item{x}{Raster* object} \item{direction}{Character. 'y' or 'x'; or 1 (=x) or 2 (=y)} \item{filename}{character. Output filename (optional)} \item{...}{if \code{x} is a Raster* object, additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick } \seealso{ transpose: \code{\link{t}}, \code{\link[raster]{rotate}} } \examples{ r <- raster(nrow=18, ncol=36) m <- matrix(1:ncell(r), nrow=18) values(r) <- as.vector(t(m)) rx <- flip(r, direction='x') values(r) <- as.vector(m) ry <- flip(r, direction='y') } \keyword{spatial} raster/man/sampleRandom.Rd0000644000176200001440000000334514160021141015231 0ustar liggesusers\name{sampleRandom} \alias{sampleRandom} \alias{sampleRandom,Raster-method} \title{Random sample} \description{ Take a random sample from the cell values of a Raster* object (without replacement). } \usage{ \S4method{sampleRandom}{Raster}(x, size, na.rm=TRUE, ext=NULL, cells=FALSE, rowcol=FALSE, xy=FALSE, sp=FALSE, asRaster=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{size}{positive integer giving the number of items to choose} \item{na.rm}{logical. If \code{TRUE} (the default), \code{NA} values are removed from random sample} \item{ext}{Extent object. To limit regular sampling to the area within the extent} \item{cells}{logical. If \code{TRUE}, sampled cell numbers are also returned} \item{rowcol}{logical. If \code{TRUE}, sampled row and column numbers are also returned} \item{xy}{logical. If \code{TRUE}, coordinates of sampled cells are also returned} \item{sp}{logical. If \code{TRUE}, a SpatialPointsDataFrame is returned} \item{asRaster}{logical. If \code{TRUE}, a Raster* object is returned with random cells with values, all other cells with \code{NA}} \item{...}{Additional arguments as in \code{\link{writeRaster}}. Only relevant when \code{asRaster=TRUE}} } \details{ With argument \code{na.rm=TRUE}, the returned sample may be smaller than requested } \value{ A vector, matrix (if \code{cells=TRUE} or \code{x} is a multi-layered object), or a SpatialPointsDataFrame (if \code{sp=TRUE} ) } \seealso{\code{\link{sampleRegular}, \link{sampleStratified}}} \examples{ r <- raster(system.file("external/test.grd", package="raster")) sampleRandom(r, size=10) s <- stack(r, r) sampleRandom(s, size=5, cells=TRUE, sp=TRUE) } \keyword{spatial} raster/man/symdif.Rd0000644000176200001440000000146214160021141014100 0ustar liggesusers\name{symdif} \docType{methods} \alias{symdif} \alias{symdif,SpatialPolygons,SpatialPolygons-method} \title{ Symetrical difference } \description{ Symetrical difference of SpatialPolygons* objects } \usage{ \S4method{symdif}{SpatialPolygons,SpatialPolygons}(x, y, ...) } \arguments{ \item{x}{SpatialPolygons* object} \item{y}{SpatialPolygons* object} \item{...}{Additional SpatialPolygons* object(s)} } \value{ SpatialPolygons* } \seealso{ \code{\link{erase}} } \examples{ #SpatialPolygons if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) sd <- symdif(p, b) plot(sd, col='red') } } \keyword{methods} \keyword{spatial} raster/man/erase.Rd0000644000176200001440000000274314160021141013707 0ustar liggesusers\name{erase} \docType{methods} \alias{erase} \alias{erase,SpatialPolygons,SpatialPolygons-method} \alias{erase,SpatialLines,SpatialPolygons-method} \title{ Erase parts of a SpatialPolygons* or SpatialLines* object. The inverse of this can be done with \code{\link{intersect}} } \description{ Erase parts of a SpatialPolygons* or SpatialLines* object with a SpatialPolygons* object } \usage{ \S4method{erase}{SpatialPolygons,SpatialPolygons}(x, y, ...) \S4method{erase}{SpatialLines,SpatialPolygons}(x, y, ...) } \arguments{ \item{x}{SpatialPolygons or SpatialLines object} \item{y}{SpatialPolygons object} \item{...}{Additional arguments (none)} } \value{ Spatial* } \seealso{The equivalent for raster data is \code{\link{mask}}} \examples{ if (require(rgdal) & require(rgeos)) { # erase parts of polygons with other polygons p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) e <- erase(p, b) plot(e) # erase parts of lines with polygons r <- raster(extent(p) +c(-.1,.1,-.1,.1), crs=crs(p)) start <- xyFromCell(r, cellFromCol(r, 1)) end <- xyFromCell(r, cellFromCol(r, ncol(r))) lines <- do.call(spLines, lapply(1:10, function(i)rbind(start[i,], end[i,]))) crs(lines) <- crs(p) e2 <- erase(lines, p) plot(p) lines(lines, col='blue', lwd=4, lty=3) lines(e2, col='red', lwd=2) } } \keyword{methods} \keyword{spatial} raster/man/calc.Rd0000644000176200001440000001247514160021141013515 0ustar liggesusers\name{calc} \docType{methods} \alias{calc} \alias{calc,Raster,function-method} \title{Calculate} \description{ Calculate values for a new Raster* object from another Raster* object, using a formula. If \code{x} is a RasterLayer, \code{fun} is typically a function that can take a single vector as input, and return a vector of values of the same length (e.g. \code{sqrt}). If \code{x} is a RasterStack or RasterBrick, fun should operate on a vector of values (one vector for each cell). \code{calc} returns a RasterLayer if \code{fun} returns a single value (e.g. \code{sum}) and it returns a RasterBrick if \code{fun} returns more than one number, e.g., \code{fun=quantile}. In many cases, what can be achieved with \code{calc}, can also be accomplished with a more intuitive 'raster-algebra' notation (see \code{\link[raster]{Arith-methods}}). For example, \code{r <- r * 2} instead of \code{r <- calc(r, fun=function(x){x * 2}}, or \code{r <- sum(s)} instead of \code{r <- calc(s, fun=sum)}. However, \code{calc} should be faster when using complex formulas on large datasets. With \code{calc} it is possible to set an output filename and file type preferences. See (\code{\link[raster]{overlay}}) to use functions that refer to specific layers, like (\code{function(a,b,c){a + sqrt(b) / c}}) } \usage{ \S4method{calc}{Raster,function}(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{fun}{function} \item{filename}{character. Output filename (optional)} \item{na.rm}{Remove \code{NA} values, if supported by 'fun' (only relevant when summarizing a multilayer Raster object into a RasterLayer)} \item{forcefun}{logical. Force \code{calc} to not use fun with apply; for use with ambiguous functions and for debugging (see Details)} \item{forceapply}{logical. Force \code{calc} to use fun with apply; for use with ambiguous functions and for debugging (see Details)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ a Raster* object } \details{ The intent of some functions can be ambiguous. Consider: \code{library(raster)} \code{r <- raster(volcano)} \code{calc(r, function(x) x * 1:10)} In this case, the cell values are multiplied in a vectorized manner and a single layer is returned where the first cell has been multiplied with one, the second cell with two, the 11th cell with one again, and so on. But perhaps the intent was to create 10 new layers (\code{x*1, x*2, ...})? This can be achieved by using argument \code{forceapply=TRUE} \code{calc(r, function(x) x * 1:10, forceapply=TRUE)} } \note{ For large objects \code{calc} will compute values chunk by chunk. This means that for the result of \code{fun} to be correct it should not depend on having access to _all_ values at once. For example, to scale the values of a Raster* object by subtracting its mean value (for each layer), you would _not_ do, for Raster object \code{x}: \code{calc(x, function(x)scale(x, scale=FALSE))} Because the mean value of each chunk will likely be different. Rather do something like \code{m <- cellStats(x, 'mean')} \code{x - m} } \seealso{ \code{ \link[raster]{overlay}} , \code{ \link[raster]{reclassify}}, \link[raster]{Arith-methods}, \link[raster]{Math-methods}} \author{Robert J. Hijmans and Matteo Mattiuzzi} \examples{ r <- raster(ncols=36, nrows=18) values(r) <- 1:ncell(r) # multiply values with 10 fun <- function(x) { x * 10 } rc1 <- calc(r, fun) # set values below 100 to NA. fun <- function(x) { x[x<100] <- NA; return(x) } rc2 <- calc(r, fun) # set NA values to -9999 fun <- function(x) { x[is.na(x)] <- -9999; return(x)} rc3 <- calc(rc2, fun) # using a RasterStack as input s <- stack(r, r*2, sqrt(r)) # return a RasterLayer rs1 <- calc(s, sum) # return a RasterBrick rs2 <- calc(s, fun=function(x){x * 10}) # recycling by layer rs3 <- calc(s, fun=function(x){x * c(1, 5, 10)}) # use overlay when you want to refer to individual layer in the function # but it can be done with calc: rs4 <- calc(s, fun=function(x){x[1]+x[2]*x[3]}) ## # Some regression examples ## # create data r <- raster(nrow=10, ncol=10) s1 <- lapply(1:12, function(i) setValues(r, rnorm(ncell(r), i, 3))) s2 <- lapply(1:12, function(i) setValues(r, rnorm(ncell(r), i, 3))) s1 <- stack(s1) s2 <- stack(s2) # regression of values in one brick (or stack) with another s <- stack(s1, s2) # s1 and s2 have 12 layers; coefficients[2] is the slope fun <- function(x) { lm(x[1:12] ~ x[13:24])$coefficients[2] } x1 <- calc(s, fun) # regression of values in one brick (or stack) with 'time' time <- 1:nlayers(s) fun <- function(x) { lm(x ~ time)$coefficients[2] } x2 <- calc(s, fun) # get multiple layers, e.g. the slope _and_ intercept fun <- function(x) { lm(x ~ time)$coefficients } x3 <- calc(s, fun) ### A much (> 100 times) faster approach is to directly use ### linear algebra and pre-compute some constants ## add 1 for a model with an intercept X <- cbind(1, time) ## pre-computing constant part of least squares invXtX <- solve(t(X) \%*\% X) \%*\% t(X) ## much reduced regression model; [2] is to get the slope quickfun <- function(y) (invXtX \%*\% y)[2] x4 <- calc(s, quickfun) } \keyword{methods} \keyword{spatial} raster/man/cellStats.Rd0000644000176200001440000000415514160021141014545 0ustar liggesusers\name{cellStats} \alias{cellStats} \alias{cellStats,RasterLayer-method} \alias{cellStats,RasterStackBrick-method} \title{Statistics across cells} \description{ Compute statistics for the cells of each layer of a Raster* object. In the \code{raster} package, functions such as max, min, and mean, when used with Raster* objects as argument, return a new Raster* object (with a value computed for each cell). In contrast, cellStats returns a single value, computed from the all the values of a layer. Also see \code{\link{layerStats}} } \usage{ \S4method{cellStats}{RasterLayer}(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) \S4method{cellStats}{RasterStackBrick}(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{stat}{The function to be applied. See Details} \item{na.rm}{Logical. Should \code{NA} values be removed?} \item{asSample}{Logical. Only relevant for \code{stat=sd} in which case, if \code{TRUE}, the standard deviation for a sample (denominator is \code{n-1}) is computed, rather than for the population (denominator is \code{n})} \item{...}{Additional arguments } } \value{ Numeric } \details{ \code{cellStats} will fail (gracefully) for very large Raster* objects except for a number of known functions: sum, mean, min, max, sd, 'skew' and 'rms'. 'skew' (skewness) and 'rms' (Root Mean Square) must be supplied as a character value (with quotes), the other known functions may be supplied with or without quotes. For other functions you could perhaps use a sample of the RasterLayer that can be held in memory (see \code{\link[raster]{sampleRegular}} ) } \seealso{ \code{\link[raster]{freq}}, \code{\link[raster]{quantile}}, \code{\link[raster:extremeValues]{minValue}}, \code{\link[raster:extremeValues]{maxValue}}, \code{\link[raster]{setMinMax}} } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) * 10 # works for large files cellStats(r, 'mean') # same, but does not work for very large files cellStats(r, mean) # multi-layer object cellStats(brick(r,r), mean) } \keyword{spatial} \keyword{univar} raster/man/contour.Rd0000644000176200001440000000132114160021141014270 0ustar liggesusers\name{contour} \docType{methods} \alias{contour} \alias{contour,RasterLayer-method} \title{Contour plot} \description{ Contour plot of a RasterLayer. } \usage{ \S4method{contour}{RasterLayer}(x, maxpixels=100000, ...) } \arguments{ \item{x}{Raster* object} \item{maxpixels}{maximum number of pixels used to create the contours} \item{...}{any argument that can be passed to \code{\link[graphics]{contour}} (graphics package)} } \seealso{ \code{\link{persp}}, \code{\link{filledContour}}, \code{\link{rasterToContour} } } \examples{ r <- raster(system.file("external/test.grd", package="raster")) plot(r) contour(r, add=TRUE) } \keyword{methods} \keyword{spatial} raster/man/projectRaster.Rd0000644000176200001440000001265214160021141015437 0ustar liggesusers\name{projectRaster} \alias{projectRaster} \alias{projectExtent} \title{Project a Raster object} \description{ Project the values of a Raster* object to a new Raster* object with another projection (coordinate reference system, (CRS)). You can do this by providing the new projection as a single argument in which case the function sets the extent and resolution of the new object. To have more control over the transformation, and, for example, to assure that the new object lines up with other datasets, you can provide a Raster* object with the properties that the input data should be projected to. \code{projectExtent} returns a RasterLayer with a projected extent, but without any values. This RasterLayer can then be adjusted (e.g. by setting its resolution) and used as a template \code{'to'} in \code{projectRaster}. } \note{ If the resolution of the output is much larger than that of the input, you should first aggregate the input such that the resolution of the input becomes more similar (perhaps a little smaller) to the output. } \usage{ projectRaster(from, to, res, crs, method="bilinear", alignOnly=FALSE, over=FALSE, filename="", ...) projectExtent(object, crs) } \arguments{ \item{from}{Raster* object} \item{to}{Raster* object with the parameters to which 'from' should be projected} \item{res}{single or (vector of) two numerics. To, optionally, set the output resolution if 'to' is missing} \item{crs}{character or object of class 'CRS'. PROJ.4 description of the coordinate reference system. In projectRaster this is used to set the output CRS if 'to' is missing, or if 'to' has no valid CRS} \item{method}{method used to compute values for the new RasterLayer. Either 'ngb' (nearest neighbor), which is useful for categorical variables, or 'bilinear' (bilinear interpolation; the default value), which is appropriate for continuous variables.} \item{alignOnly}{logical. Use \code{to} or other parameters only to align the output (i.e. same origin and resolution), but use the projected extent from \code{from}} \item{over}{logical. If \code{TRUE} wrapping around the date-line is turned off. This can be desirable for global data (to avoid mapping the same areas twice) but it is not desireable in other cases} \item{filename}{character. Output filename} \item{...}{additional arguments as for \code{\link{writeRaster}}} \item{object}{Raster* object} } \details{ There are two approaches you can follow to project the values of a Raster object. 1) Provide a \code{crs} argument, and, optionally, a \code{res} argument, but do not provide a \code{to} argument. 2) Create a template Raster with the CRS you want to project to. You can use an existing object, or use \code{projectExtent} for this or an existing Raster* object. Also set the number of rows and columns (or the resolution), and perhaps adjust the extent. The resolution of the output raster should normally be similar to that of the input raster. Then use that object as \code{from} argument to project the input Raster to. This is the preferred method because you have most control. For example you can assure that the resulting Raster object lines up with other Raster objects. Projection is performed using the PROJ.4 library accessed through the rgdal package. Also see \code{projInfo('proj')}, \code{projInfo('ellps')}, and \code{projInfo('datum')} for valid PROJ.4 values. } \note{ User beware. Sadly, the PROJ.4 notation has been partly deprecated in the GDAL/PROJ library that is used by this function. You can still use it, but *only* with the the WGS84 datum. Other datums are silently ignored. When printing a Spat* object the PROJ.4 notation is shown because it is the most concise and clear format available. However, internally a WKT representation is used (see \code{\link{crs}}). Vector (points, lines, polygons) can be transformed with \code{\link[sp]{spTransform}}. \code{projectExtent} does not work very well when transforming projected circumpolar data to (e.g.) longitude/latitude. With such data you may need to adjust the returned object. E.g. do \code{ymax(object) <- 90} } \value{ RasterLayer or RasterBrick object. } \author{Robert J. Hijmans and Joe Cheng} \seealso{ \code{\link{resample}}, \code{\link[rgdal]{CRS-class}}, \code{\link[rgdal]{projInfo}}, \code{\link[sp]{spTransform}} } \examples{ # create a new (not projected) RasterLayer with cellnumbers as values r <- raster(xmn=-110, xmx=-90, ymn=40, ymx=60, ncols=40, nrows=40) r <- setValues(r, 1:ncell(r)) crs(r) # wkt(r) # proj.4 projection description newproj <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +datum=WGS84" # we need the rgdal package for this if (require(rgdal)) { #simplest approach pr1 <- projectRaster(r, crs=newproj) # alternatively also set the resolution pr2 <- projectRaster(r, crs=newproj, res=20000) # inverse projection, back to the properties of 'r' inv <- projectRaster(pr2, r) # to have more control, provide an existing Raster object, here we create one # using projectExtent (no values are transferred) pr3 <- projectExtent(r, newproj) # Adjust the cell size res(pr3) <- 200000 # now project pr3 <- projectRaster(r, pr3) \dontrun{ # using a higher resolution res(pr1) <- 10000 pr <- projectRaster(r, pr1, method='bilinear') inv <- projectRaster(pr, r, method='bilinear') dif <- r - inv # small difference plot(dif) } } } \keyword{spatial} raster/man/mosaic.Rd0000644000176200001440000000357414160021141014066 0ustar liggesusers\name{mosaic} \docType{methods} \alias{mosaic} \alias{mosaic,Raster,Raster-method} \title{ Merge Raster* objects using a function for overlapping areas } \description{ Mosaic Raster* objects to form a new object with a larger spatial extent. A function is used to compute cell values in areas where layers overlap (in contrast to the \code{\link[raster]{merge}} function which uses the values of the 'upper' layer). All objects must have the same origin, resolution, and coordinate reference system. } \usage{ \S4method{mosaic}{Raster,Raster}(x, y, ..., fun, tolerance=0.05, filename="") } \arguments{ \item{x}{Raster* object} \item{y}{Raster* object} \item{...}{Additional Raster or Extent objects (and/or arguments for writing files as in \code{\link{writeRaster})}} \item{fun}{Function. E.g. mean, min, or max. Must be a function that accepts a 'na.rm' argument} \item{tolerance}{Numeric. permissible difference in origin (relative to the cell resolution). See \code{\link[base]{all.equal}}} \item{filename}{Character. Output filename (optional)} } \details{ The Raster objects must have the same origin and resolution. } \value{ RasterLayer or RasterBrick object. } \seealso{ \code{\link[raster]{merge}}, \code{\link[raster]{extend}}} \examples{ r <- raster(ncol=100, nrow=100) r1 <- crop(r, extent(-10, 11, -10, 11)) r2 <- crop(r, extent(0, 20, 0, 20)) r3 <- crop(r, extent(9, 30, 9, 30)) values(r1) <- 1:ncell(r1) values(r2) <- 1:ncell(r2) values(r3) <- 1:ncell(r3) m1 <- mosaic(r1, r2, r3, fun=mean) s1 <- stack(r1, r1*2) s2 <- stack(r2, r2/2) s3 <- stack(r3, r3*4) m2 <- mosaic(s1, s2, s3, fun=min) # if you have a list of Raster objects, you can use do.call x <- list(r1, r2, r3) names(x)[1:2] <- c('x', 'y') x$fun <- mean x$na.rm <- TRUE y <- do.call(mosaic, x) } \keyword{methods} \keyword{spatial} raster/man/writeValues.Rd0000644000176200001440000000656214160021141015125 0ustar liggesusers\name{writeValues} \alias{writeStart} \alias{writeStart,RasterLayer,character-method} \alias{writeStart,RasterBrick,character-method} \alias{writeStop} \alias{writeStop,RasterLayer-method} \alias{writeStop,RasterBrick-method} \alias{writeValues} \alias{writeValues,RasterLayer,vector-method} \alias{writeValues,RasterBrick,matrix-method} \title{Write values to a file} \description{ Functions for writing blocks (>= 1 row(s)) of values to files. Writing has to start at the first cell of a row (identified with argument \code{start}) and the values written must represent 1 or more entire rows. Begin by opening a file with \code{writeStart}, then write values to it in chunks. When writing is done close the file with \code{writeStop}. If you want to write all values of a Raster* object at once, you can also use \code{\link{writeRaster}} which is easier to use but more limited. The functions described here allow writing values to file using chunks of different sizes (e.g. 1 or 10 rows). Function \code{\link{blockSize}} can be used to suggest a chunk size to use. } \usage{ \S4method{writeStart}{RasterLayer,character}(x, filename, options=NULL, format, prj=FALSE, ...) \S4method{writeStart}{RasterBrick,character}(x, filename, options=NULL, format, prj=FALSE, ...) \S4method{writeValues}{RasterLayer,vector}(x, v, start, ...) \S4method{writeValues}{RasterBrick,matrix}(x, v, start, ...) \S4method{writeStop}{RasterLayer}(x) \S4method{writeStop}{RasterBrick}(x) } \arguments{ \item{x}{Raster* object} \item{filename}{character. Output file name} \item{options}{character, see \code{\link{writeRaster}}} \item{format}{character, see \code{\link{writeRaster}}} \item{prj}{logical. If \code{TRUE}, a "prj" file is written} \item{...}{additional arguments as for \code{\link{writeRaster}}} \item{v}{vector (RasterLayer) or matrix (RasterBrick) of values} \item{start}{Integer. Row number (counting starts at 1) from where to start writing \code{v}} } \value{ RasterLayer or RasterBrick } \seealso{ \code{\link{writeRaster}, \link{blockSize}, \link{update}} } \examples{ \dontrun{ r <- raster(system.file("external/test.grd", package="raster")) # write to a new binary file in chunks s <- raster(r) # tr <- blockSize(r) tr s <- writeStart(s, filename='test.grd', overwrite=TRUE) for (i in 1:tr$n) { v <- getValuesBlock(r, row=tr$row[i], nrows=tr$nrows[i]) s <- writeValues(s, v, tr$row[i]) } s <- writeStop(s) if(require(rgdal)){ s2 <- writeStart(s, filename='test2.tif', format='GTiff', overwrite=TRUE) # writing last row first for (i in tr$n:1) { v <- getValuesBlock(r, row=tr$row[i], nrows=tr$nrows[i]) s2 <- writeValues(s2, v, tr$row[i]) } # row number 5 once more v <- getValuesBlock(r, row=5, nrows=1) writeValues(s2, v, 5) s2 <- writeStop(s2) } ## write values of a RasterStack to a RasterBrick s <- stack(system.file("external/rlogo.grd", package="raster")) # create empty brick b <- brick(s, values=FALSE) b <- writeStart(b, filename="test.grd", format="raster",overwrite=TRUE) tr <- blockSize(b) for (i in 1:tr$n) { v <- getValuesBlock(s, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, v, tr$row[i]) } b <- writeStop(b) # note that the above is equivalent to # b <- writeRaster(s, filename="test.grd", format="raster",overwrite=TRUE) } } \keyword{ spatial } \keyword{ methods } raster/man/cover.Rd0000644000176200001440000000364114160021141013724 0ustar liggesusers\name{cover} \docType{methods} \alias{cover} \alias{cover,RasterLayer,RasterLayer-method} \alias{cover,RasterStackBrick,Raster-method} \alias{cover,SpatialPolygons,SpatialPolygons-method} \title{ Replace NA values with values of other layers } \description{ For Raster* objects: Replace \code{NA} values in the first Raster object (\code{x}) with the values of the second (\code{y}), and so forth for additional Rasters. If \code{x} has multiple layers, the subsequent Raster objects should have the same number of layers, or have a single layer only (which will be recycled). For SpatialPolygons* objects: Areas of \code{x} that overlap with \code{y} are replaced by (or intersected with) \code{y}. } \usage{ \S4method{cover}{RasterLayer,RasterLayer}(x, y, ..., filename='') \S4method{cover}{RasterStackBrick,Raster}(x, y, ..., filename='') \S4method{cover}{SpatialPolygons,SpatialPolygons}(x, y, ..., identity=FALSE) } \arguments{ \item{x}{Raster* or SpatialPolygons* object} \item{y}{Same as \code{x}} \item{filename}{character. Output filename (optional)} \item{...}{Same as \code{x}. If \code{x} is a Raster* object, also additional arguments as for \code{\link{writeRaster}}} \item{identity}{logical. If \code{TRUE} overlapping areas are intersected rather than replaced} } \value{ RasterLayer or RasterBrick object, or SpatialPolygons object } \examples{ # raster objects r1 <- raster(ncols=36, nrows=18) values(r1) <- 1:ncell(r1) r2 <- setValues(r1, runif(ncell(r1))) r2[r2 < 0.5] <- NA r3 <- cover(r2, r1) #SpatialPolygons if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) b <- SpatialPolygonsDataFrame(b, data.frame(ID_1=9)) cv1 <- cover(p, b) cv2 <- cover(p, b, identity=TRUE) } } \keyword{methods} \keyword{spatial} raster/man/quantile.Rd0000644000176200001440000000173414160021141014431 0ustar liggesusers\name{quantile} \docType{methods} \alias{quantile} \alias{quantile,Raster-method} \title{Raster quantiles} \description{ Compute quantiles for the cell values of a RasterLayer. If you want to compute quantiles for each cell across a number of layers, you can use \code{\link{calc}(x, fun=quantile)}. } \usage{ quantile(x, ...) } \arguments{ \item{x}{Raster object} \item{...}{Additional arguments: \code{na.rm=TRUE}, \code{ncells=NULL}, and additional arguments to the stats::quantile function, see \code{\link[stats]{quantile}}} ncells can be used to set the number of cells to be sampled, for very large raster datasets. } \value{ A vector of quantiles } \seealso{ \code{\link[raster]{density}}, \code{\link[raster]{cellStats}} } \examples{ r <- raster(ncol=100, nrow=100) values(r) <- rnorm(ncell(r), 0, 50) quantile(r) quantile(r, probs = c(0.25, 0.75), type=7,names = FALSE) } \keyword{methods} \keyword{spatial} raster/man/plotRGB.Rd0000644000176200001440000000645414160021141014124 0ustar liggesusers\name{plotRGB} \docType{methods} \alias{plotRGB} \alias{plotRGB,RasterStackBrick-method} \title{Red-Green-Blue plot of a multi-layered Raster object} \description{ Make a Red-Green-Blue plot based on three layers (in a RasterBrick or RasterStack). Three layers (sometimes referred to as "bands" because they may represent different bandwidths in the electromagnetic spectrum) are combined such that they represent the red, green and blue channel. This function can be used to make 'true (or false) color images' from Landsat and other multi-band satellite images. } \usage{ \S4method{plotRGB}{RasterStackBrick}(x, r=1, g=2, b=3, scale, maxpixels=500000, stretch=NULL, ext=NULL, interpolate=FALSE, colNA='white', alpha, bgalpha, addfun=NULL, zlim=NULL, zlimcol=NULL, axes=FALSE, xlab='', ylab='', asp=NULL, add=FALSE, margins=FALSE, ...) } \arguments{ \item{x}{RasterBrick or RasterStack} \item{r}{integer. Index of the Red channel, between 1 and nlayers(x)} \item{g}{integer. Index of the Green channel, between 1 and nlayers(x)} \item{b}{integer. Index of the Blue channel, between 1 and nlayers(x)} \item{scale}{integer. Maximum (possible) value in the three channels. Defaults to 255 or to the maximum value of \code{x} if that is known and larger than 255} \item{maxpixels}{integer > 0. Maximum number of pixels to use} \item{stretch}{character. Option to stretch the values to increase the contrast of the image: "lin" or "hist"} \item{ext}{An \code{\link{Extent}} object to zoom in to a region of interest (see \code{\link{drawExtent}})} \item{interpolate}{logical. If \code{TRUE}, interpolate the image when drawing} \item{colNA}{color for the background (\code{NA} values)} \item{alpha}{transparency. Integer between 0 (transparent) and 255 (opaque)} \item{bgalpha}{Background transparency. Integer between 0 (transparent) and 255 (opaque)} \item{addfun}{Function to add additional items such as points or polygons to the plot (map). See \code{\link[raster]{plot}}} \item{zlim}{numeric vector of length 2. Range of values to plot (optional)} \item{zlimcol}{If \code{NULL} the values outside the range of zlim get the color of the extremes of the range. If zlimcol has any other value, the values outside the zlim range get the color of \code{NA} values (see colNA)} \item{axes}{logical. If \code{TRUE} axes are drawn (and arguments such as \code{main="title"} will be honored)} \item{xlab}{character. Label of x-axis} \item{ylab}{character. Label of y-axis} \item{asp}{numeric. Aspect (ratio of x and y. If NULL, and appropriate value is computed to match data for the longitude/latitude coordinate reference system, and 1 for planar coordinate reference systems} \item{add}{logical. If \code{TRUE} add values to current plot} \item{margins}{logical. If \code{TRUE} standard whitespace margins are used. If \code{FALSE}, graphics::par(plt=c(0,1,0,1)) is used} \item{...}{graphical parameters as in \code{\link{plot}} or \code{\link{rasterImage}}} } \author{Robert J. Hijmans; stretch option based on functions by Josh Gray } \seealso{ \code{\link[raster]{plot}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) plotRGB(b) plotRGB(b, 3, 2, 1) plotRGB(b, 3, 2, 1, stretch='hist') } \keyword{methods} \keyword{spatial} raster/man/shift.Rd0000644000176200001440000000214014160021141013714 0ustar liggesusers\name{shift} \docType{methods} \alias{shift} \alias{shift,Raster-method} \alias{shift,SpatialPolygons-method} \alias{shift,SpatialLines-method} \alias{shift,SpatialPoints-method} \title{Shift} \description{ Shift the location of a Raster* of vector type Spatial* object in the x and/or y direction } \usage{ \S4method{shift}{Raster}(x, dx=0, dy=0, filename='', ...) \S4method{shift}{SpatialPolygons}(x, dx=0, dy=0, ...) \S4method{shift}{SpatialLines}(x, dx=0, dy=0, ...) \S4method{shift}{SpatialPoints}(x, dx=0, dy=0, ...) } \arguments{ \item{x}{Raster* or Spatial* object} \item{dx}{numeric. The shift in horizontal direction} \item{dy}{numeric. The shift in vertical direction} \item{filename}{character file name (optional)} \item{...}{if \code{x} is a Raster* object: additional arguments as for \code{\link{writeRaster}} } } \value{ Same object type as \code{x} } \seealso{ \code{\link{flip}}, \code{\link{rotate}}, and the elide function in the maptools package } \examples{ r <- raster() r <- shift(r, dx=1, dy=-1) } \keyword{spatial} raster/man/cellsFromExtent.Rd0000644000176200001440000000254514160021141015726 0ustar liggesusers\name{cellsFromExtent} \alias{cellsFromExtent} \alias{extentFromCells} \title{Cells from extent, and vice versa} \description{ cellsFromExtent returns the cell numbers for a Raster* object that are within a specfied extent (rectangular area), supply an object of class Extent, or another Raster* object. extentFromCells returns an Extent object from a Raster* object and cell numbers. All cells are within the returned Extent. } \usage{ cellsFromExtent(object, extent, expand=FALSE) extentFromCells(object, cells) } \arguments{ \item{object}{A Raster* object} \item{extent}{An object of class Extent (which you can create with newExtent(), or another Raster* object )} \item{expand}{Logical. If \code{TRUE}, \code{NA} is returned for (virtual) cells implied by \code{bndbox}, that are outside the RasterLayer (\code{object}). If \code{FALSE}, only cell numbers for the area where \code{object} and \code{bndbox} overlap are returned (see \link[raster]{intersect}) } \item{cells}{numeric. A vector of cell numbers} } \value{ a vector of cell numbers } \seealso{ \code{\link[raster]{extent}}, \code{\link{cellFromXY}} } \examples{ r <- raster() bb <- extent(-5, 5, -5, 5) cells <- cellsFromExtent(r, bb) r <- crop(r, bb) values(r) <- cells e <- extentFromCells(r, 50:55) } \keyword{spatial} raster/man/adjacent.Rd0000644000176200001440000000514214160021141014355 0ustar liggesusers\name{adjacent} \alias{adjacent} \alias{adjacent,BasicRaster-method} \title{Adjacent cells} \description{ Identify cells that are adjacent to a set of cells on a raster. } \usage{ \S4method{adjacent}{BasicRaster}(x, cells, directions=4, pairs=TRUE, target=NULL, sorted=FALSE, include=FALSE, id=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{cells}{vector of cell numbers for which adjacent cells should be found. Cell numbers start with 1 in the upper-left corner and increase from left to right and from top to bottom} \item{directions}{the number of directions in which cells should be connected: 4 (rook's case), 8 (queen's case), 16 (knight and one-cell queen moves), or 'bishop' to connect cells with one-cell diagonal moves. Or a neighborhood matrix (see Details)} \item{pairs}{logical. If \code{TRUE}, a matrix of pairs of adjacent cells is returned. If \code{FALSE}, a vector of cells adjacent to \code{cells} is returned} \item{target}{optional vector of target cell numbers that should be considered. All other adjacent cells are ignored} \item{sorted}{logical. Should the results be sorted? } \item{include}{logical. Should the focal cells be included in the result? } \item{id}{logical. Should the id of the cells be included in the result? (numbered from 1 to length(cells) } \item{...}{additional arguments. None implemented } } \details{ A neighborhood matrix identifies the cells around each cell that are considered adjacent. The matrix should have one, and only one, cell with value 0 (the focal cell); at least one cell with value 1 (the adjacent cell(s)); All other cells are not considered adjacent and ignored. } \value{ matrix or vector with adjacent cells. } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster(nrows=10, ncols=10) adjacent(r, cells=c(1, 55), directions=8, pairs=TRUE) a <- adjacent(r, cell = c(1,55,90), directions=4, sorted=TRUE) a r[c(1,55,90)] <- 1 r[a] <- 2 plot(r) # same result as above rook <- matrix(c(NA, 1, NA, 1, 0, 1, NA, 1, NA), ncol=3, byrow=TRUE) adjacent(r, cells = c(1,55,90), directions=rook, sorted=TRUE) # Count the number of times that a cell with a certain value # occurs next to a cell with a certain value set.seed(0) r <- raster(ncol=10, nrow=10) values(r) <- round(runif(ncell(r)) * 5) a <- adjacent(r, 1:ncell(r), 4, pairs=TRUE) tb <- table(r[a[,1]], r[a[,2]]) tb # make a matrix out of the 'table' object tb <- unclass(tb) plot(raster(tb, xmn=-0.5, xmx=5.5, ymn=-0.5, ymx=5.5)) } \keyword{spatial} raster/man/filename.Rd0000644000176200001440000000103314160021141014357 0ustar liggesusers\name{filename} \alias{filename} \title{Filename} \description{ Get the filename of a Raster* object. You cannot set the filename of an object (except for RasterStack objects); but you can provide a 'filename= ' argument to a function that creates a new RasterLayer or RasterBrick* object. } \usage{ filename(x) } \arguments{ \item{x}{A Raster* object } } \value{ a Raster* object } \examples{ r <- raster( system.file("external/test.grd", package="raster") ) filename(r) } \keyword{ spatial } raster/man/Extent-class.Rd0000644000176200001440000000165414160021141015162 0ustar liggesusers\name{Extent-class} \docType{class} \alias{Extent} \alias{Extent-class} \alias{show,Extent-method} \title{Class "Extent" } \description{ Objects of class Extent are used to define the spatial extent (extremes) of objects of the BasicRaster and Raster* classes. } \section{Objects from the Class}{ You can use the \code{\link{extent}} function to create Extent objects, or to extract them from Raster* and Spatial* objects. } \section{Slots}{ \describe{ \item{\code{xmin}:}{minimum x coordinate} \item{\code{xmax}:}{maximum x coordinate} \item{\code{ymin}:}{minumum y coordinate} \item{\code{ymax}:}{maximum y coordinate} } } \section{Methods}{ \describe{ \item{show}{display values of a Extent object } } } \seealso{ \code{\link{extent}}, \code{\link[raster]{setExtent}} } \examples{ ext <- extent(-180,180,-90,90) ext } \keyword{classes} \keyword{spatial} raster/man/geom.Rd0000644000176200001440000000336514160021141013540 0ustar liggesusers\name{geom} \docType{methods} \alias{geom} \alias{geom,SpatialPolygons-method} \alias{geom,SpatialLines-method} \alias{geom,SpatialPoints-method} \alias{geom,data.frame-method} \title{Get the coordinates of a vector type Spatial* object} \description{ Extract the coordinates of a Spatial object } \usage{ \S4method{geom}{SpatialPolygons}(x, sepNA=FALSE, ...) \S4method{geom}{SpatialLines}(x, sepNA=FALSE, ...) \S4method{geom}{SpatialPoints}(x, ...) \S4method{geom}{data.frame}(x, d, gt, crs, ...) } \arguments{ \item{x}{SpatialPolygons*, SpatialLines*, or SpatialPoints* object; or a data.frame} \item{sepNA}{logical. If \code{TRUE}, geometries are separated by a row with \code{NA} values} \item{...}{additional arguments, none implemented} \item{d}{data.frame that matches the number of objects in data.frame \code{x}} \item{gt}{character. geometry type. Must be one of "polygons", "lines", "points"} \item{crs}{character. PROJ.4 crs string} } \value{ Matrix with 6, (5 SpatialLines), or 3 (SpatialPoints) columns. object (sequential object number) part (sequential part number within the object; not for SpatialPoints), cump (cumulative part number; not for SpatialPoints), hole (is this a hole or not; only for SpatialPolygons), x (x coordinate or longitude), y (y coordinate or latitude) } \seealso{ \code{\link[sp]{coordinates}}, \code{\link[sp:geometry-methods]{geometry}} } \examples{ p <- readRDS(system.file("external/lux.rds", package="raster")) x <- geom(p) head(x) # and back to a SpatialPolygonsDataFrame x <- data.frame(x) sp <- as(x, "SpatialPolygons") crs(sp) <- crs(p) spdf <- SpatialPolygonsDataFrame(sp, data.frame(p), match.ID=FALSE) } \keyword{methods} \keyword{spatial} raster/man/focal.Rd0000644000176200001440000001213114160021141013664 0ustar liggesusers\name{focal} \alias{focal} \alias{focal,RasterLayer-method} \title{Focal values} \description{ Calculate focal ("moving window") values for the neighborhood of focal cells using a matrix of weights, perhaps in combination with a function. } \usage{ \S4method{focal}{RasterLayer}(x, w, fun, filename='', na.rm=FALSE, pad=FALSE, padValue=NA, NAonly=FALSE, ...) } \arguments{ \item{x}{RasterLayer} \item{w}{matrix of weights (the moving window), e.g. a 3 by 3 matrix with values 1; see Details. The matrix does not need to be square, but the sides must be odd numbers. If you need even sides, you can add a column or row with weights of zero or \code{NA}} \item{fun}{function (optional). The function fun should take multiple numbers, and return a single number. For example mean, modal, min or max. It should also accept a \code{na.rm} argument (or ignore it, e.g. as one of the 'dots' arguments. For example, \code{length} will fail, but \code{function(x, ...){na.omit(length(x))}} works. } \item{filename}{character. Filename for a new raster (optional)} \item{na.rm}{logical. If \code{TRUE}, \code{NA} will be removed from focal computations. The result will only be \code{NA} if all focal cells are \code{NA}. Except for some special cases (weights of 1, functions like min, max, mean), using \code{na.rm=TRUE} may not be a good idea in this function because it can unbalance the effect of the weights} \item{pad}{logical. If \code{TRUE}, additional 'virtual' rows and columns are padded to \code{x} such that there are no edge effects. This can be useful when a function needs to have access to the central cell of the filter} \item{padValue}{numeric. The value of the cells of the padded rows and columns} \item{NAonly}{logical. If \code{TRUE}, only cell values that are \code{NA} are replaced with the computed focal values} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \details{ \code{focal} uses a matrix of weights for the neighborhood of the focal cells. The default function is \code{sum}. It is computationally much more efficient to adjust the weights-matrix than to use another function through the \code{fun} argument. Thus while the following two statements are equivalent (if there are no \code{NA} values), the first one is faster than the second one: \code{a <- focal(x, w=matrix(1/9, nc=3, nr=3))} \code{b <- focal(x, w=matrix(1,3,3), fun=mean)} There is, however, a difference if \code{NA} values are considered. One can use the \code{na.rm=TRUE} option which may make sense when using a function like \code{mean}. However, the results would be wrong when using a weights matrix. Laplacian filter: \code{filter=matrix(c(0,1,0,1,-4,1,0,1,0), nrow=3)} Sobel filters: \code{fx=matrix(c(-1,-2,-1,0,0,0,1,2,1) / 4, nrow=3)} and \code{fy=matrix(c(1,0,-1,2,0,-2,1,0,-1)/4, nrow=3)} see the \code{\link{focalWeight}} function to create distance based circular, rectangular, or Gaussian filters. Note that there is a difference between 0 and NA in the weights matrix. A zero weight cell is included in the computation, whereas a NA weight cell is excluded. This does not matter for "sum", nor for "mean" (zeros are removed), but it affects many other functions such as "var" as you could be adding a lot of zeros that should not be there. } \value{ RasterLayer } \seealso{ \code{\link{focalWeight}} } \examples{ r <- raster(ncols=36, nrows=18, xmn=0) values(r) <- runif(ncell(r)) # 3x3 mean filter r3 <- focal(r, w=matrix(1/9,nrow=3,ncol=3)) # 5x5 mean filter r5 <- focal(r, w=matrix(1/25,nrow=5,ncol=5)) # Gaussian filter gf <- focalWeight(r, 2, "Gauss") rg <- focal(r, w=gf) # The max value for the lower-rigth corner of a 3x3 matrix around a focal cell f = matrix(c(0,0,0,0,1,1,0,1,1), nrow=3) f rm <- focal(r, w=f, fun=max) # global lon/lat data: no 'edge effect' for the columns xmin(r) <- -180 r3g <- focal(r, w=matrix(1/9,nrow=3,ncol=3)) \dontrun{ ## focal can be used to create a cellular automaton # Conway's Game of Life w <- matrix(c(1,1,1,1,0,1,1,1,1), nr=3,nc=3) gameOfLife <- function(x) { f <- focal(x, w=w, pad=TRUE, padValue=0) # cells with less than two or more than three live neighbours die x[f<2 | f>3] <- 0 # cells with three live neighbours become alive x[f==3] <- 1 x } # simulation function sim <- function(x, fun, n=100, pause=0.25) { for (i in 1:n) { x <- fun(x) plot(x, legend=FALSE, asp=NA, main=i) dev.flush() Sys.sleep(pause) } invisible(x) } # Gosper glider gun m <- matrix(0, nc=48, nr=34) m[c(40, 41, 74, 75, 380, 381, 382, 413, 417, 446, 452, 480, 486, 517, 549, 553, 584, 585, 586, 619, 718, 719, 720, 752, 753, 754, 785, 789, 852, 853, 857, 858, 1194, 1195, 1228, 1229)] <- 1 init <- raster(m) # run the model sim(init, gameOfLife, n=150, pause=0.05) ## Implementation of Sobel edge-detection filter ## for RasterLayer r sobel <- function(r) { fy <- matrix(c(1,0,-1,2,0,-2,1,0,-1), nrow=3) fx <- matrix(c(-1,-2,-1,0,0,0,1,2,1) , nrow=3) rx <- focal(r, fx) ry <- focal(r, fy) sqrt(rx^2 + ry^2) } } } \keyword{spatial} raster/man/clump.Rd0000644000176200001440000000270314160021141013724 0ustar liggesusers\name{clump} \alias{clump} \alias{clump,RasterLayer-method} \title{Detect clumps} \description{ Detect clumps (patches) of connected cells. Each clump gets a unique ID. NA and zero are used as background values (i.e. these values are used to separate clumps). You can use queen's or rook's case, using the \code{directions} argument. For larger files that are processed in chunks, the highest clump number is not necessarily equal to the number of clumps (unless you use argument \code{gaps=FALSE}). } \usage{ \S4method{clump}{RasterLayer}(x, filename="", directions=8, gaps=TRUE, ...) } \arguments{ \item{x}{RasterLayer} \item{filename}{Character. Filename for the output RasterLayer (optional)} \item{directions}{Integer. Which cells are considered adjacent? Should be 8 (Queen's case) or 4 (Rook's case) } \item{gaps}{Logical. If \code{TRUE} (the default), there may be 'gaps' in the chunk numbers (e.g. you may have clumps with IDs 1, 2, 3 and 5, but not 4). If it is \code{FALSE}, these numbers will be recoded from 1 to n (4 in this example)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \note{ This function requires that the igraph package is available. } \value{ RasterLayer } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster(ncols=12, nrows=12) set.seed(0) values(r) <- round(runif(ncell(r))*0.7 ) rc <- clump(r) freq(rc) plot(rc) } \keyword{spatial} raster/man/NAvalue.Rd0000644000176200001440000000204414160021141014135 0ustar liggesusers\name{NAvalue} \alias{NAvalue<-} \alias{NAvalue} \title{Set the NA value of a RasterLayer } \description{ NAvalue returns the value that is used to write NA values to disk (in 'raster' type files). If you set the NA value of a Raster* object, this value will be interpreted as NA when reading the values from a file. Values already in memory will not be affected. If the NA value is smaller than zero, all values smaller or equal to that number will be set to NA. } \usage{ NAvalue(x) <- value NAvalue(x) } \arguments{ \item{x}{A \code{Raster} object} \item{value}{the value to be interpreted as NA; set this before reading the values from the file. Integer values are matched exactly; for decimal values files any value <= the value will be interpreted as NA} } \value{ Returns or set the NA value used for storage on disk. } \examples{ r1 <- raster(system.file("external/rlogo.grd", package="raster")) r2 <- r1 NAvalue(r2) NAvalue(r2) <- 255 #plot(r1) #x11() #plot(r2) } \keyword{ spatial } raster/man/rasterFromCells.Rd0000644000176200001440000000213014160021141015705 0ustar liggesusers\name{rasterFromCells} \alias{rasterFromCells} \title{Subset a raster by cell numbers} \description{ This function returns a new raster based on an existing raster and cell numbers for that raster. The new raster is cropped to the cell numbers provided, and, if \code{values=TRUE} has values that are the cell numbers of the original raster. } \usage{ rasterFromCells(x, cells, values=TRUE) } \arguments{ \item{x}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{cells}{vector of cell numbers} \item{values}{Logical. If \code{TRUE}, the new RasterLayer has cell values that correspond to the cell numbers of \code{x}} } \details{ Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \value{ RasterLayer } \seealso{ \code{\link[raster]{rowFromCell}} } \examples{ r <- raster(ncols=100, nrows=100) cells <- c(3:5, 210) r <- rasterFromCells(r, cells) cbind(1:ncell(r), getValues(r)) } \keyword{spatial} raster/man/extend.Rd0000644000176200001440000000431214160021141014071 0ustar liggesusers\name{extend} \alias{extend} \alias{extend,Raster-method} \alias{extend,Extent-method} \title{Extend} \description{ Extend returns an Raster* object with a larger spatial extent. The output Raster object has the outer minimum and maximum coordinates of the input Raster and Extent arguments. Thus, all of the cells of the original raster are included. See \code{\link[raster]{crop}} if you (also) want to remove rows or columns. There is also an extend method for Extent objects to enlarge (or reduce) an Extent. You can also use algebraic notation to do that (see examples). This function has replaced function "expand" (to avoid a name conflict with the Matrix package). } \usage{ \S4method{extend}{Raster}(x, y, value=NA, snap="near", filename='', ...) \S4method{extend}{Extent}(x, y, ...) } \arguments{ \item{x}{Raster or Extent object} \item{y}{If \code{x} is a Raster object, \code{y} should be an Extent object, or any object that is or has an Extent object, or an object from which it can be extracted (such as sp objects). Alternatively, you can provide a numeric vector of length 2 indicating the number of rows and columns that need to be added (or a single number when the number of rows and columns is equal) If \code{x} is an Extent object, \code{y} should be a numeric vector of 1, 2, or 4 elements} \item{value}{value to assign to new cells} \item{snap}{Character. One of "near", "in", or "out", to determine in which direction the extent should be aligned. To the nearest border, inwards or outwards} \item{filename}{Character (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick, or Extent } \author{Robert J. Hijmans and Etienne B. Racine (Extent method)} \seealso{\code{\link[raster]{crop}}, \code{\link[raster]{merge}}} \examples{ r <- raster(xmn=-150, xmx=-120, ymx=60, ymn=30, ncol=36, nrow=18) values(r) <- 1:ncell(r) e <- extent(-180, 0, 0, 90) re <- extend(r, e) # extend with a number of rows and columns (at each side) re2 <- extend(r, c(2,10)) # Extent object e <- extent(r) e extend(e, 10) extend(e, 10, -10, 0, 20) e + 10 e * 2 } \keyword{spatial} raster/man/freq.Rd0000644000176200001440000000300514160021141013535 0ustar liggesusers\name{freq} \docType{methods} \alias{freq} \alias{freq,RasterLayer-method} \alias{freq,RasterStackBrick-method} \title{Frequency table} \description{ Frequency table of the values of a RasterLayer. } \usage{ \S4method{freq}{RasterLayer}(x, digits=0, value=NULL, useNA='ifany', progress='', ...) \S4method{freq}{RasterStackBrick}(x, digits=0, value=NULL, useNA='ifany', merge=FALSE, progress='', ...) } \arguments{ \item{x}{RasterLayer} \item{digits}{non-negative integer for rounding the cell values. Argument is passed to \code{round} } \item{value}{numeric, logical or NA. An optional single value to only count the number of cells with that value} \item{useNA}{character. What to do with NA values? Options are "no", "ifany", "always". See to \code{\link[base]{table}} } \item{progress}{character to specify a progress bar. Choose from 'text', 'window', or '' (the default, no progress bar)} \item{merge}{logical. If \code{TRUE} the list will be merged into a single data.frame} \item{...}{additional arguments (none implemented)} } \value{ matrix (RasterLayer). List of matrices (one for each layer) or data.frame (if \code{merge=TRUE}) (RasterStack or RasterBrick) } \seealso{ \code{\link[raster]{crosstab} } and \code{\link[raster]{zonal} } } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) r[1:5] <- NA r <- r * r * r * 5 freq(r) freq(r, value=2) s <- stack(r, r*2, r*3) freq(s, merge=TRUE) } \keyword{spatial} \keyword{univar} raster/man/validNames.Rd0000644000176200001440000000071114160021141014664 0ustar liggesusers\name{validNames} \alias{validNames} \title{Create valid names} \description{ Create a set of valid names (trimmed, no duplicates, not starting with a number). } \usage{ validNames(x, prefix='layer') } \arguments{ \item{x}{character} \item{prefix}{character string used if x is empty} } \value{ character } \seealso{ \code{\link{make.names} } } \examples{ validNames(c('a', 'a', '', '1', NA, 'b', 'a')) } raster/man/rasterToPolygons.Rd0000644000176200001440000000247214160021141016145 0ustar liggesusers\name{rasterToPolygons} \alias{rasterToPolygons} \title{ Raster to polygons conversion} \description{ Raster to polygons conversion. Cells with NA are not converted. A function can be used to select a subset of the raster cells (by their values). } \usage{ rasterToPolygons(x, fun=NULL, n=4, na.rm=TRUE, digits=12, dissolve=FALSE) } \arguments{ \item{x}{ Raster* object } \item{fun}{ function to select a subset of raster values (only allowed if \code{x} has a single layer)} \item{n}{ integer. The number of nodes for each polygon. Only 4, 8, and 16 are allowed } \item{na.rm}{ If \code{TRUE}, cells with \code{NA} values in all layers are ignored } \item{digits}{ number of digits to round the coordinates to } \item{dissolve}{logical. If \code{TRUE}, polygons with the same attribute value will be dissolved into multi-polygon regions. This option requires the rgeos package} } \details{ \code{fun} should be a simple function returning a logical value. E.g.: \code{fun=function(x){x==1}} or \code{fun=function(x){x>3 & x<6}} } \value{ SpatialPolygonsDataFrame } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) * 10 r[r>8] <- NA pol <- rasterToPolygons(r, fun=function(x){x>6}) #plot(r > 6) #plot(pol, add=TRUE, col='red') } \keyword{ spatial } raster/man/getValues.Rd0000644000176200001440000000365314160021141014550 0ustar liggesusers\name{getValues} \alias{values} \alias{values,Raster-method} \alias{getValues} \alias{getValues,RasterLayer,missing,missing-method} \alias{getValues,RasterLayerSparse,missing,missing-method} \alias{getValues,RasterStack,missing,missing-method} \alias{getValues,RasterBrick,missing,missing-method} \alias{getValues,RasterLayer,numeric,missing-method} \alias{getValues,RasterLayerSparse,numeric,missing-method} \alias{getValues,RasterStack,numeric,missing-method} \alias{getValues,RasterBrick,numeric,missing-method} \alias{getValues,RasterLayer,numeric,numeric-method} \alias{getValues,RasterLayerSparse,numeric,numeric-method} \alias{getValues,RasterStack,numeric,numeric-method} \alias{getValues,RasterBrick,numeric,numeric-method} \title{Get raster cell values} \description{ getValues returns all values or the values for a number of rows of a Raster* object. Values returned for a RasterLayer are a vector. The values returned for a RasterStack or RasterBrick are always a matrix, with the rows representing cells, and the columns representing layers \code{values} is a shorthand version of getValues (for all rows). } \usage{ getValues(x, row, nrows, ...) values(x, ...) } \arguments{ \item{x}{Raster* object} \item{row}{Numeric. Row number, should be between 1 and nrow(x), or missing in which case all values are returned} \item{nrows}{Numeric. Number of rows. Should be an integer > 0, or missing} \item{...}{Additional arguments. When x is a \code{RasterLayer}: \code{format} to specify the output format. Either "matrix" or, the default "", in which case a vector is returned} } \value{ vector or matrix of raster values } \seealso{\code{\link{getValuesBlock}, \link{getValuesFocal}, \link{setValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) r v <- getValues(r) length(v) head(v) getValues(r, row=10) } \keyword{spatial} \keyword{methods} raster/man/extension.Rd0000644000176200001440000000170714160021141014623 0ustar liggesusers\name{extension} \alias{extension} \alias{extension<-} \title{Filename extensions} \description{ Get or change a filename extension } \usage{ extension(filename, value=NULL, maxchar=10) extension(filename) <- value } \arguments{ \item{filename}{A filename, with or without the path} \item{value}{A file extension with or without a dot, e.g., ".txt" or "txt"} \item{maxchar}{Maximum number of characters after the last dot in the filename, for that string to be considered a filename extension } } \value{ A file extension, filename or path. If \code{ext(filename)} is used without a \code{value} argument, it returns the file extension; otherwise it returns the filename (with new extensions set to \code{value} } \examples{ fn <- "c:/temp folder/filename.exten sion" extension(fn) extension(fn) <- ".txt" extension(fn) fn <- extension(fn, '.document') extension(fn) extension(fn, maxchar=4) } \keyword{file} raster/man/unstack.Rd0000644000176200001440000000125314160021141014253 0ustar liggesusers\name{unstack} \alias{unstack} \alias{unstack,RasterStack-method} \alias{unstack,RasterBrick-method} \title{ Unstack } \description{ Create a list of RasterLayer objects from a RasterStack or RasterBrick } \usage{ unstack(x, ...) } \arguments{ \item{x}{ a RasterStack object } \item{...}{not used. further arguments passed to or from other methods} } \value{ A list of RasterLayer objects } \seealso{ \code{\link[raster]{stack}}} \examples{ file <- system.file("external/test.grd", package="raster") s <- stack(file, file) list1 <- unstack(s) b <- brick(s) list2 <- unstack(b) } \keyword{ spatial } \keyword{ methods } raster/man/rotate.Rd0000644000176200001440000000151614160021141014103 0ustar liggesusers\name{rotate} \docType{methods} \alias{rotate} \alias{rotate,Raster-method} \title{Rotate} \description{ Rotate a Raster* object that has x coordinates (longitude) from 0 to 360, to standard coordinates between -180 and 180 degrees. Longitude between 0 and 360 is frequently used in global climate models. } \usage{ \S4method{rotate}{Raster}(x, filename='', ...) } \arguments{ \item{x}{Raster* object} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or a RasterBrick object } \seealso{ \code{\link[raster]{flip}} } \examples{ r <- raster(nrow=18, ncol=36) m <- matrix(1:ncell(r), nrow=18) values(r) <- as.vector(t(m)) extent(r) <- extent(0, 360, -90, 90) rr <- rotate(r) } \keyword{spatial} raster/man/bands.Rd0000644000176200001440000000255714160021141013702 0ustar liggesusers\name{bands} \alias{bandnr} \alias{bandnr,RasterLayer-method} \alias{nbands} \title{Number of bands} \description{ A 'band' refers to a single layer for a possibly multi-layer file. Most RasterLayer objects will refer to files with a single layer. The term 'band' is frequently used in remote sensing to refer to a variable (layer) in a multi-variable dataset as these variables typically reperesent reflection in different bandwidths in the electromagnetic spectrum. But in that context, bands could be stored in a single or in separate files. In the context of the raster package, the term band is equivalent to a layer in a raster file. \code{nbands} returns the number of bands of the file that a RasterLayer points to (and 1 if it does not point at any file). This functions also works for a RasterStack for which it is equivalent to \code{\link{nlayers}}. \code{band} returns the specific band the RasterLayer refers to (1 if the RasterLayer points at single layer file or does not point at any file). } \usage{ nbands(x) bandnr(x, ...) } \arguments{ \item{x}{RasterLayer} \item{...}{Additional arguments (none at this time)} } \seealso{\code{\link[raster]{nlayers}}} \value{ numeric >= 1 } \examples{ f <- system.file("external/rlogo.grd", package="raster") r <- raster(f, layer=2) nbands(r) bandnr(r) } \keyword{spatial} raster/man/shapefile.Rd0000644000176200001440000000346214160021141014547 0ustar liggesusers \name{shapefile} \alias{shapefile} \alias{shapefile,character-method} \alias{shapefile,Spatial-method} \title{ Read or write a shapefile } \description{ Reading and writing of "ESRI shapefile" format spatial data. Only the three vector types (points, lines, and polygons) can be stored in shapefiles. These are simple wrapper functions around readOGR and writeOGR (rgdal package). A shapefile should consist of at least four files: .shp (the geometry), .dbf (the attributes), .shx (the index that links the two, and .prj (the coordinate reference system). If the .prj file is missing, a warning is given. If any other file is missing an error occurs (although one could in principle recover the .shx from the .shp file). Additional files are ignored. } \usage{ \S4method{shapefile}{character}(x, stringsAsFactors=FALSE, verbose=FALSE, warnPRJ=TRUE, ...) \S4method{shapefile}{Spatial}(x, filename='', overwrite=FALSE, ...) } \arguments{ \item{x}{character (a file name, when reading a shapefile) or Spatial* object (when writing a shapefile)} \item{filename}{character. Filename to write a shapefile} \item{overwrite}{logical. Overwrite existing shapefile?} \item{verbose}{logical. If \code{TRUE}, information about the file is printed} \item{warnPRJ}{logical. If \code{TRUE}, a warning is given if there is no .prj file} \item{stringsAsFactors}{logical. If \code{TRUE}, strings are converted to factors} \item{...}{Additional arguments passed to rgdal functions readOGR or writeOGR} } \value{ Spatial*DataFrame (reading). Nothing is returned when writing a shapefile. } \examples{ if (require(rgdal)) { filename <- system.file("external/lux.shp", package="raster") filename p <- shapefile(filename) \dontrun{ shapefile(p, 'copy.shp') } } } \keyword{spatial} raster/man/boundaries.Rd0000644000176200001440000000276114160021141014743 0ustar liggesusers\name{boundaries} \alias{boundaries} \alias{boundaries,RasterLayer-method} \title{boundaries (edges) detection} \description{ Detect boundaries (edges). boundaries are cells that have more than one class in the 4 or 8 cells surrounding it, or, if \code{classes=FALSE}, cells with values and cells with \code{NA}. } \usage{ \S4method{boundaries}{RasterLayer}(x, type='inner', classes=FALSE, directions=8, asNA=FALSE, filename="", ...) } \arguments{ \item{x}{RasterLayer object} \item{type}{character. 'inner' or 'outer'} \item{classes}{character. Logical. If \code{TRUE} all different values are (after rounding) distinguished, as well as \code{NA}. If \code{FALSE} (the default) only edges between \code{NA} and non-\code{NA} cells are considered} \item{directions}{integer. Which cells are considered adjacent? Should be 8 (Queen's case) or 4 (Rook's case)} \item{asNA}{logical. If \code{TRUE}, non-edges are returned as \code{NA} instead of zero} \item{filename}{character. Filename for the output RasterLayer (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer. Cell values are either 1 (a border) or 0 (not a border), or \code{NA} } \seealso{ \code{\link{focal}}, \code{\link{clump}} } \examples{ r <- raster(nrow=18, ncol=36, xmn=0) r[150:250] <- 1 r[251:450] <- 2 plot( boundaries(r, type='inner') ) plot( boundaries(r, type='outer') ) plot( boundaries(r, classes=TRUE) ) } \keyword{methods} \keyword{spatial} raster/man/setValues.Rd0000644000176200001440000000334614160021141014563 0ustar liggesusers\name{setValues} \alias{values<-} \alias{values<-,RasterLayer,ANY-method} \alias{values<-,RasterLayerSparse,ANY-method} \alias{values<-,RasterStack,ANY-method} \alias{values<-,RasterBrick,ANY-method} \alias{setValues} \alias{setValues,RasterLayer-method} \alias{setValues,RasterLayerSparse-method} \alias{setValues,RasterStack-method} \alias{setValues,RasterBrick-method} \title{Set values of a Raster object} \description{ Assign (new) values to a Raster* object. } \usage{ \S4method{setValues}{RasterLayer}(x, values, ...) \S4method{setValues}{RasterBrick}(x, values, layer=-1, ...) \S4method{setValues}{RasterStack}(x, values, layer=-1, ...) \S4method{setValues}{RasterLayerSparse}(x, values, index=NULL, ...) values(x) <- value } \arguments{ \item{x}{A \code{Raster*} } \item{values}{Cell values to associate with the Raster* object. There should be values for all cells} \item{value}{Cell values to associate with the Raster* object. There should be values for all cells} \item{layer}{Layer number (only relevant for RasterBrick and RasterStack objects). If missing, the values of all layers is set} \item{index}{Cell numbers corresponding to the values} \item{...}{Additional arguments (none implemented)} } \seealso{ \code{\link[raster]{replacement}} } \value{ a Raster* object } \note{ While you can access the 'values' slot of the objects directly, you would do that at your own peril because when setting values, multiple slots need to be changed; which is what setValues takes care of. } \examples{ r <- raster(ncol=10, nrow=10) vals <- 1:ncell(r) r <- setValues(r, vals) # equivalent to values(r) <- vals } \keyword{ spatial } \keyword{ methods } raster/man/raster.Rd0000644000176200001440000001557714160021141014121 0ustar liggesusers\name{raster} \docType{methods} \alias{raster} \alias{raster,missing-method} \alias{raster,character-method} \alias{raster,Extent-method} \alias{raster,BasicRaster-method} \alias{raster,RasterLayer-method} \alias{raster,RasterLayerSparse-method} \alias{raster,RasterStack-method} \alias{raster,RasterBrick-method} \alias{raster,Spatial-method} \alias{raster,SpatialGrid-method} \alias{raster,SpatialPixels-method} \alias{raster,matrix-method} \alias{raster,list-method} \alias{raster,im-method} \alias{raster,asc-method} \alias{raster,kasc-method} \alias{raster,kde-method} \alias{raster,grf-method} \alias{raster,sf-method} \alias{raster,GridTopology-method} \alias{raster,SpatRaster-method} \title{Create a RasterLayer object} \description{ Methods to create a RasterLayer object. RasterLayer objects can be created from scratch, a file, an Extent object, a matrix, an 'image' object, or from a Raster*, Spatial*, im (spatstat) asc, kasc (adehabitat*), grf (geoR) or kde object. In many cases, e.g. when a RasterLayer is created from a file, it does (initially) not contain any cell (pixel) values in (RAM) memory, it only has the parameters that describe the RasterLayer. You can access cell-values with \code{\link[raster]{getValues}, \link[raster]{extract}} and related functions. You can assign new values with \code{\link[raster]{setValues}} and with \code{\link[raster]{replacement}}. For an overview of the functions in the raster package have a look here: \code{\link{raster-package}}. } \usage{ \S4method{raster}{character}(x, band=1, ...) \S4method{raster}{RasterLayer}(x) \S4method{raster}{RasterStack}(x, layer=0) \S4method{raster}{RasterBrick}(x, layer=0) \S4method{raster}{missing}(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, crs, ext, resolution, vals=NULL) \S4method{raster}{Extent}(x, nrows=10, ncols=10, crs="", ...) \S4method{raster}{matrix}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", template=NULL) \S4method{raster}{Spatial}(x, origin, ...) \S4method{raster}{SpatialGrid}(x, layer=1, values=TRUE) \S4method{raster}{SpatialPixels}(x, layer=1, values=TRUE) \S4method{raster}{sf}(x, origin, ...) } \arguments{ \item{x}{filename (character), Extent, Raster*, sf, SpatialPixels*, SpatialGrid*, object, 'image', matrix, im, or missing. Supported file types are the 'native' raster package format and those that can be read via \code{rgdal} (see \code{\link[rgdal]{readGDAL}}} \item{band}{integer. The layer to use in a multi-layer file} \item{...}{Additional arguments, see Details } \item{layer}{integer. The layer (variable) to use in a multi-layer file, or the layer to extract from a RasterStack/Brick or SpatialPixelsDataFrame or SpatialGridDataFrame. An empty RasterLayer (no associated values) is returned if \code{layer=0}} \item{values}{logical. If \code{TRUE}, the cell values of '\code{x}' are copied to the RasterLayer object that is returned} \item{nrows}{integer > 0. Number of rows} \item{ncols}{integer > 0. Number of columns} \item{xmn}{minimum x coordinate (left border)} \item{xmx}{maximum x coordinate (right border)} \item{ymn}{minimum y coordinate (bottom border)} \item{ymx}{maximum y coordinate (top border)} \item{ext}{object of class Extent. If present, the arguments xmn, xmx, ymn and ynx are ignored} \item{crs}{character or object of class CRS. PROJ.4 type description of a Coordinate Reference System (map projection). If this argument is missing, and the x coordinates are within -360 .. 360 and the y coordinates are within -90 .. 90, "+proj=longlat +datum=WGS84" is used. Also see under Details if \code{x} is a character (filename)} \item{resolution}{numeric vector of length 1 or 2 to set the resolution (see \code{\link{res}}). If this argument is used, arguments \code{ncols} and \code{nrows} are ignored } \item{vals}{optional. Values for the new RasterLayer. Accepted formats are as for \code{\link{setValues}}} \item{origin}{minimum y coordinate (bottom border)} \item{template}{Raster* or Extent object used to set the extent (and CRS in case of a Raster* object). If not \code{NULL}, arguments \code{xmn}, \code{xmx}, \code{ymn}, \code{ymx} and \code{crs} (unless \code{template} is an Extent object) are ignored} } \details{ If \code{x} is a filename, the following additional variables are recognized: \code{sub}: positive integer. Subdataset number for a file with subdatasets \code{native}: logical. Default is \code{FALSE} except when package \code{rgdal} is missing. If \code{TRUE}, reading and writing of IDRISI, BIL, BSQ, BIP, SAGA, and Arc ASCII files is done with native (raster package) drivers, rather then via rgdal. 'raster' and netcdf format files are always read with native drivers. \code{RAT}: logical. The default is \code{TRUE}, in which case a raster attribute table is created for files that have one \code{offset}: integer. To indicate the number of header rows on non-standard ascii files (rarely useful; use with caution) \code{crs}: character. PROJ.4 string to set the CRS. Ignored when the file provides a CRS description that can be interpreted. If \code{x} represents a \bold{NetCDF} file, the following additional variable is recognized: \code{varname}: character. The variable name, such as 'tasmax' or 'pr'. If not supplied and the file has multiple variables are a guess will be made (and reported) \code{lvar}: integer > 0 (default=3). To select the 'level variable' (3rd dimension variable) to use, if the file has 4 dimensions (e.g. depth instead of time)\cr \code{level}: integer > 0 (default=1). To select the 'level' (4th dimension variable) to use, if the file has 4 dimensions, e.g. to create a RasterBrick of weather over time at a certain height. \cr To use NetCDF files the \code{ncdf4} package needs to be available. It is assumed that these files follow, or are compatible with, the CF-1 convention (The GMT format may also work). If the ncdf file does not have a standard extension (which is used to recognize the file format), you can use argument \code{ncdf=TRUE} to indicate the format. If \code{x} is a \code{Spatial} or an \code{Extent} object, additional arguments are for the method with signature \code{'missing'} } \value{ RasterLayer } \seealso{ \code{\link[raster]{stack}, \link[raster]{brick}} } \examples{ # Create a RasterLayer object from a file # N.B.: For your own files, omit the 'system.file' and 'package="raster"' bits # these are just to get the path to files installed with the package f <- system.file("external/test.grd", package="raster") f r <- raster(f) logo <- raster(system.file("external/rlogo.grd", package="raster")) #from scratch r1 <- raster(nrows=108, ncols=21, xmn=0, xmx=10) #from an Extent object e <- extent(r) r2 <- raster(e) #from another Raster* object r3 <- raster(r) s <- stack(r, r, r) r4 <- raster(s) r5 <- raster(s, 3) } \keyword{methods} \keyword{spatial} raster/man/getData.Rd0000644000176200001440000000670714160021141014165 0ustar liggesusers\name{getData} \alias{getData} \alias{ccodes} \title{Get geographic data } \description{ Get geographic data for anywhere in the world. Data are read from files that are first downloaded if necessary. Function \code{ccodes} returns country names and the ISO codes } \usage{ getData(name, download=TRUE, path="", ...) ccodes() } \arguments{ \item{name}{Data set name, currently supported are 'GADM', 'countries', 'SRTM', 'alt', and 'worldclim'. See Details for more info} \item{download}{Logical. If \code{TRUE} data will be downloaded if not locally available} \item{path}{Character. Path name indicating where to store the data. Default is the current working directory } \item{...}{ Additional required (!) parameters. These are data set specific. See Details} } \value{ A spatial object (Raster* or Spatial*) } \details{ 'alt' stands for altitude (elevation); the data were aggregated from SRTM 90 m resolution data between -60 and 60 latitude. 'GADM' is a database of global administrative boundaries. 'worldclim' is a database of global interpolated climate data. 'SRTM' refers to the hole-filled CGIAR-SRTM (90 m resolution). 'countries' has polygons for all countries at a higher resolution than the 'wrld_simpl' data in the maptools package . If \code{name} is 'alt' or 'GADM' you must provide a 'country=' argument. Countries are specified by their 3 letter ISO codes. Use getData('ISO3') to see these codes. In the case of GADM you must also provide the level of administrative subdivision (0=country, 1=first level subdivision). In the case of alt you can set 'mask' to FALSE. If it is TRUE values for neighbouring countries are set to NA. For example: \code{getData('GADM', country='FRA', level=1)} \code{getData('alt', country='FRA', mask=TRUE)} If \code{name} is 'SRTM' you must provide 'lon' and 'lat' arguments (longitude and latitude). These should be single numbers somewhere within the SRTM tile that you want. \code{getData('SRTM', lon=5, lat=45)} If \code{name='worldclim'} you must also provide arguments \code{var}, and a resolution \code{res}. Valid variables names are 'tmin', 'tmax', 'prec' and 'bio'. Valid resolutions are 0.5, 2.5, 5, and 10 (minutes of a degree). In the case of \code{res=0.5}, you must also provide a \code{lon} and \code{lat} argument for a tile; for the lower resolutions global data will be downloaded. In all cases there are 12 (monthly) files for each variable except for 'bio' which contains 19 files. \code{getData('worldclim', var='tmin', res=0.5, lon=5, lat=45)} \code{getData('worldclim', var='bio', res=10)} To get (projected) future climate data (CMIP5), you must provide arguments \code{var} and \code{res} as above. Only resolutions 2.5, 5, and 10 are currently available. In addition, you need to provide \code{model}, \code{rcp} and \code{year}. For example, \code{getData('CMIP5', var='tmin', res=10, rcp=85, model='AC', year=70)} function (var, model, rcp, year, res, lon, lat, path, download = TRUE) 'model' should be one of "AC", "BC", "CC", "CE", "CN", "GF", "GD", "GS", "HD", "HG", "HE", "IN", "IP", "MI", "MR", "MC", "MP", "MG", or "NO". 'rcp' should be one of 26, 45, 60, or 85. 'year' should be 50 or 70 Not all combinations are available. See www.worldclim.org for details. } \references{ \url{https://www.worldclim.org} \url{https://gadm.org} \url{https://srtm.csi.cgiar.org/} \url{https://diva-gis.org/gdata} } \keyword{ spatial } raster/man/setMinMax.Rd0000644000176200001440000000132014160021141014503 0ustar liggesusers\name{setMinMax} \alias{setMinMax,RasterLayer-method} \alias{setMinMax,RasterStack-method} \alias{setMinMax,RasterBrick-method} \alias{setMinMax} \title{Compute min and max values} \description{ The minimum and maximum value of a RasterLayer are computed (from a file on disk if necessary) and stored in the returned Raster* object. } \usage{ setMinMax(x, ...) } \arguments{ \item{x}{Raster object } \item{\dots}{additional arguments, none implemented} } \value{ Raster object } \seealso{ \code{\link[raster]{getValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) r r <- setMinMax(r) r } \keyword{ spatial } \keyword{ methods } raster/man/rasterOptions.Rd0000644000176200001440000001016714160021141015463 0ustar liggesusers\name{Options} \alias{rasterOptions} \alias{tmpDir} \title{Global options for the raster package} \description{ Set, inspect, reset, save a number of global options used by the raster package. Most of these options are used when writing files to disk. They can be ignored by specific functions if the corresponding argument is provided as an argument to these functions. The default location is returned by \code{rasterTmpDir}. It is the same as that of the R temp directory but you can change it (for the current session) with \code{rasterOptions(tmpdir="path")}. To permanently set any of these options, you can add them to \code{/etc/Rprofile.site>}. For example, to change the default directory used to save temporary files, add a line like this: \code{options(rasterTmpDir='c:/temp/')} to that file. All temporary raster files in that folder that are older than 24 hrs are deleted when the raster package is loaded. Function \code{tmpDir} returns the location of the temporary files } \usage{ rasterOptions(format, overwrite, datatype, tmpdir, tmptime, progress, timer, chunksize, maxmemory, memfrac, todisk, setfileext, tolerance, standardnames, depracatedwarnings, addheader, default=FALSE) tmpDir(create=TRUE) } \arguments{ \item{format}{character. The default file format to use. See \code{\link[raster]{writeFormats}}} \item{overwrite}{logical. The default value for overwriting existing files. If \code{TRUE}, existing files will be overwritten} \item{datatype}{character. The default data type to use. See \link[raster]{dataType}} \item{tmpdir}{character. The default location for writing temporary files; See \code{\link{rasterTmpFile}}} \item{tmptime}{number > 1. The number of hours after which a temporary file will be deleted. As files are deleted when loading the raster package, this option is only useful if you save this option so that it is loaded when starting a new session} \item{progress}{character. Valid values are "text", "window" and "" (the default in most functions, no progress bar)} \item{timer}{Logical. If \code{TRUE}, the time it took to complete the function is printed} \item{chunksize}{integer. Maximum number of bytes to read/write in a single chunk while processing (chunk by chunk) disk based Raster* objects} \item{maxmemory}{numeric. Maximum number of bytes to read into memory. If a process is expected to require more than this value, \code{\link{canProcessInMemory}} will return \code{FALSE} } \item{memfrac}{numeric. Fraction of available RAM that may be used by a process} \item{todisk}{logical. For debugging only. Default is \code{FALSE} and should normally not be changed. If \code{TRUE}, results are always written to disk, even if no filename is supplied (a temporary filename is used)} \item{setfileext}{logical. Default is \code{TRUE}. If \code{TRUE}, the file extension will be changed when writing (if known for the file type). E.g. GTiff files will be saved with the .tif extension } \item{tolerance}{numeric. The tolerance used when comparing the origin and resolution of Raster* objects. Expressed as the fraction of a single cell. This should be a number between 0 and 0.5 } \item{standardnames}{logical. Default is \code{TRUE}. Should \code{\link{names}} be standardized to be syntactically valid names (using \code{\link{make.names}})} \item{depracatedwarnings}{logical. If \code{TRUE} (the default) a warning is generated when a depracated (obsolete) function is used} \item{addheader}{character. If not equal to \code{''} (the default) an additional header file is written when a raster format file (grd/gri) is written. Supported formats are as in \code{\link{hdr}}} \item{default}{logical. If \code{TRUE}, all options are set to their default values} \item{create}{logical. If \code{TRUE}, the temporary files directory is created if it does not exist} } \value{ list of the current options (invisibly). If no arguments are provided the options are printed. } \seealso{ \code{\link[base]{options}}, \code{\link[raster]{rasterTmpFile}} } \examples{ \dontrun{ rasterOptions() rasterOptions(chunksize=2e+07) } } \keyword{ spatial } raster/man/replacement.Rd0000644000176200001440000000351214160021141015102 0ustar liggesusers\name{replacement} \docType{methods} \alias{[<-,RasterLayer,RasterLayer,missing-method} \alias{[<-,RasterLayer,missing,missing-method} \alias{[<-,RasterStackBrick,Raster,missing-method} \alias{[<-,RasterStackBrick,missing,missing-method} \alias{[[<-,RasterStack,numeric,missing-method} \alias{[[<-,Raster,numeric,missing-method} \alias{[[<-,RasterStackBrick,character,missing-method} \alias{[[<-,RasterLayer,character,missing-method} \alias{[<-,Raster,numeric,numeric-method} \alias{[<-,Raster,numeric,missing-method} \alias{[<-,Raster,matrix,missing-method} \alias{[<-,Raster,logical,missing-method} \alias{[<-,Raster,missing,numeric-method} \alias{[<-,Raster,Spatial,missing-method} \alias{[<-,Raster,Extent,missing-method} \alias{[<-,Extent,numeric,missing-method} \alias{$<-,Raster-method} \alias{$,Raster-method} \title{Replace cell values or layers of a Raster* object} \description{ You can set values of a Raster* object, when \code{i} is a vector of cell numbers, a Raster*, Extent, or Spatial* object. These are shorthand methods that work best for relatively small Raster* objects. In other cases you can use functions such as \code{\link{calc} and \link{rasterize}}. } \section{Methods}{ \describe{ \code{x[i] <- value} \code{x[i,j] <- value} \tabular{rll}{ \tab \bold{Arguments:} \tab \cr \tab \code{x} \tab a Raster* object \cr \tab \code{i} \tab cell number(s), row number(s), Extent, Spatial* object \cr \tab \code{j} \tab columns number(s) (only available if i is (are) a row number(s)) \cr \tab \code{value} \tab new cell value(s) \cr } }} \seealso{ \link{calc}, \link{rasterize}} \examples{ r <- raster(ncol=10, nrow=5) values(r) <- 1:ncell(r) * 2 r[1,] <- 1 r[,1] <- 2 r[1,1] <- 3 s <- stack(r, sqrt(r)) s[s<5] <- NA } \keyword{methods} \keyword{spatial} raster/man/animate.Rd0000644000176200001440000000223714160021141014224 0ustar liggesusers\name{animate} \docType{methods} \alias{animate} \alias{animate,RasterStackBrick-method} \title{Animate layers of a Raster* object} \description{ Animate (sequentially plot) the layers of a RasterStack or RasterBrick* object to create a movie } \usage{ \S4method{animate}{RasterStackBrick}(x, pause=0.25, main, zlim, maxpixels=50000, n=10, ...) } \arguments{ \item{x}{Raster* object} \item{pause}{numeric. How long should be the pause be between layers?} \item{main}{title for each layer. If not supplied the z-value is used if available. Otherwise the names are used.} \item{zlim}{numeric vector of lenght 2. Range of values to plot} \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting} \item{n}{integer > 0. Number of loops} \item{...}{Additional arguments passed to \code{\link{plot}}} } \value{ None } \seealso{ \code{\link{plot}}, \code{\link{spplot}}, \code{\link{plotRGB}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) animate(b, n=1) } \keyword{methods} \keyword{spatial} raster/man/brick.Rd0000644000176200001440000001077614160021141013707 0ustar liggesusers\name{brick} \docType{methods} \alias{brick} \alias{brick,character-method} \alias{brick,missing-method} \alias{brick,RasterLayer-method} \alias{brick,RasterStack-method} \alias{brick,RasterBrick-method} \alias{brick,Extent-method} \alias{brick,array-method} \alias{brick,list-method} \alias{brick,SpatialPixels-method} \alias{brick,SpatialGrid-method} \alias{brick,kasc-method} \alias{brick,grf-method} \alias{brick,SpatRaster-method} \title{ Create a RasterBrick object} \description{ A RasterBrick is a multi-layer raster object. They are typically created from a multi-layer (band) file; but they can also exist entirely in memory. They are similar to a RasterStack (that can be created with \code{\link[raster]{stack}}), but processing time should be shorter when using a RasterBrick. Yet they are less flexible as they can only point to a single file. A RasterBrick can be created from RasterLayer objects, from a RasterStack, or from a (multi-layer) file. The can also be created from SpatialPixels*, SpatialGrid*, and Extent objects, and from a three-dimensional array. } \usage{ \S4method{brick}{character}(x, ...) \S4method{brick}{RasterStack}(x, values=TRUE, nl, filename='', ...) \S4method{brick}{RasterBrick}(x, nl, ...) \S4method{brick}{RasterLayer}(x, ..., values=TRUE, nl=1, filename='') \S4method{brick}{missing}(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, nl=1, crs) \S4method{brick}{Extent}(x, nrows=10, ncols=10, crs="", nl=1) \S4method{brick}{array}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", transpose=FALSE) \S4method{brick}{SpatialGrid}(x) \S4method{brick}{SpatialPixels}(x) } \arguments{ \item{x}{character (filename, see Details); Raster* object; missing; array; SpatialGrid*; SpatialPixels*; Extent; or list of Raster* objects. Supported file types are the 'native' raster package format and those that can be read via rgdal (see \code{\link[rgdal]{readGDAL}}), and NetCDF files (see details)} \item{...}{see Details} \item{values}{logical. If \code{TRUE}, the cell values of '\code{x}' are copied to the RasterBrick object that is returned} \item{nl}{integer > 0. How many layers should the RasterBrick have?} \item{filename}{character. Filename if you want the RasterBrick to be saved on disk} \item{nrows}{integer > 0. Number of rows} \item{ncols}{integer > 0. Number of columns} \item{xmn}{minimum x coordinate (left border)} \item{xmx}{maximum x coordinate (right border)} \item{ymn}{minimum y coordinate (bottom border)} \item{ymx}{maximum y coordinate (top border)} \item{crs}{character or object of class CRS. PROJ4 type description of a Coordinate Reference System (map projection). If this argument is missing, and the x coordinates are within -360 .. 360 and the y coordinates are within -90 .. 90, "+proj=longlat +datum=WGS84" is used} \item{transpose}{if \code{TRUE}, the values in the array are transposed} } \details{ If \code{x} is a RasterLayer, the additional arguments can be used to pass additional Raster* objects. If there is a \code{filename} argument, the additional arguments are as for \code{\link{writeRaster}}. If \code{x} represents a filename there is the following additional argument: \code{native}: logical. If \code{TRUE} (not the default), reading and writing of IDRISI, BIL, BSQ, BIP, and Arc ASCII files is done with native (raster package) drivers, rather then via rgdal. In addition, if \code{x} is a \bold{NetCDF} filename there are the following additional arguments: \code{varname}: character. The variable name (e.g. 'altitude' or 'precipitation'. If not supplied and the file has multiple variables are a guess will be made (and reported)) \code{lvar}: integer > 0 (default=3). To select the 'level variable' (3rd dimension variable) to use, if the file has 4 dimensions (e.g. depth instead of time) \code{level}: integer > 0 (default=1). To select the 'level' (4th dimension variable) to use, if the file has 4 dimensions, e.g. to create a RasterBrick of weather over time at a certain height. \code{dims}: integer vector to indicated the order of the dimensions. Default is \code{dims=c(1,2,3)} (rows, cols, time). To use NetCDF files the \code{ncdf4} package needs to be available. It is assumed that these files follow, or are compatible with the CF-1 convention. } \value{ RasterBrick } \seealso{ \code{\link[raster]{raster}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) b nlayers(b) names(b) extract(b, 870) } \keyword{methods} \keyword{spatial} raster/man/Math-methods.Rd0000644000176200001440000000210114160021141015126 0ustar liggesusers\name{Math-methods} \docType{methods} \alias{Math-methods} \alias{Math2,Extent-method} \alias{Math2,Raster-method} \alias{Math,Raster-method} \alias{Math,RasterLayerSparse-method} \alias{log,Raster-method} \title{Mathematical functions} \description{ Generic mathematical functions that can be used with a Raster* object as argument: \code{"abs", "sign", "sqrt", "ceiling", "floor", "trunc", "cummax", "cummin", } \code{"cumprod", "cumsum", "log", "log10", "log2", "log1p", "acos", "acosh", "asin", } \code{"asinh", "atan", "atanh", "exp", "expm1", "cos", "cosh", "sin", "sinh", "tan", "tanh"}. } \section{Note}{ You can use the, somewhat more flexible, function \code{\link[raster]{calc}} instead of the Math-methods. } \seealso{ \code{\link[raster]{Arith-methods}}, \code{\link{calc}}, \code{\link{overlay}}, \code{\link{atan2}} } \examples{ r1 <- raster(nrow=10, ncol=10) r1 <- setValues(r1, runif(ncell(r1)) * 10) r2 <- sqrt(r1) s <- stack(r1, r2) - 5 b <- abs(s) } \keyword{spatial} \keyword{methods} \keyword{math} raster/man/programming.Rd0000644000176200001440000000546514160021141015136 0ustar liggesusers\name{Programming} \alias{readStart} \alias{readStop} \alias{readStart,Raster-method} \alias{readStart,RasterStack-method} \alias{readStop,Raster-method} \alias{readStop,RasterStack-method} \alias{canProcessInMemory} \alias{pbCreate} \alias{pbStep} \alias{pbClose} \alias{getCluster} \alias{returnCluster} \title{Helper functions for programming} \description{ These are low level functions that can be used by programmers to develop new functions. If in doubt, it is almost certain that you do not need these functions as these are already embedded in all other functions in the raster package. \code{canProcessInMemory} is typically used within functions. In the raster package this function is used to determine if the amount of memory needed for the function is available. If there is not enough memory available, the function returns \code{FALSE}, and the function that called it will write the results to a temporary file. readStart opens file connection(s) for reading, readStop removes it. pbCreate creates a progress bar, pbStep sets the progress, and pbClose closes it. } \usage{ canProcessInMemory(x, n=4, verbose=FALSE) pbCreate(nsteps, progress, style=3, label='Progress', ...) pbStep(pb, step=NULL, label='') pbClose(pb, timer) readStart(x, ...) readStop(x) getCluster() returnCluster() } \arguments{ \item{x}{RasterLayer or RasterBrick object (for connections) or RasterStack object (canProcessInMemory)} \item{n}{integer. The number of copies of the Raster* object cell values that a function needs to be able to have in memory} \item{verbose}{logical. If \code{TRUE} the amount of memory needed and available is printed} \item{nsteps}{integer. Number of steps the progress bar will make from start to end (e.g. nrow(raster)) } \item{progress}{character. 'text', 'window', or ''} \item{style}{style for text progress bar. See \code{\link[utils]{txtProgressBar}} } \item{label}{character. Label for the window type progress bar} \item{...}{additional arguments (None implemented, except for 'silent=TRUE' for readStart for files read with gdal, and other arguments passed to gdal.open)} \item{pb}{ progress bar object created with pbCreate } \item{step}{which step is this ( 1 <= step <= nsteps ). If step is \code{NULL}, a single step is taken } \item{timer}{logical. If \code{TRUE}, time to completion will be printed. If missing, the value will be taken from the rasterOptions} } \value{ canProcessInMemory: logical closeConnection: RasterLayer or RasterBrick object getCluster: snow cluster object } \examples{ r <- raster(nrow=100, ncol=100) canProcessInMemory(r, 4) r <- raster(nrow=50000, ncol=50000) canProcessInMemory(r, 2, verbose=TRUE) rasterOptions(maxmem=Inf, memfrac=.8) rasterOptions(default=TRUE) } \keyword{ spatial } raster/man/zoom.Rd0000644000176200001440000000234714160021141013574 0ustar liggesusers\name{zoom} \docType{methods} \alias{zoom} \alias{zoom,Raster-method} \alias{zoom,Spatial-method} \alias{zoom,missing-method} \title{Zoom in on a map} \description{ Zoom in on a map (plot) by providing a new extent, by default this is done by clicking twice on the map. } \usage{ zoom(x, ...) \S4method{zoom}{Raster}(x, ext=drawExtent(), maxpixels=100000, layer=1, new=TRUE, useRaster=TRUE, ...) \S4method{zoom}{Spatial}(x, ext=drawExtent(), new=TRUE, ...) \S4method{zoom}{missing}(x, ext=drawExtent(), new=TRUE, ...) } \arguments{ \item{x}{Raster* or Spatial* (vector type) object} \item{ext}{Extent object, or other object from which an extent can be extracted} \item{maxpixels}{Maximum number of pixels used for the map} \item{layer}{Positive integer to select the layer to be used if x is a mutilayer Raster object} \item{new}{Logical. If \code{TRUE}, the zoomed in map will appear on a new device (window)} \item{useRaster}{Logical. If \code{TRUE}, a bitmap raster is used to plot the image instead of polygons} \item{...}{additional paramters for base plot} } \value{ Extent object (invisibly) } \seealso{ \code{\link[raster]{drawExtent}}, \code{\link[raster]{plot}}} \keyword{spatial} raster/man/layerStats.Rd0000644000176200001440000000407414160021141014742 0ustar liggesusers\name{layerStats} \alias{layerStats} \title{Correlation and (weighted) covariance} \description{ Compute correlation and (weighted) covariance for multi-layer Raster objects. Like \code{\link{cellStats}} this function returns a few values, not a Raster* object (see \code{\link{Summary-methods}} for that). } \usage{ layerStats(x, stat, w, asSample=TRUE, na.rm=FALSE, ...) } \arguments{ \item{x}{RasterStack or RasterBrick for which to compute a statistic} \item{stat}{Character. The statistic to compute: either 'cov' (covariance), 'weighted.cov' (weighted covariance), or 'pearson' (correlation coefficient)} \item{w}{RasterLayer with the weights (should have the same extent, resolution and number of layers as \code{x}) to compute the weighted covariance} \item{asSample}{Logical. If \code{TRUE}, the statistic for a sample (denominator is \code{n-1}) is computed, rather than for the population (denominator is \code{n})} \item{na.rm}{Logical. Should missing values be removed?} \item{...}{Additional arguments (none implemetned)} } \value{ List with two items: the correlation or (weighted) covariance matrix, and the (weighted) means. } \author{Jonathan A. Greenberg & Robert Hijmans. Weighted covariance based on code by Mort Canty} \references{ For the weighted covariance: \itemize{ \item {Canty, M.J. and A.A. Nielsen, 2008. Automatic radiometric normalization of multitemporal satellite imagery with the iteratively re-weighted MAD transformation. Remote Sensing of Environment 112:1025-1036.} \item {Nielsen, A.A., 2007. The regularized iteratively reweighted MAD method for change detection in multi- and hyperspectral data. IEEE Transactions on Image Processing 16(2):463-478.} } } \seealso{ \code{\link{cellStats}}, \code{\link{cov.wt}}, \code{\link[raster]{weighted.mean}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) layerStats(b, 'pearson') layerStats(b, 'cov') # weigh by column number w <- init(b, v='col') layerStats(b, 'weighted.cov', w=w) } raster/man/setExtent.Rd0000644000176200001440000000247314160021141014573 0ustar liggesusers\name{setExtent} \alias{setExtent} \alias{extent<-} \title{Set the extent of a RasterLayer} \description{ setExtent sets the extent of a Raster* object. Either by providing a new Extent object or by setting the extreme coordinates one by one. } \usage{ setExtent(x, ext, keepres=FALSE, snap=FALSE) extent(x) <- value } \arguments{ \item{x}{A Raster* object} \item{ext}{ An object of class Extent (which you can create with \code{\link[raster]{extent}}, or an object that has an extent (e.g. a Raster* or Spatial* object) ) } \item{keepres}{logical. If \code{TRUE}, the resolution of the cells will stay the same after adjusting the bounding box (by adjusting the number of rows and columns). If \code{FALSE}, the number of rows and columns will stay the same, and the resolution will be adjusted. } \item{snap}{logical. If \code{TRUE}, the extent is adjusted so that the cells of the input and output RasterLayer are aligned} \item{value}{An object of class Extent (which you can create with \code{\link[raster]{extent}} )} } \value{ a Raster* object } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{Extent-class}} } \examples{ r <- raster() bb <- extent(-10, 10, -20, 20) extent(r) <- bb r <- setExtent(r, bb, keepres=TRUE) } \keyword{spatial} raster/man/ncell.Rd0000644000176200001440000000173014160021141013700 0ustar liggesusers\name{ncell} \alias{ncol} \alias{nrow} \alias{nrow,BasicRaster-method} \alias{ncol,BasicRaster-method} \alias{ncell} \alias{ncell,ANY-method} \alias{ncell,BasicRaster-method} \alias{length,BasicRaster-method} \alias{nrow<-} \alias{ncol<-} \alias{nrow<-,BasicRaster,numeric-method} \alias{ncol<-,BasicRaster,numeric-method} \title{Number or rows, columns, and cells of a Raster* object} \description{ Get the number of rows, columns, or cells of a Raster* object. } \usage{ ncol(x) nrow(x) ncell(x) ncol(x, ...) <- value nrow(x, ...) <- value } \arguments{ \item{x}{a Raster object} \item{value}{row or column number (integer > 0)} \item{...}{additional arguments. None implemented} } \value{ Integer } \seealso{ \code{\link{dim}, \link{extent}}, \link{res} } \examples{ r <- raster() ncell(r) ncol(r) nrow(r) dim(r) nrow(r) <- 18 ncol(r) <- 36 # equivalent to dim(r) <- c(18, 36) } \keyword{spatial} raster/man/stackSelect.Rd0000644000176200001440000000313114160021141015045 0ustar liggesusers\name{stackSelect} \alias{stackSelect} \alias{stackSelect,RasterStackBrick,Raster-method} \title{Select cell values from a multi-layer Raster* object} \description{ Use a Raster* object to select cell values from different layers in a multi-layer Raster* object. The object to select values \code{y} should have values between \code{1} and \code{nlayers(x)}. The values of \code{y} are rounded. See \code{\link{extract}} for extraction of values by cell, point, or otherwise. } \usage{ \S4method{stackSelect}{RasterStackBrick,Raster}(x, y, recycle=FALSE, type='index', filename='', ...) } \arguments{ \item{x}{RasterStack or RasterBrick object} \item{y}{Raster* object} \item{recycle}{Logical. Recursively select values (default = \code{FALSE}. Only relevant if \code{y} has multiple layers. E.g. if \code{x} has 12 layers, and \code{y} has 4 layers, the indices of the \code{y} layers are used three times.} \item{type}{Character. Only relevant when \code{recycle=TRUE}. Can be 'index' or 'truefalse'. If it is 'index', the cell values of \code{y} should represent layer numbers. If it is 'truefalse' layer numbers are indicated by 0 (not used, NA returned) and 1 (used)} \item{filename}{Character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ Raster* object } \seealso{\code{\link{stackApply}}, \code{\link{extract}}} \examples{ r <- raster(ncol=10, nrow=10, vals=1) s <- stack(r, r+2, r+5) values(r) <- round((runif(ncell(r)))*3) x <- stackSelect(s, r) } \keyword{methods} \keyword{spatial} raster/man/boxplot.Rd0000644000176200001440000000214314160021141014271 0ustar liggesusers\name{boxplot} \docType{methods} \alias{boxplot} \alias{boxplot,RasterLayer-method} \alias{boxplot,RasterStackBrick-method} \title{ Box plot of Raster objects } \description{ Box plot of layers in a Raster object } \usage{ \S4method{boxplot}{RasterStackBrick}(x, maxpixels=100000, ...) \S4method{boxplot}{RasterLayer}(x, y=NULL, maxpixels=100000, ...) } \arguments{ \item{x}{Raster* object} \item{y}{If \code{x} is a RasterLayer object, y can be an additional RasterLayer to group the values of \code{x} by 'zone'} \item{maxpixels}{Integer. Number of pixels to sample from each layer of large Raster objects} \item{...}{Arguments passed to \code{graphics::\link[graphics]{boxplot}}} } \seealso{ \code{\link{pairs}, \link{hist}} } \examples{ r1 <- r2 <- r3 <- raster(ncol=10, nrow=10) values(r1) <- rnorm(ncell(r1), 100, 40) values(r2) <- rnorm(ncell(r1), 80, 10) values(r3) <- rnorm(ncell(r1), 120, 30) s <- stack(r1, r2, r3) names(s) <- c('A', 'B', 'C') boxplot(s, notch=TRUE, col=c('red', 'blue', 'orange'), main='Box plot', ylab='random' ) } \keyword{spatial} raster/man/image.Rd0000644000176200001440000000341614160021141013670 0ustar liggesusers\name{image} \docType{methods} \alias{image} \alias{image,RasterLayer-method} \alias{image,RasterStackBrick-method} \title{Image} \description{ Create an "image" type plot of a RasterLayer. This is an implementation of a generic function in the graphics package. In most cases the \code{\link[raster]{plot}} function would be preferable because it produces a legend (and has some additional options). } \usage{ image(x, ...) \S4method{image}{RasterLayer}(x, maxpixels=500000, useRaster=TRUE, ...) \S4method{image}{RasterStackBrick}(x, y=1, maxpixels=100000, useRaster=TRUE, main, ...) } \arguments{ \item{x}{Raster* object} \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting} \item{useRaster}{If \code{TRUE}, the rasterImage function is used for plotting. Otherwise the image function is used. This can be useful if rasterImage does not work well on your system (see note)} \item{main}{character. Main plot title} \item{...}{Any argument that can be passed to \code{\link[graphics]{image}} (graphics package)} \item{y}{If \code{x} is a RasterStack or RasterBrick: integer, character (layer name(s)), or missing to select which layer(s) to plot} } \seealso{\code{\link[raster]{plot}}, \code{\link[graphics]{image}}, \code{\link[raster]{contour}}} \note{ raster uses \code{\link[graphics]{rasterImage}} from the graphics package. For unknown reasons this does not work on Windows Server and on a few versions of Windows XP. On that system you may need to use argument \code{useRaster=FALSE} to get a plot. } \examples{ r <- raster(system.file("external/test.grd", package="raster")) image(r) } \keyword{methods} \keyword{spatial} raster/man/autocor.Rd0000644000176200001440000000330414160021141014256 0ustar liggesusers\name{autocorrelation} \alias{Geary} \alias{Moran} \alias{MoranLocal} \alias{GearyLocal} \title{Spatial autocorrelation} \description{ Compute Moran's I or Geary's C measures of global spatial autocorrelation in a RasterLayer, or compute the the local Moran or Geary index (Anselin, 1995). } \usage{ Geary(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) Moran(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) MoranLocal(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) GearyLocal(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) } \arguments{ \item{x}{RasterLayer} \item{w}{Spatial weights defined by or a rectangular matrix with odd length (3, 5, ...) sides (as in \code{\link{focal}}) } } \value{ A single value (Moran's I or Geary's C) or a RasterLayer (Local Moran or Geary values) } \details{ The default setting uses a 3x3 neighborhood to compute "Queen's case" indices. You can use a filter (weights matrix) to do other things, such as "Rook's case", or different lags. } \seealso{ The spdep package for additional and more general approaches for computing indices of spatial autocorrelation } \author{Robert J. Hijmans and Babak Naimi} \references{ Moran, P.A.P., 1950. Notes on continuous stochastic phenomena. Biometrika 37:17-23 Geary, R.C., 1954. The contiguity ratio and statistical mapping. The Incorporated Statistician 5: 115-145 Anselin, L., 1995. Local indicators of spatial association-LISA. Geographical Analysis 27:93-115 } \examples{ r <- raster(nrows=10, ncols=10) values(r) <- 1:ncell(r) Moran(r) # Rook's case f <- matrix(c(0,1,0,1,0,1,0,1,0), nrow=3) Moran(r, f) Geary(r) x1 <- MoranLocal(r) # Rook's case x2 <- MoranLocal(r, w=f) } \keyword{spatial} raster/man/distance.Rd0000644000176200001440000000362514160021141014402 0ustar liggesusers\name{distance} \alias{distance} \alias{distance,RasterLayer,missing-method} \alias{distance,RasterLayer,RasterLayer-method} \alias{distance,Spatial,Spatial-method} \title{Distance} \description{ For a single \code{RasterLayer} (\code{y} is missing) this method computes the distance, for all cells that are \code{NA}, to the nearest cell that is not \code{NA}. The distance unit is in meters if the RasterLayer is not projected (\code{+proj=longlat}) and in map units (typically also meters) when it is projected. If two \code{RasterLayer} objects are provided, the cell-value distances are computed. If two \code{Spatial} vector type objects are provided, the distances between pairs of geographic object are computed. } \usage{ \S4method{distance}{RasterLayer,missing}(x, y, filename='', doEdge=TRUE, ...) \S4method{distance}{RasterLayer,RasterLayer}(x, y, ...) \S4method{distance}{Spatial,Spatial}(x, y, ...) } \arguments{ \item{x}{RasterLayer object} \item{y}{missing, RasterLayer or Spatial object} \item{filename}{Character. Filename for the output RasterLayer (optional)} \item{doEdge}{Logical. If \code{TRUE}, the \code{\link{boundaries}} function is called first. This may be efficient in cases where you compute the distance to large blobs. Calling \code{boundaries} determines the edge cells that matter for distance computation} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{RasterLayer} \seealso{ \code{\link[raster]{distanceFromPoints}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} See the \code{gdistance} package for more advanced distances, and the \code{geosphere} package for great-circle distances (and more) between points in longitude/latitude coordinates. } \examples{ r <- raster(ncol=36,nrow=18) values(r) <- NA r[500] <- 1 dist <- distance(r) #plot(dist / 1000) } \keyword{spatial} raster/man/scale.Rd0000644000176200001440000000230114160021141013665 0ustar liggesusers\name{scale} \alias{scale} \alias{scale,Raster-method} \title{Scale values} \description{ Center and/or scale raster data } \usage{ \S4method{scale}{Raster}(x, center=TRUE, scale=TRUE) } \arguments{ \item{x}{Raster* object} \item{center}{logical or numeric. If \code{TRUE}, centering is done by subtracting the layer means (omitting \code{NA}s), and if \code{FALSE}, no centering is done. If \code{center} is a numeric vector with length equal to the \code{nlayers(x)}, then each layer of \code{x} has the corresponding value from center subtracted from it.} \item{scale}{logical or numeric. If \code{TRUE}, scaling is done by dividing the (centered) layers of \code{x} by their standard deviations if \code{center} is \code{TRUE}, and the root mean square otherwise. If scale is \code{FALSE}, no scaling is done. If \code{scale} is a numeric vector with length equal to \code{nlayers(x)}, each layer of \code{x} is divided by the corresponding value. Scaling is done after centering.} } \value{ Raster* object } \seealso{ \code{\link[base]{scale}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) bs <- scale(b) } \keyword{ spatial } raster/man/cv.Rd0000644000176200001440000000176714160021141013225 0ustar liggesusers\name{cv} \alias{cv} \alias{cv,ANY-method} \alias{cv,Raster-method} \title{Coefficient of variation} \description{ Compute the coefficient of variation (expressed as a percentage). If there is only a single value, \code{sd} is \code{NA} and \code{cv} returns \code{NA} if \code{aszero=FALSE} (the default). However, if (\code{aszero=TRUE}), \code{cv} returns \code{0}. } \usage{ \S4method{cv}{ANY}(x, ..., aszero=FALSE, na.rm = FALSE) \S4method{cv}{Raster}(x, ..., aszero=FALSE, na.rm = FALSE) } \arguments{ \item{x}{A vector of numbers (typically integers for modal), or a Raster* object} \item{...}{additional (vectors of) numbers, or Raster objects} \item{aszero}{logical. If \code{TRUE}, a zero is returned (rather than an NA) if the cv of single value is computed} \item{na.rm}{Remove (ignore) NA values} } \value{ vector or RasterLayer } \examples{ data <- c(0,1,2,3,3,3,3,4,4,4,5,5,6,7,7,8,9,NA) cv(data, na.rm=TRUE) } \keyword{univar} \keyword{math} raster/man/rowFromCell.Rd0000644000176200001440000000222214160021141015033 0ustar liggesusers\name{rowFromCell} \alias{rowFromCell} \alias{rowFromCell,BasicRaster,numeric-method} \alias{colFromCell} \alias{colFromCell,BasicRaster,numeric-method} \alias{rowColFromCell} \alias{rowColFromCell,BasicRaster,numeric-method} \title{Row or column number from a cell number} \description{ These functions get the row and/or column number from a cell number of a Raster* object) } \usage{ colFromCell(object, cell) rowFromCell(object, cell) rowColFromCell(object, cell) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{cell}{cell number(s)} } \details{ The colFromCell and similar functions accept a single value, or a vector or list of these values, Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \value{ row of column number(s) } \seealso{ \code{\link[raster]{cellFrom}} } \examples{ r <- raster(ncols=10, nrows=10) colFromCell(r, c(5,15)) rowFromCell(r, c(5,15)) rowColFromCell(r, c(5,15)) } \keyword{spatial} raster/man/writeFormats.Rd0000644000176200001440000000317014160021141015271 0ustar liggesusers\name{writeFormats} \alias{writeFormats} \title{File types for writing} \description{ List supported file types for writing RasterLayer values to disk. When a function writes a file to disk, the file format is determined by the 'format=' argument if supplied, or else by the file extension (if the extension is known). If other cases the default format is used. The 'factory-fresh' default format is 'raster', but this can be changed using \code{\link{rasterOptions}}. } \usage{ writeFormats() } \details{ writeFormats returns a matrix of the file formats (the "drivers") that are supported. Supported formats include: \tabular{llllr}{ \tab \bold{File type} \tab \bold{Long name} \tab \bold{default extension} \tab \bold{Multiband support} \cr \tab \code{raster} \tab 'Native' raster package format \tab .grd \tab Yes \cr \tab \code{ascii} \tab ESRI Ascii \tab .asc \tab No \cr \tab \code{SAGA} \tab SAGA GIS \tab .sdat \tab No \cr \tab \code{IDRISI} \tab IDRISI \tab .rst \tab No \cr \tab \code{CDF} \tab netCDF (requires ncdf4) \tab .nc \tab Yes \cr \tab \code{GTiff} \tab GeoTiff (requires rgdal) \tab .tif \tab Yes \cr \tab \code{ENVI} \tab ENVI .hdr Labelled \tab .envi \tab Yes \cr \tab \code{EHdr} \tab ESRI .hdr Labelled \tab .bil \tab Yes \cr \tab \code{HFA} \tab Erdas Imagine Images (.img) \tab .img \tab Yes \cr } } \seealso{ \code{\link[rgdal]{GDALDriver-class}} } \examples{ writeFormats() } \keyword{ spatial } raster/man/aggregate.Rd0000644000176200001440000001224014160021141014527 0ustar liggesusers\name{aggregate} \docType{methods} \alias{aggregate} \alias{aggregate,Raster-method} \alias{aggregate,SpatialPolygons-method} \alias{aggregate,SpatialLines-method} \title{Aggregate raster cells or SpatialPolygons/Lines} \description{ Raster* objects: Aggregate a Raster* object to create a new RasterLayer or RasterBrick with a lower resolution (larger cells). Aggregation groups rectangular areas to create larger cells. The value for the resulting cells is computed with a user-specified function. SpatialPolygon*: Aggregate a SpatialPolygon* object, optionally by combining polygons that have the same attributes for one or more variables. If the polygons touch or overlap, internal boundaries are optionally "dissolved". } \usage{ \S4method{aggregate}{Raster}(x, fact, fun=mean, expand=TRUE, na.rm=TRUE, filename='', ...) \S4method{aggregate}{SpatialPolygons}(x, by, sums, dissolve=TRUE, vars=NULL, ...) } \arguments{ \item{x}{Raster* object or SpatialPolygons* object} \item{fact}{postive integer. Aggregation factor expressed as number of cells in each direction (horizontally and vertically). Or two integers (horizontal and vertical aggregation factor) or three integers (when also aggregating over layers). See Details} \item{fun}{function used to aggregate values } \item{expand}{logical. If \code{TRUE} the output Raster* object will be larger than the input Raster* object if a division of the number of columns or rows with \code{factor} is not an integer} \item{na.rm}{logical. If \code{TRUE}, NA cells are removed from calculations } \item{filename}{character. Output filename (optional)} \item{...}{if \code{x} is a Raster* object, additional arguments as for \code{\link{writeRaster}}} \item{by}{character or integer. The variables (column names or numbers) that should be used to aggregate (dissolve) the SpatialPolygons by only maintaining unique combinations of these variables. The default setting is to use no variables and aggregate all polygons. You can also supply a vector with a length of length(x)} \item{sums}{list with function(s) and variable(s) to summarize. This should be a list of lists in which each element of the main lists has two items. The first item is function (e.g. mean), the second element is a vector of column names (or indices) that need to summarize with that function. Be careful with character and factor variables (you can use, e.g. 'first' \code{function(x)x[1]} or 'last' \code{function(x)x[length(x)]} or \code{modal} for these variables} \item{vars}{deprecated. Same as \code{by}} \item{dissolve}{logical. If \code{TRUE} borders between touching or overlapping polygons are removed (requires package rgeos)} } \details{ Aggregation of a \code{x} will result in a Raster* object with fewer cells. The number of cells is the number of cells of \code{x} divided by \code{fact*fact} (when fact is a single number) or \code{prod(fact)} (when fact consists of 2 or 3 numbers). If necessary this number is adjusted according to the value of \code{expand}. For example, \code{fact=2} will result in a new Raster* object with \code{2*2=4} times fewer cells. If two numbers are supplied, e.g., \code{fact=c(2,3)}, the first will be used for aggregating in the horizontal direction, and the second for aggregating in the vertical direction, and the returned object will have \code{2*3=6} times fewer cells. Likewise, \code{fact=c(2,3,4)} aggregates cells in groups of 2 (rows) by 3 (columns) and 4 (layers). Aggregation starts at the upper-left end of a raster (you can use \code{\link{flip}} if you want to start elsewhere). If a division of the number of columns or rows with \code{factor} does not return an integer, the extent of the resulting Raster object will either be somewhat smaller or somewhat larger than the original RasterLayer. For example, if an input RasterLayer has 100 columns, and \code{fact=12}, the output Raster object will have either 8 columns (\code{expand=FALSE}) (using \code{8 x 12 = 96} of the original columns) or 9 columns (\code{expand=TRUE}). In both cases, the maximum x coordinate of the output RasterLayer would, of course, also be adjusted. The function \code{fun} should take multiple numbers, and return a single number. For example \code{mean}, \code{modal}, \code{min} or \code{max}. It should also accept a \code{na.rm} argument (or ignore it as one of the 'dots' arguments). } \value{ RasterLayer or RasterBrick, or a SpatialPolygons* object } \seealso{ \code{\link{disaggregate}}, \code{\link{resample}}. For SpatialPolygons* \code{\link[sp]{disaggregate}} } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster() # a new aggregated raster, no values ra <- aggregate(r, fact=10) r <- setValues(r, runif(ncell(r))) # a new aggregated raster, max of the values ra <- aggregate(r, fact=10, fun=max) # multiple layers s <- stack(r, r*2) x <- aggregate(s,2) #SpatialPolygons if (require(rgdal) & require(rgeos)) { p <- shapefile(system.file("external/lux.shp", package="raster")) p pa0 <- aggregate(p) pa0 pa1 <- aggregate(p, by='NAME_1', sums=list(list(mean, 'ID_2'))) pa1 } } \keyword{methods} \keyword{spatial} raster/man/filledContour.Rd0000644000176200001440000000146714160021141015423 0ustar liggesusers\name{filledContour} \alias{filledContour} \title{Filled contour plot} \description{ Filled contour plot of a RasterLayer. This is a wrapper around \code{\link[graphics]{filled.contour}} for RasterLayer objects. } \usage{ filledContour(x, y=1, maxpixels=100000, ...) } \arguments{ \item{x}{A Raster* object} \item{y}{Integer. The layer number of x (if x has multiple layers)} \item{maxpixels}{The maximum number of pixels} \item{...}{Any argument that can be passed to \code{\link[graphics]{filled.contour}} (graphics package)} } \seealso{ \code{\link[graphics]{filled.contour}}, \code{\link[raster]{persp}}, \code{\link[raster]{plot}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) filledContour(r) } \keyword{methods} \keyword{spatial} raster/man/getValuesFocal.Rd0000644000176200001440000000361514160021141015513 0ustar liggesusers \name{getValuesFocal} \alias{getValuesFocal} \alias{getValuesFocal,Raster-method} \alias{getValuesFocal,Raster,missing,missing,numeric-method} \alias{getValuesFocal,Raster,numeric,numeric,numeric-method} \title{Get focal raster cell values} \description{ This function returns a matrix (or matrices) for all focal values of a number of rows of a Raster* object} \usage{ \S4method{getValuesFocal}{Raster}(x, row, nrows, ngb, names=FALSE, padValue=NA, array=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{row}{Numeric. Row number, should be between 1 and nrow(x). Can be omitted to get all rows} \item{nrows}{Numeric. Number of rows, should be a positive integer smaller than \code{row+nrow(x)}. Should be omitted if \code{row} is omitted} \item{ngb}{Neighbourhood size. Either a single integer or a vector of two integers \code{c(nrow, ncol)}} \item{names}{logical. If \code{TRUE}, the matrix returned has row and column names} \item{padValue}{numeric. The value of the cells of the "padded" rows and columns. That is 'virtual' values for cells within a neighbourhood, but outside the raster} \item{array}{logical. If \code{TRUE} and \code{x} has multiple layers, an array is returned in stead of a list of matrices} \item{...}{additional arguments (none implemented)} } \value{ If \code{x} has a single layer, a matrix with one row for each focal cell, and one column for each neighbourhood cell around it. If \code{x} has multiple layers, an array (if \code{array=TRUE}) or a list of such matrices (one list element (matrix) for each layer) } \seealso{ \code{\link{getValues}, \link{focal}} } \examples{ r <- raster(nr=5, nc=5, crs='+proj=utm +zone=12') values(r) <- 1:25 as.matrix(r) getValuesFocal(r, row=1, nrows=2, ngb=3, names=TRUE) getValuesFocal(stack(r,r), row=1, nrows=1, ngb=3, names=TRUE, array=TRUE) } \keyword{spatial} \keyword{methods} raster/man/headtail.Rd0000644000176200001440000000171414160021141014360 0ustar liggesusers\name{head} \docType{methods} \alias{head} \alias{head,RasterLayer-method} \alias{head,RasterStackBrick-method} \alias{head,Spatial-method} \alias{tail} \alias{tail,RasterLayer-method} \alias{tail,RasterStackBrick-method} \alias{tail,Spatial-method} \title{Show the head or tail of a Raster* object} \description{ Show the head (first rows/columns) or tail (last rows/columns) of the cell values of a Raster* object. } \usage{ head(x, ...) tail(x, ...) } \arguments{ \item{x}{Raster* object} \item{...}{Additional arguments: \code{rows=10} and \code{cols=20}, to set the maximum number of rows and columns that are shown. For RasterStack and RasterBrick objects there is an additional argument \code{lyrs} } } \value{ matrix } \seealso{ \code{\link{getValuesBlock}} } \examples{ r <- raster(nrow=25, ncol=25) values(r) = 1:ncell(r) head(r) tail(r, cols=10, rows=5) } \keyword{methods} \keyword{spatial} raster/man/resample.Rd0000644000176200001440000000315514160021141014416 0ustar liggesusers\name{resample} \alias{resample} \alias{resample,Raster,Raster-method} \title{Resample a Raster object} \description{ Resample transfers values between non matching Raster* objects (in terms of origin and resolution). Use \code{\link[raster]{projectRaster}} if the target has a different coordinate reference system (projection). Before using resample, you may want to consider using these other functions instead: \code{\link[raster]{aggregate}}, \code{\link[raster]{disaggregate}}, \code{\link[raster]{crop}}, \code{\link[raster]{extend}}, \code{\link[raster]{merge}}. } \usage{ \S4method{resample}{Raster,Raster}(x, y, method="bilinear", filename="", ...) } \arguments{ \item{x}{Raster* object to be resampled} \item{y}{Raster* object with parameters that \code{x} should be resampled to} \item{method}{method used to compute values for the new RasterLayer, should be \code{"bilinear"} for bilinear interpolation, or \code{"ngb"} for using the nearest neighbor} \item{filename}{character. Output filename (optional) } \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick object } \author{Robert J. Hijmans and Joe Cheng} \seealso{ \code{\link[raster]{aggregate}}, \code{\link[raster]{disaggregate}}, \code{\link[raster]{crop}}, \code{\link[raster]{extend}}, \code{\link[raster]{merge}}, \code{\link[raster]{projectRaster}} } \examples{ r <- raster(nrow=3, ncol=3) values(r) <- 1:ncell(r) s <- raster(nrow=10, ncol=10) s <- resample(r, s, method='bilinear') #par(mfrow=c(1,2)) #plot(r) #plot(s) } \keyword{spatial} raster/man/modal.Rd0000644000176200001440000000251514160021141013701 0ustar liggesusers\name{modal} \alias{modal} \alias{modal,ANY-method} \alias{modal,Raster-method} \title{modal value} \description{ Compute the mode for a vector of numbers, or across raster layers. The mode, or modal value, is the most frequent value in a set of values. } \usage{ \S4method{modal}{ANY}(x, ..., ties='random', na.rm=FALSE, freq=FALSE) \S4method{modal}{Raster}(x, ..., ties='random', na.rm=FALSE, freq=FALSE) } \arguments{ \item{x}{vector of numbers (typically integers), characters, logicals, or factors, or a Raster* object} \item{...}{additional argument of the same type as \code{x}} \item{ties}{character. Indicates how to treat ties. Either 'random', 'lowest', 'highest', 'first', or 'NA'} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values are ignored. If \code{FALSE}, \code{NA} is returned if \code{x} has any \code{NA} values} \item{freq}{return the frequency of the modal value, instead of the modal value} } \value{ vector or RasterLayer. The vector has length 1 and is of the same type as \code{x}, except when \code{x} is a factor and additional arguments (values) are supplied, in which case the values are coerced to characters and a character value is returned. } \examples{ data <- c(0,1,2,3,3,3,3,4,4,4,5,5,6,7,7,8,9,NA) modal(data, na.rm=TRUE) } \keyword{univar} \keyword{math} raster/man/atan2.Rd0000644000176200001440000000136514160021141013614 0ustar liggesusers\name{atan2} \alias{atan2,Raster,Raster-method} \alias{atan2} \title{Two argument arc-tangent} \description{ For Raster* objects x and y, atan2(y, x) returns the angle in radians for the tangent y/x, handling the case when x is zero. See \code{\link[base]{Trig}} See \code{\link[raster]{Math-methods}} for other trigonometric and mathematical functions that can be used with Raster* objects. } \usage{ atan2(y, x) } \arguments{ \item{y}{Raster* object} \item{x}{Raster* object} } \seealso{ \code{\link[raster]{Math-methods}} } \examples{ r1 <- r2 <- raster(nrow=10, ncol=10) values(r1) <- (runif(ncell(r1))-0.5) * 10 values(r2) <- (runif(ncell(r1))-0.5) * 10 atan2(r1, r2) } \keyword{methods} \keyword{math} raster/man/as.matrix.Rd0000644000176200001440000000373014160021141014513 0ustar liggesusers\name{as.matrix} \alias{as.vector} \alias{as.matrix} \alias{as.array} \alias{as.array,RasterStackBrick-method} \alias{as.array,RasterLayer-method} \alias{as.matrix,RasterStackBrick-method} \alias{as.matrix,RasterLayer-method} \alias{as.matrix,Extent-method} \alias{as.vector,Extent-method} \alias{as.vector,Raster-method} \title{Get a vector, matrix, or array with raster cell values} \description{ \code{as.vector} returns a vector of cell values. For a RasterLayer it is equivalent to getValues(x). \code{as.matrix} returns all values of a Raster* object as a matrix. For RasterLayers, rows and columns in the matrix represent rows and columns in the RasterLayer object. For other Raster* objects, the matrix returned by \code{as.matrix} has columns for each layer and rows for each cell. \code{as.array} returns an array of matrices that are like those returned by \code{as.matrix} for a RasterLayer If there is insufficient memory to load all values, you can use \code{\link{getValues}} or \code{\link{getValuesBlock}} to read chunks of the file. \code{as.matrix} and \code{as.vector} can also be used to obtain the coordinates from an Extent object. } \usage{ as.matrix(x, ...) as.array(x, ...) \S4method{as.vector}{Extent}(x, mode='any') \S4method{as.vector}{Raster}(x, mode='any') } \arguments{ \item{x}{ Raster* or (for \code{as.matrix} and \code{as.vector}) Extent object } \item{mode}{Character string giving an atomic mode (such as "numeric" or "character") or "list", or "any". Note: this argument is currently ignored!} \item{...}{ additional arguments: \code{maxpixels} Integer. To regularly subsample very large objects \code{transpose} Logical. Transpose the data? (for as.array only) }} \value{ matrix, array, or vector } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.matrix(r) s <- stack(r,r) as.array(s) as.vector(extent(s)) } \keyword{spatial} \keyword{methods} raster/man/gridDistance.Rd0000644000176200001440000000371014160021141015203 0ustar liggesusers\name{gridDistance} \alias{gridDistance} \alias{gridDistance,RasterLayer-method} \title{Distance on a grid} \description{ The function calculates the distance to cells of a RasterLayer when the path has to go through the centers of neighboring raster cells (currently only implemented as a 'queen' case in which cells have 8 neighbors). The distance is in meters if the coordinate reference system (CRS) of the RasterLayer is longitude/latitude (\code{+proj=longlat}) and in the units of the CRS (typically meters) in other cases. Distances are computed by summing local distances between cells, which are connected with their neighbours in 8 directions. } \usage{ \S4method{gridDistance}{RasterLayer}(x, origin, omit=NULL, filename="", ...) } \arguments{ \item{x}{RasterLayer} \item{origin}{value(s) of the cells from which the distance is calculated} \item{omit}{value(s) of the cells which cannot be traversed (optional)} \item{filename}{character. output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \seealso{See \code{\link[raster]{distance}} for 'as the crow flies' distance. Additional distance measures and options (directions, cost-distance) are available in the '\code{gdistance}' package.} \details{ If the RasterLayer to be processed is big, it will be processed in chunks. This may lead to errors in the case of complex objects spread over different chunks (meandering rivers, for instance). You can try to solve these issues by varying the chunk size, see function setOptions(). } \value{RasterLayer} \author{Jacob van Etten and Robert J. Hijmans } \examples{ #world lon/lat raster r <- raster(ncol=10,nrow=10, vals=1) r[48] <- 2 r[66:68] <- 3 d <- gridDistance(r,origin=2,omit=3) plot(d) #UTM small area crs(r) <- "+proj=utm +zone=15 +ellps=GRS80 +datum=NAD83 +units=m +no_defs" d <- gridDistance(r,origin=2,omit=3) plot(d) } \keyword{spatial} raster/man/subs.Rd0000644000176200001440000000443314160021141013562 0ustar liggesusers\name{substitute} \docType{methods} \alias{subs} \alias{subs,Raster,data.frame-method} \title{ Substitute values in a Raster* object} \description{ Substitute (replace) values in a Raster* object with values in a \code{data.frame}. The \code{data.frame} should have a column to identify the key (ID) to match with the cell values of the Raster* object, and one or more columns with replacement values. By default these are the first and second column but you can specify other columns with arguments \code{by} and \code{which}. It is possible to match one table to multiple layers, or to use multiple layers as a single key, but not both. } \usage{ \S4method{subs}{Raster,data.frame}(x, y, by=1, which=2, subsWithNA=TRUE, filename='', ...) } \arguments{ \item{x}{Raster* object} \item{y}{data.frame} \item{by}{column number(s) or name(s) identifying the key (ID) to match rows in data.frame \code{y} to values of the Raster object} \item{which}{column number or name that has the new (replacement) values} \item{subsWithNA}{logical. If \code{TRUE} values that are not matched become NA. If \code{FALSE}, they retain their original value (which could also be \code{NA}). This latter option is handy when you want to replace only one or a few values. It cannot be used when \code{x} has multiple layers} \item{filename}{character. Optional output filename} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \details{ You could obtain the same result with \code{\link[raster]{reclassify}}, but \code{subs} is more efficient for simple replacement. Use \code{reclassify} if you want to replace ranges of values with new values. You can also replace values using a fitted model. E.g. fit a model to \code{glm} or \code{loess} and then call \link[raster]{predict} } \value{ Raster object } \seealso{ \code{\link{reclassify}, \link{clamp}, \link{cut}}} \examples{ r <- raster(ncol=10, nrow=10) values(r) <- round(runif(ncell(r)) * 10) df <- data.frame(id=2:8, v=c(10,10,11,11,12:14)) x <- subs(r, df) x2 <- subs(r, df, subsWithNA=FALSE) df$v2 <- df$v * 10 x3 <- subs(r, df, which=2:3) s <- stack(r, r*3) names(s) <- c('first', 'second') x4 <- subs(s, df) x5 <- subs(s, df, which=2:3) } \keyword{methods} \keyword{spatial} raster/man/interpolate.Rd0000644000176200001440000001177514160021141015143 0ustar liggesusers\name{interpolate} \docType{methods} \alias{interpolate} \alias{interpolate,Raster-method} \title{Interpolate} \description{ Make a RasterLayer with interpolated values using a fitted model object of classes such as 'gstat' (gstat package) or 'Krige' (fields package). That is, these are models that have location ('x' and 'y', or 'longitude' and 'latitude') as independent variables. If x and y are the only independent variables provide an empty (no associated data in memory or on file) RasterLayer for which you want predictions. If there are more spatial predictor variables provide these as a Raster* object in the first argument of the function. If you do not have x and y locations as implicit predictors in your model you should use \code{\link[raster]{predict}} instead. } \usage{ \S4method{interpolate}{Raster}(object, model, filename="", fun=predict, xyOnly=TRUE, xyNames=c('x', 'y'), ext=NULL, const=NULL, index=1, na.rm=TRUE, debug.level=1, ...) } \arguments{ \item{object}{Raster* object} \item{model}{model object} \item{filename}{character. Output filename (optional)} \item{fun}{function. Default value is 'predict', but can be replaced with e.g. 'predict.se' (depending on the class of the model object)} \item{xyOnly}{logical. If \code{TRUE}, values of the Raster* object are not considered as co-variables; and only x and y (longitude and latitude) are used. This should match the model} \item{xyNames}{character. variable names that the model uses for the spatial coordinates. E.g., \code{c('longitude', 'latitude')}} \item{ext}{Extent object to limit the prediction to a sub-region of \code{x}} \item{const}{data.frame. Can be used to add a constant for which there is no Raster object for model predictions. This is particulary useful if the constant is a character-like factor value} \item{index}{integer. To select the column if 'predict.model' returns a matrix with multiple columns} \item{na.rm}{logical. Remove cells with NA values in the predictors before solving the model (and return \code{NA} for those cells). In most cases this will not affect the output. This option prevents errors with models that cannot handle \code{NA} values} \item{debug.level}{for gstat models only. See ?} \item{...}{additional arguments passed to the predict.'model' function} } \value{ Raster* object } \seealso{ \code{\link[raster]{predict}}, \code{\link[gstat]{predict.gstat}}, \code{\link[fields]{Tps}} } \examples{ \donttest{ ## Thin plate spline interpolation with x and y only # some example data r <- raster(system.file("external/test.grd", package="raster")) ra <- aggregate(r, 10) xy <- data.frame(xyFromCell(ra, 1:ncell(ra))) v <- getValues(ra) # remove NAs i <- !is.na(v) xy <- xy[i,] v <- v[i] #### Thin plate spline model library(fields) tps <- Tps(xy, v) p <- raster(r) # use model to predict values at all locations p <- interpolate(p, tps) p <- mask(p, r) plot(p) ## change the fun from predict to fields::predictSE to get the TPS standard error se <- interpolate(p, tps, fun=predictSE) se <- mask(se, r) plot(se) ## another variable; let's call it elevation elevation <- (init(r, 'x') * init(r, 'y')) / 100000000 names(elevation) <- 'elev' z <- extract(elevation, xy) # add as another independent variable xyz <- cbind(xy, z) tps2 <- Tps(xyz, v) p2 <- interpolate(elevation, tps2, xyOnly=FALSE) # as a linear coveriate tps3 <- Tps(xy, v, Z=z) # Z is a separate argument in Krig.predict, so we need a new function # Internally (in interpolate) a matrix is formed of x, y, and elev (Z) pfun <- function(model, x, ...) { predict(model, x[,1:2], Z=x[,3], ...) } p3 <- interpolate(elevation, tps3, xyOnly=FALSE, fun=pfun) #### gstat examples library(gstat) data(meuse) ## inverse distance weighted (IDW) r <- raster(system.file("external/test.grd", package="raster")) data(meuse) mg <- gstat(id = "zinc", formula = zinc~1, locations = ~x+y, data=meuse, nmax=7, set=list(idp = .5)) z <- interpolate(r, mg) z <- mask(z, r) ## kriging coordinates(meuse) <- ~x+y crs(meuse) <- crs(r) ## ordinary kriging v <- variogram(log(zinc)~1, meuse) m <- fit.variogram(v, vgm(1, "Sph", 300, 1)) gOK <- gstat(NULL, "log.zinc", log(zinc)~1, meuse, model=m) OK <- interpolate(r, gOK) # examples below provided by Maurizio Marchi ## universial kriging vu <- variogram(log(zinc)~elev, meuse) mu <- fit.variogram(vu, vgm(1, "Sph", 300, 1)) gUK <- gstat(NULL, "log.zinc", log(zinc)~elev, meuse, model=mu) names(r) <- 'elev' UK <- interpolate(r, gUK, xyOnly=FALSE) ## co-kriging gCoK <- gstat(NULL, 'log.zinc', log(zinc)~1, meuse) gCoK <- gstat(gCoK, 'elev', elev~1, meuse) gCoK <- gstat(gCoK, 'cadmium', cadmium~1, meuse) gCoK <- gstat(gCoK, 'copper', copper~1, meuse) coV <- variogram(gCoK) plot(coV, type='b', main='Co-variogram') coV.fit <- fit.lmc(coV, gCoK, vgm(model='Sph', range=1000)) coV.fit plot(coV, coV.fit, main='Fitted Co-variogram') coK <- interpolate(r, coV.fit) plot(coK) } } \keyword{methods} \keyword{spatial} raster/man/as.data.frame.Rd0000644000176200001440000000525514160021141015215 0ustar liggesusers\name{as.data.frame} \alias{as.data.frame} \alias{as.data.frame,Raster-method} \alias{as.data.frame,SpatialPolygons-method} \alias{as.data.frame,SpatialLines-method} \title{Get a data.frame with raster cell values, or coerce SpatialPolygons, Lines, or Points to a data.frame} \description{ \code{as.matrix} returns all values of a Raster* object as a matrix. For RasterLayers, rows and columns in the matrix represent rows and columns in the RasterLayer object. For other Raster* objects, the matrix returned by \code{as.matrix} has columns for each layer and rows for each cell. \code{as.array} returns an array of matrices that are like those returned by \code{as.matrix} for a RasterLayer If there is insufficient memory to load all values, you can use \code{\link{getValues}} or \code{\link{getValuesBlock}} to read chunks of the file. You could also first use \code{\link{sampleRegular}} The methods for Spatial* objects allow for easy creation of a data.frame with the coordinates and attributes; the default method only returns the attributes data.frame } \usage{ \S4method{as.data.frame}{Raster}(x, row.names=NULL, optional=FALSE, xy=FALSE, na.rm=FALSE, long=FALSE, ...) \S4method{as.data.frame}{SpatialPolygons}(x, row.names=NULL, optional=FALSE, xy=FALSE, centroids=TRUE, sepNA=FALSE, ...) \S4method{as.data.frame}{SpatialLines}(x, row.names=NULL, optional=FALSE, xy=FALSE, sepNA=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{row.names}{\code{NULL} or a character vector giving the row names for the data frame. Missing values are not allowed} \item{optional}{logical. If \code{TRUE}, setting row names and converting column names (to syntactic names: see make.names) is optional} \item{xy}{logical. If \code{TRUE}, also return the spatial coordinates} \item{na.rm}{logical. If \code{TRUE}, remove rows with NA values. This can be particularly useful for very large datasets with many NA values} \item{long}{logical. If \code{TRUE}, values are \code{\link{reshape}d} from a wide to a long format} \item{centroids}{logical. If \code{TRUE} return the centroids instead of all spatial coordinates (only relevant if \code{xy=TRUE})} \item{sepNA}{logical. If \code{TRUE} the parts of the spatial objects are separated by lines that are \code{NA} (only if \code{xy=TRUE} and, for polygons, if \code{centroids=FALSE}} \item{...}{Additional arguments (none)} } \value{ data.frame } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- sqrt(1:ncell(r)) r[3:5] <- NA as.data.frame(r) s <- stack(r, r*2) as.data.frame(s) as.data.frame(s, na.rm=TRUE) } \keyword{spatial} \keyword{methods} raster/man/properties.Rd0000644000176200001440000000125714160021141015003 0ustar liggesusers\name{properties} \alias{dataSize} \alias{dataSigned} \title{Raster file properties} \description{ Properties of the values of the file that a RasterLayer object points to \code{dataSize} returns the number of bytes used for each value (pixel, grid cell) \code{dataSigned} is TRUE for data types that include negative numbers. } \usage{ dataSize(object) dataSigned(object) } \arguments{ \item{object}{Raster* object} } \seealso{ \code{\link[raster]{filename}} } \value{ varies } \examples{ r <- raster(system.file("external/test.grd", package="raster")) dataSize(r) dataSigned(r) dataType(r) } \keyword{spatial} raster/man/plot.Rd0000644000176200001440000001435014160021141013563 0ustar liggesusers\name{plot} \docType{methods} \alias{plot} \alias{plot,Raster,ANY-method} \alias{plot,Raster,Raster-method} \alias{plot,Extent,missing-method} \alias{lines,RasterLayer-method} \alias{lines,Extent-method} \title{Plot a Raster* object} \description{ Plot (that is, make a map of) the values of a Raster* object, or make a scatterplot of their values. Points, lines, and polygons can be drawn on top of a map using \code{plot(..., add=TRUE)}, or with functions like \code{points, lines, polygons} See the \code{rasterVis} package for more advanced (trellis/lattice) plotting of Raster* objects. } \usage{ \S4method{plot}{Raster,ANY}(x, y, maxpixels=500000, col, alpha=NULL, colNA=NA, add=FALSE, ext=NULL, useRaster=TRUE, interpolate=FALSE, addfun=NULL, nc, nr, maxnl=16, main, npretty=0, ...) \S4method{plot}{Raster,Raster}(x, y, maxpixels=100000, cex, xlab, ylab, nc, nr, maxnl=16, main, add=FALSE, gridded=FALSE, ncol=25, nrow=25, ...) } \arguments{ \item{x}{Raster* object} \item{y}{If \code{x} is a RasterStack or RasterBrick: integer, character (layer name(s)), or missing to select which layer(s) to plot. If missing, all RasterLayers in the RasterStack will be plotted (up to a maximum of 16). Or another Raster* object of the same extent and resolution, to produce a scatter plot of the cell values. } \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting. If \code{gridded=TRUE} maxpixels may be ignored to get a larger sample} \item{col}{A color palette, i.e. a vector of n contiguous colors generated by functions like \link{rainbow}, \link{heat.colors}, \link{topo.colors}, \link[sp]{bpy.colors} or one or your own making, perhaps using \code{\link{colorRampPalette}}. If none is provided, \code{rev(terrain.colors(255))} is used unless \code{x} has a 'color table'} \item{alpha}{Number between 0 and 1 to set transparency. 0 is entirely transparent, 1 is not transparent (NULL is equivalent to 1)} \item{colNA}{The color to use for the background (default is transparent)} \item{add}{Logical. Add to current plot?} \item{ext}{An extent object to zoom in a region (see also \code{\link{zoom}} and \code{\link{crop}(x, \link{drawExtent}())}} \item{useRaster}{If \code{TRUE}, the rasterImage function is used for plotting. Otherwise the image function is used. This can be useful if rasterImage does not work well on your system (see note)} \item{interpolate}{Logical. Should the image be interpolated (smoothed)? Only used when \code{useRaster = TRUE}} \item{addfun}{Function to add additional items such as points or polygons to the plot (map). Typically containing statements like "points(xy); plot(polygons, add=TRUE)". This is particularly useful to add something to each map when plotting a multi-layer Raster* object.} \item{npretty}{integer. Number of decimals for \link{pretty} lables on the axes} \item{...}{Graphical parameters. Any argument that can be passed to \code{\link[fields]{image.plot}} and to base \code{plot}, such as axes=FALSE, main='title', ylab='latitude'} \item{xlab}{Optional. x-axis label)} \item{ylab}{Optional. y-axis label)} \item{nc}{Optional. The number of columns to divide the plotting device in (when plotting multiple layers in a RasterLayer or RasterBrick object)} \item{nr}{Optional. The number of rows to divide the plotting device in (when plotting multiple layers in a RasterLayer or RasterBrick object)} \item{maxnl}{integer. Maximum number of layers to plot (for a multi-layer object)} \item{main}{character. Main plot title} \item{cex}{Symbol size for scatter plots} \item{gridded}{logical. If \code{TRUE} the scatterplot is gridded (counts by cells)} \item{ncol}{integer. Number of columns for gridding} \item{nrow}{integer. Number of rows for gridding} } \details{ Most of the code for the plot function for a single Raster* object was taken from image.plot (fields package). Raster objects with a color-table (e.g. a graphics file) are plotted according to that color table. } \note{ raster uses \code{\link[graphics]{rasterImage}} from the graphics package. For unknown reasons this does not work on Windows Server and on a few versions of Windows XP. On that system you may need to use argument \code{useRaster=FALSE} to get a plot. } \seealso{ The \code{rasterVis} package has lattice based methods for plotting Raster* objects (like \code{\link[raster]{spplot}}) red-green-blue plots (e.g. false color composites) can be made with \code{\link[raster]{plotRGB}} \code{\link[raster]{barplot}}, \code{\link[raster]{hist}}, \code{\link[raster]{text}}, \code{\link[raster]{persp}}, \code{\link[raster]{contour}}, \code{\link[raster]{pairs}} } \examples{ # RasterLayer r <- raster(nrows=10, ncols=10) r <- setValues(r, 1:ncell(r)) plot(r) e <- extent(r) plot(e, add=TRUE, col='red', lwd=4) e <- e / 2 plot(e, add=TRUE, col='red') # Scatterplot of 2 RasterLayers r2 <- sqrt(r) plot(r, r2) plot(r, r2, gridded=TRUE) # Multi-layer object (RasterStack / Brick) s <- stack(r, r2, r/r) plot(s, 2) plot(s) # two objects, different range, one scale: values(r) <- runif(ncell(r)) r2 <- r/2 brks <- seq(0, 1, by=0.1) nb <- length(brks)-1 cols <- rev(terrain.colors(nb)) par(mfrow=c(1,2)) plot(r, breaks=brks, col=cols, lab.breaks=brks, zlim=c(0,1), main='first') plot(r2, breaks=brks, col=cols, lab.breaks=brks, zlim=c(0,1), main='second') # breaks and labels x <- raster(nc=10, nr=10) values(x) <- runif(ncell(x)) brk <- c(0, 0.25, 0.75, 1) arg <- list(at=c(0.12,0.5,0.87), labels=c("Low","Med.","High")) plot(x, col=terrain.colors(3), breaks=brk) plot(x, col=terrain.colors(3), breaks=brk, axis.args=arg) par(mfrow=c(1,1)) # color ramp plot(x, col=colorRampPalette(c("red", "white", "blue"))(255)) # adding random points to the map xy <- cbind(-180 + runif(10) * 360, -90 + runif(10) * 180) points(xy, pch=3, cex=5) # for SpatialPolygons do # plot(pols, add=TRUE) # adding the same points to each map of each layer of a RasterStack fun <- function() { points(xy, cex=2) points(xy, pch=3, col='red') } plot(s, addfun=fun) } \keyword{methods} \keyword{spatial} raster/man/terrain.Rd0000644000176200001440000001163114160021141014250 0ustar liggesusers\name{terrain} \alias{terrain} \alias{terrain,RasterLayer-method} \title{Terrain characteristics} \description{ Compute slope, aspect and other terrain characteristics from a raster with elevation data. The elevation data should be in map units (typically meter) for projected (planar) raster data. They should be in meters when the coordinate reference system (CRS) is longitude/latitude. } \usage{ \S4method{terrain}{RasterLayer}(x, opt="slope", unit="radians", neighbors=8, filename="", ...) } \arguments{ \item{x}{RasterLayer object with elevation values. Values should have the same unit as the map units, or in meters when the crs is longitude/latitude} \item{opt}{Character vector containing one or more of these options: slope, aspect, TPI, TRI, roughness, flowdir (see Details)} \item{unit}{Character. 'degrees', 'radians' or 'tangent'. Only relevant for slope and aspect. If 'tangent' is selected that is used for slope, but for aspect 'degrees' is used (as 'tangent' has no meaning for aspect) } \item{neighbors}{Integer. Indicating how many neighboring cells to use to compute slope for any cell. Either 8 (queen case) or 4 (rook case). Only used for slope and aspect, see Details} \item{filename}{Character. Output filename (optional)} \item{...}{Standard additional arguments for writing Raster* objects to file} } \details{ When \code{neighbors=4}, slope and aspect are computed according to Fleming and Hoffer (1979) and Ritter (1987). When \code{neigbors=8}, slope and aspect are computed according to Horn (1981). The Horn algorithm may be best for rough surfaces, and the Fleming and Hoffer algorithm may be better for smoother surfaces (Jones, 1997; Burrough and McDonnell, 1998). If slope = 0, aspect is set to 0.5*pi radians (or 90 degrees if unit='degrees'). When computing slope or aspect, the CRS (\code{\link{projection}}) of the RasterLayer \code{x} must be known (may not be \code{NA}), to be able to safely differentiate between planar and longitude/latitude data. flowdir returns the 'flow direction' (of water), i.e. the direction of the greatest drop in elevation (or the smallest rise if all neighbors are higher). They are encoded as powers of 2 (0 to 7). The cell to the right of the focal cell 'x' is 1, the one below that is 2, and so on: \tabular{rrr}{ 32 \tab64 \tab 128\cr 16 \tab x \tab 1 \cr 8 \tab 4 \tab 2 \cr } If two cells have the same drop in elevation, a random cell is picked. That is not ideal as it may prevent the creation of connected flow networks. ArcGIS implements the approach of Greenlee (1987) and I might adopt that in the future. The terrain indices are according to Wilson et al. (2007). TRI (Terrain Ruggedness Index) is the mean of the absolute differences between the value of a cell and the value of its 8 surrounding cells. TPI (Topographic Position Index) is the difference between the value of a cell and the mean value of its 8 surrounding cells. Roughness is the difference between the maximum and the minimum value of a cell and its 8 surrounding cells. Such measures can also be computed with the \code{\link{focal}} function: f <- matrix(1, nrow=3, ncol=3) TRI <- focal(x, w=f, fun=function(x, ...) sum(abs(x[-5]-x[5]))/8, pad=TRUE, padValue=NA) TPI <- focal(x, w=f, fun=function(x, ...) x[5] - mean(x[-5]), pad=TRUE, padValue=NA) rough <- focal(x, w=f, fun=function(x, ...) {max(x) - min(x)}, pad=TRUE, padValue=NA, na.rm=TRUE) } \seealso{ \code{\link{hillShade}} } \references{ Burrough, P., and R.A. McDonnell, 1998. Principles of Geographical Information Systems. Oxford University Press. Fleming, M.D. and Hoffer, R.M., 1979. Machine processing of landsat MSS data and DMA topographic data for forest cover type mapping. LARS Technical Report 062879. Laboratory for Applications of Remote Sensing, Purdue University, West Lafayette, Indiana. Greenlee, D.D., 1987. Raster and vector processing for scanned linework. Photogrammetric Engineering and Remote Sensing 53:1383-1387 Horn, B.K.P., 1981. Hill shading and the reflectance map. Proceedings of the IEEE 69:14-47 Jones, K.H., 1998. A comparison of algorithms used to compute hill slope as a property of the DEM. Computers & Geosciences 24: 315-323 Ritter, P., 1987. A vector-based slope and aspect generation algorithm. Photogrammetric Engineering and Remote Sensing 53: 1109-1111 Wilson, M.F.J., O'Connell, B., Brown, C., Guinan, J.C., Grehan, A.J., 2007. Multiscale terrain analysis of multibeam bathymetry data for habitat mapping on the continental slope. Marine Geodesy 30: 3-35. } \examples{ \dontrun{ elevation <- getData('alt', country='CHE') x <- terrain(elevation, opt=c('slope', 'aspect'), unit='degrees') plot(x) # TPI for different neighborhood size: tpiw <- function(x, w=5) { m <- matrix(1/(w^2-1), nc=w, nr=w) m[ceiling(0.5 * length(m))] <- 0 f <- focal(x, m) x - f } tpi5 <- tpiw(elevation, w=5) } } \keyword{spatial} raster/man/saveStack.Rd0000644000176200001440000000254214160021141014531 0ustar liggesusers\name{stackSave} \alias{stackSave} \alias{stackOpen} \title{Save or open a RasterStack file} \description{ A RasterStack is a collection of RasterLayers with the same spatial extent and resolution. They can be created from RasterLayer objects, or from file names. These two functions allow you to save the references to raster files and recreate a rasterStack object later. They only work if the RasterStack points to layers that have their values on disk. The values are not saved, only the references to the files. } \usage{ stackOpen(stackfile) stackSave(x, filename) } \arguments{ \item{stackfile}{ Filename for the RasterStack (to save it on disk) } \item{x}{ RasterStack object } \item{filename}{File name } } \details{ When a RasterStack is saved to a file, only pointers (filenames) to raster datasets are saved, not the data. If the name or location of a raster file changes, the RasterStack becomes invalid. } \value{ RasterStack object } \seealso{ \code{\link[raster]{writeRaster}}, \code{\link[raster]{stack}}, \code{\link[raster]{addLayer}}} \examples{ file <- system.file("external/test.grd", package="raster") s <- stack(c(file, file)) \dontrun{ s <- stackSave(s, "mystack") # note that filename adds an extension .stk to a stackfile s2 <- stackOpen("mystack.stk") s2 } } \keyword{ spatial } raster/man/clamp.Rd0000644000176200001440000000213014160021141013672 0ustar liggesusers\name{clamp} \alias{clamp} \alias{clamp,Raster-method} \alias{clamp,numeric-method} \title{Clamp values} \description{ Clamp values to a minimum and maximum value. That is, all values below the lower clamp value and above the upper clamp value become NA (or the lower/upper value if \code{useValue=TRUE}) } \usage{ \S4method{clamp}{Raster}(x, lower=-Inf, upper=Inf, useValues=TRUE, filename="", ...) \S4method{clamp}{numeric}(x, lower=-Inf, upper=Inf, ...) } \arguments{ \item{x}{RasterLayer, or numeric vector} \item{lower}{numeric. lowest value} \item{upper}{numeric. highest value} \item{useValues}{logical. If \code{FALSE} values outside the clamping range become \code{NA}, if \code{TRUE}, they get the extreme values} \item{filename}{character. Filename for the output RasterLayer (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ Raster object } \seealso{ \code{\link{reclassify}} } \examples{ r <- raster(ncols=12, nrows=12) values(r) <- 1:ncell(r) rc <- clamp(r, 25, 75) rc } \keyword{spatial} raster/man/density.Rd0000644000176200001440000000164314160021141014265 0ustar liggesusers\name{density} \alias{density} \alias{density,Raster-method} \docType{methods} \title{Density plot} \description{ Create density plots of values in a Raster object } \usage{ \S4method{density}{Raster}(x, layer, maxpixels=100000, plot=TRUE, main, ...) } \arguments{ \item{x}{Raster object} \item{layer}{numeric. Can be used to subset the layers to plot in a multilayer object (RasterBrick or RasterStack)} \item{maxpixels}{the maximum number of (randomly sampled) cells to be used for creating the plot} \item{plot}{if \code{TRUE} produce a plot, else return a density object} \item{main}{main title for each plot (can be missing)} \item{...}{Additional arguments passed to base plot} } \value{ density plot (and a density object, returned invisibly if \code{plot=TRUE)} } \examples{ logo <- stack(system.file("external/rlogo.grd", package="raster")) density(logo) } \keyword{spatial} raster/man/getValuesBlock.Rd0000644000176200001440000000406414160021141015520 0ustar liggesusers\name{getValuesBlock} \alias{getValuesBlock} \alias{getValuesBlock,RasterLayer-method} \alias{getValuesBlock,RasterLayerSparse-method} \alias{getValuesBlock,RasterStack-method} \alias{getValuesBlock,RasterBrick-method} \title{Get a block of raster cell values} \description{ getValuesBlock returns values for a block (rectangular area) of values of a Raster* object. } \usage{ \S4method{getValuesBlock}{RasterLayer}(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), format='', ...) \S4method{getValuesBlock}{RasterBrick}(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) \S4method{getValuesBlock}{RasterStack}(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) } \arguments{ \item{x}{Raster* object} \item{row}{positive integer. Row number to start from, should be between 1 and nrow(x)} \item{nrows}{positive integer. How many rows? Default is 1} \item{col}{positive integer. Column number to start from, should be between 1 and ncol(x)} \item{ncols}{positive integer. How many columns? Default is the number of columns left after the start column} \item{format}{character. When \code{x} is a \code{RasterLayer}, if \code{format='matrix'} or \code{format='m'}, a matrix is returned instead of a vector. If \code{format='matrix'}, it is a nrow x ncol matrix. If \code{format='m'} it is a 1 column matrix (the benefit is that the type of output is now the same for all Raster objects)} \item{lyrs}{integer (vector). Which layers? Default is all layers (\code{1:nlayers(x)})} \item{...}{additional arguments (none implemented)} } \value{ matrix or vector (if \code{(x=RasterLayer)}, unless \code{format='matrix'}) } \seealso{ \code{\link{getValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) b <- getValuesBlock(r, row=100, nrows=3, col=10, ncols=5) b b <- matrix(b, nrow=3, ncol=5, byrow=TRUE) b logo <- brick(system.file("external/rlogo.grd", package="raster")) getValuesBlock(logo, row=35, nrows=3, col=50, ncols=3, lyrs=2:3) } \keyword{spatial} \keyword{methods} raster/man/as.logical-methods.Rd0000644000176200001440000000165114160021141016262 0ustar liggesusers\name{as.logical} \docType{methods} \alias{as.logical,Raster-method} \alias{as.integer,Raster-method} \title{ Change cell values to logical or integer values} \description{ Change values of a Raster* object to logical or integer values. With \code{as.logical}, zero becomes \code{FALSE}, all other values become \code{TRUE}. With \code{as.integer} values are truncated. } \usage{ \S4method{as.logical}{Raster}(x, filename='', ...) \S4method{as.integer}{Raster}(x, filename='', ...) } \arguments{ \item{x}{Raster* object} \item{filename}{character. Output filename (optional)} \item{...}{additional optional arguments as for \code{\link{writeRaster}}} } \seealso{ \code{\link[base]{logical}}, \code{\link[base]{integer}} } \examples{ r <- raster(nrow=10, ncol=10) set.seed(0) values(r) <- runif(ncell(r)) * 10 r r <- as.integer(r) r as.logical(r) } \keyword{methods} \keyword{spatial} raster/man/slopeAspect.Rd0000644000176200001440000000106214160021141015063 0ustar liggesusers\name{Slope and aspect} \alias{slopeAspect} \title{Slope and aspect} \description{ DEPRACATED. Use \code{\link{terrain}} instead. } \usage{ slopeAspect(dem, filename='', out=c('slope', 'aspect'), unit='radians', neighbors=8, flatAspect, ...) } \arguments{ \item{dem}{DEPRACATED} \item{filename}{DEPRACATED} \item{out}{DEPRACATED} \item{unit}{DEPRACATED} \item{neighbors}{DEPRACATED} \item{flatAspect}{DEPRACATED} \item{...}{DEPRACATED} } \seealso{ \code{\link{terrain}} } \keyword{spatial} raster/man/spplot.Rd0000644000176200001440000000431414160021141014125 0ustar liggesusers\name{spplot} \docType{methods} \alias{spplot} \alias{spplot,Raster-method} \alias{spplot,SpatRaster-method} \alias{spplot,SpatialPoints-method} \alias{spplot,SpatialLines-method} \alias{spplot,SpatialPolygons-method} \alias{lines,SpatialPolygons-method} \alias{spplot,SpatVector-method} \title{Use spplot to plot a Raster* or other object} \description{ A wrapper function around \link[sp]{spplot} (sp package). With spplot it is easy to map several layers with a single legend for all maps. ssplot is itself a wrapper around the \link[lattice]{levelplot} function in the lattice package, and see the help for these functions for additional options. One of the advantages of the wrapper function for Raster* objects is the additional \code{maxpixels} argument to sample large objects for faster drawing. There are also added spplot methods for Spatial objects that have no data.frame and for SpatVector (terra package) } \usage{ \S4method{spplot}{Raster}(obj, ..., maxpixels=50000, as.table=TRUE, zlim) } \arguments{ \item{obj}{Raster* object} \item{...}{Any argument that can be passed to \code{\link[sp]{spplot}} and \link[lattice]{levelplot}} \item{maxpixels}{integer. Number of pixels to sample from each layer of large Raster objects} \item{as.table}{If \code{TRUE}, the plots are ordered from top to bottom} \item{zlim}{Vector of two elements indicating the minimum and maximum values to be mapped (values outside that ranage are set to these limits)} } \seealso{ \code{ \link[raster]{plot}, \link[raster]{plotRGB} } The rasterVis package has more advanced plotting methods for Raster objects } \examples{ r <- raster(system.file("external/test.grd", package="raster")) s <- stack(r, r*2) names(s) <- c('meuse', 'meuse x 2') spplot(s) pts <- data.frame(sampleRandom(r, 10, xy=TRUE)) coordinates(pts) <- ~ x + y spplot(s, scales = list(draw = TRUE), xlab = "easting", ylab = "northing", col.regions = rainbow(99, start=.1), names.attr=c('original', 'times two'), sp.layout = list("sp.points", pts, pch=20, cex=2, col='black'), par.settings = list(fontsize = list(text = 12)), at = seq(0, 4000, 500)) } \keyword{methods} \keyword{spatial} raster/man/unique.Rd0000644000176200001440000000236314160021141014114 0ustar liggesusers\name{unique} \docType{methods} \alias{unique} \alias{unique,RasterLayer,missing-method} \alias{unique,RasterStackBrick,missing-method} \title{Unique values} \description{ This function returns the unique values in a RasterLayer object or the unique combinations of the layers in a multilayer object. } \usage{ \S4method{unique}{RasterLayer,missing}(x, incomparables=FALSE, na.last=NA, progress="", ...) \S4method{unique}{RasterStackBrick,missing}(x, incomparables=FALSE, na.last=NA, progress="", ...) } \arguments{ \item{x}{Raster object} \item{incomparables}{must be missing. The default value \code{FALSE} is used. See \code{\link[base]{unique}}} \item{na.last}{logical. for controlling the treatment of \code{NA}s. If \code{TRUE}, missing values in the data are put last; if \code{FALSE}, they are put first; if \code{NA}, they are removed.} \item{progress}{character. Use "text" or "window" for a progress indicator} \item{...}{additional arguments. as in \code{\link[base]{unique}}} } \seealso{ \code{\link[base]{unique}} } \value{ vector or matrix } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- round(runif(ncell(r))*10) unique(r) unique(stack(r, round(r/2))) } \keyword{spatial} raster/man/as.character.Rd0000644000176200001440000000165714160021141015151 0ustar liggesusers\name{as.character} \alias{as.character} \alias{as.character,Raster-method} \alias{as.character,Extent-method} \title{Character representation of a Raster or Extent object} \description{ \code{as.character} returns a text (R code) representation of a Raster* or Extent object. The main purpose of this is to allow quick generation of objects to use in examples on, for example, stackoverflow.com. } \usage{ \S4method{as.character}{Raster}(x, ...) \S4method{as.character}{Extent}(x, ...) } \arguments{ \item{x}{ Raster* or Extent object } \item{...}{ additional arguments, none implemented } } \value{ character } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.character(r) s <- stack(r, r) as.character(s) as.character(extent(s)) x <- as.character(s) eval(parse(text=x)) y <- as.character(extent(s)) eval(parse(text=y)) } \keyword{spatial} \keyword{methods} raster/man/compare.Rd0000644000176200001440000000407214160021141014233 0ustar liggesusers\name{compareRaster} \alias{compareRaster} \alias{all.equal,Raster,Raster-method} \title{Compare Raster objects} \description{ Evaluate whether a two or more Raster* objects have the same extent, number of rows and columns, projection, resolution, and origin (or a subset of these comparisons). all.equal is a wrapper around compareRaster with options \code{values=TRUE}, \code{stopiffalse=FALSE} and \code{showwarning=TRUE}. } \usage{ compareRaster(x, ..., extent=TRUE, rowcol=TRUE, crs=TRUE, res=FALSE, orig=FALSE, rotation=TRUE, values=FALSE, tolerance, stopiffalse=TRUE, showwarning=FALSE) } \arguments{ \item{x}{Raster* object } \item{...}{Raster* objects} \item{extent}{logical. If \code{TRUE}, bounding boxes are compared} \item{rowcol}{logical. If \code{TRUE}, number of rows and columns of the objects are compared} \item{crs}{logical. If \code{TRUE}, coordinate reference systems are compared.} \item{res}{logical. If \code{TRUE}, resolutions are compared (redundant when checking extent and rowcol)} \item{orig}{logical. If \code{TRUE}, origins are compared} \item{rotation}{logical. If \code{TRUE}, rotations are compared} \item{values}{logical. If \code{TRUE}, cell values are compared} \item{tolerance}{numeric between 0 and 0.5. If not supplied, the default value is used (see \code{\link{rasterOptions}}. It sets difference (relative to the cell resolution) that is permissible for objects to be considered 'equal', if they have a non-integer origin or resolution. See \link{all.equal}. } \item{stopiffalse}{logical. If \code{TRUE}, an error will occur if the objects are not the same} \item{showwarning}{logical. If \code{TRUE}, an warning will be given if objects are not the same. Only relevant when \code{stopiffalse} is \code{TRUE}} } \examples{ r1 <- raster() r2 <- r1 r3 <- r1 compareRaster(r1, r2, r3) nrow(r3) <- 10 # compareRaster(r1, r3) compareRaster(r1, r3, stopiffalse=FALSE) compareRaster(r1, r3, rowcol=FALSE) all.equal(r1, r2) all.equal(r1, r3) } \keyword{ spatial } raster/man/readAll.Rd0000644000176200001440000000157714160021141014160 0ustar liggesusers\name{readAll} \alias{readAll,RasterLayer-method} \alias{readAll,RasterStack-method} \alias{readAll,RasterBrick-method} \alias{readAll} \title{Read values from disk} \description{ Read all values from a raster file associated with a Raster* object into memory. This function should normally not be used. In most cases \code{\link[raster]{getValues}} or \code{\link[raster]{getValuesBlock}} is more appropriate as \code{readAll} will fail when there is no file associated with the RasterLayer (values may only exist in memory). } \usage{ readAll(object) } \arguments{ \item{object}{a Raster* object} } \seealso{ \code{\link[raster]{getValues}}, \code{\link[raster]{getValuesBlock}}, \code{\link[raster]{extract}}} \examples{ r <- raster(system.file("external/test.grd", package="raster")) r <- readAll(r) } \keyword{classes} \keyword{spatial} raster/man/pairs.Rd0000644000176200001440000000224114160021141013717 0ustar liggesusers\name{pairs} \docType{methods} \alias{pairs} \alias{pairs,RasterStackBrick-method} \title{ Pairs plot (matrix of scatterplots) } \description{ Pair plots of layers in a RasterStack or RasterBrick. This is a wrapper around graphics function \code{\link[graphics]{pairs}}. } \usage{ \S4method{pairs}{RasterStackBrick}(x, hist=TRUE, cor=TRUE, use="pairwise.complete.obs", maxpixels=100000, ...) } \arguments{ \item{x}{RasterBrick or RasterStack} \item{hist}{Logical. If TRUE a histogram of the values is shown on the diagonal} \item{cor}{Logical. If TRUE the correlation coefficient is shown in the upper panels} \item{use}{Argument passed to the \code{\link[stats]{cor}} function} \item{maxpixels}{Integer. Number of pixels to sample from each layer of large Raster objects} \item{...}{Additional arguments (only \code{cex} and \code{main})} } \seealso{ \code{\link{boxplot}, \link{hist}, \link{density}} } \examples{ r <- raster(system.file("external/test.grd", package="raster") ) s <- stack(r, 1/r, sqrt(r)) pairs(s) \dontrun{ # to make indvidual histograms: hist(r) # or scatter plots: plot(r, 1/r) } } \keyword{spatial} raster/man/click.Rd0000644000176200001440000000473714160021141013702 0ustar liggesusers\name{click} \alias{click} \alias{click,Raster-method} \alias{click,SpatialGrid-method} \alias{click,SpatialPixels-method} \alias{click,missing-method} \alias{click,SpatialPolygons-method} \alias{click,SpatialLines-method} \alias{click,SpatialPoints-method} \title{Query by clicking on a map} \description{ Click on a map (plot) to get values of a Raster* or Spatial* object at that location; and optionally the coordinates and cell number of the location. For SpatialLines and SpatialPoints you need to click twice (draw a box). } \usage{ \S4method{click}{Raster}(x, n=Inf, id=FALSE, xy=FALSE, cell=FALSE, type="n", show=TRUE, ...) \S4method{click}{SpatialGrid}(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) \S4method{click}{SpatialPolygons}(x, n=1, id=FALSE, xy=FALSE, type="n", ...) \S4method{click}{SpatialLines}(x, ...) \S4method{click}{SpatialPoints}(x, ...) } \arguments{ \item{x}{Raster*, or Spatial* object (or missing)} \item{n}{number of clicks on the map} \item{id}{Logical. If \code{TRUE}, a numeric ID is shown on the map that corresponds to the row number of the output} \item{xy}{Logical. If \code{TRUE}, xy coordinates are included in the output} \item{cell}{Logical. If \code{TRUE}, cell numbers are included in the output} \item{type}{One of "n", "p", "l" or "o". If "p" or "o" the points are plotted; if "l" or "o" they are joined by lines. See ?locator} \item{show}{logical. Print the values after each click?} \item{...}{additional graphics parameters used if type != "n" for plotting the locations. See ?locator} } \value{ The value(s) of \code{x} at the point(s) clicked on (or touched by the box drawn). } \note{ The plot only provides the coordinates for a spatial query, the values are read from the Raster* or Spatial* object that is passed as an argument. Thus you can extract values from an object that has not been plotted, as long as it spatialy overlaps with with the extent of the plot. Unless the process is terminated prematurely values at at most \code{n} positions are determined. The identification process can be terminated by clicking the second mouse button and selecting 'Stop' from the menu, or from the 'Stop' menu on the graphics window. } \seealso{ \code{\link{select}, \link[raster]{drawExtent}} } \examples{ \dontrun{ r <- raster(system.file("external/test.grd", package="raster")) plot(r) click(r) # now click on the plot (map) }} \keyword{ spatial } raster/man/hillShade.Rd0000644000176200001440000000276614160021141014512 0ustar liggesusers\name{hillShade} \alias{hillShade} \title{Hill shading} \description{ Compute hill shade from slope and aspect layers (both in radians). Slope and aspect can be computed with function \code{\link{terrain}}. A hill shade layer is often used as a backdrop on top of which another, semi-transparent, layer is drawn. } \usage{ hillShade(slope, aspect, angle=45, direction=0, filename='', normalize=FALSE, ...) } \arguments{ \item{slope}{RasterLayer object with slope values (in radians) } \item{aspect}{RasterLayer object with aspect values (in radians) } \item{angle}{ The the elevation angle of the light source (sun), in degrees} \item{direction}{ The direction (azimuth) angle of the light source (sun), in degrees} \item{filename}{Character. Optional filename} \item{normalize}{Logical. If \code{TRUE}, values below zero are set to zero and the results are multiplied with 255} \item{...}{Standard additional arguments for writing RasterLayer files} } \seealso{ \code{\link{terrain}} } \author{Andrew Bevan, Robert J. Hijmans} \references{ Horn, B.K.P., 1981. Hill shading and the reflectance map. Proceedings of the IEEE 69(1):14-47 } \examples{ \dontrun{ alt <- getData('alt', country='CHE') slope <- terrain(alt, opt='slope') aspect <- terrain(alt, opt='aspect') hill <- hillShade(slope, aspect, 40, 270) plot(hill, col=grey(0:100/100), legend=FALSE, main='Switzerland') plot(alt, col=rainbow(25, alpha=0.35), add=TRUE) } } \keyword{spatial} raster/man/hdrFiles.Rd0000644000176200001440000000306114160021141014342 0ustar liggesusers\name{hdr} \alias{hdr} \title{Header files} \description{ Write header files to use together with raster binary files to read the data in other applications. } \usage{ hdr(x, format, extension='.wld', filename='') } \arguments{ \item{x}{RasterLayer or RasterBrick object associated with a binary values file on disk } \item{format}{Type of header file: 'VRT', 'BIL', 'ENVI', 'ErdasRaw', 'IDRISI', 'SAGA', 'RASTER', 'WORLDFILE', 'PRJ' } \item{extension}{File extension, only used with an ESRI worldfile (\code{format='WORLDFILE'})} \item{filename}{character. Need to be provided if \code{x} is not associated with a file} } \details{ The RasterLayer object must be associated with a file on disk. You can use \code{\link{writeRaster}} to save a existing file in another format. But if you have a file in a 'raster' format (or similar), you can also only export a header file, and use the data file (.gri) that already exists. The function can write a VRT (GDAL virtual raster) header (.vrt); an ENVI or BIL header (.hdr) file; an Erdas Raw (.raw) header file; an IDRISI (.rdc) or SAGA (.sgrd). This (hopefully) allows for reading the binary data (.gri), perhaps after changing the file extension, in other programs such as ENVI or ArcGIS. } \seealso{ \code{\link[raster]{writeRaster}}, \code{\link[rgdal:readGDAL]{writeGDAL}} } \examples{ \dontrun{ r <- raster(system.file("external/test.grd", package="raster")) r <- writeRaster(r, filename='export.grd', overwrite=TRUE) hdr(r, format="ENVI") } } \keyword{ spatial } raster/man/direction.Rd0000644000176200001440000000262514163701063014602 0ustar liggesusers\name{direction} \alias{direction} \alias{direction,RasterLayer-method} \title{Direction} \description{ The direction (azimuth) to or from the nearest cell that is not \code{NA}. The direction unit is in radians, unless you use argument \code{degrees=TRUE}. } \usage{ \S4method{direction}{RasterLayer}(x, filename='', degrees=FALSE, from=FALSE, doEdge=FALSE, ...) } \arguments{ \item{x}{RasterLayer object} \item{filename}{Character. Output filename (optional)} \item{degrees}{Logical. If \code{FALSE} (the default) the unit of direction is radians.} \item{from}{Logical. Default is \code{FALSE}. If \code{TRUE}, the direction from (instead of to) the nearest cell that is not \code{NA} is returned} \item{doEdge}{Logical. If \code{TRUE}, the \code{\link{boundaries}} function is called first. This may be efficient in cases where you compute the distance to large blobs. Calling \code{boundaries} determines the edge cells that matter for direction computation} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{RasterLayer} \seealso{ \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}} For the direction between (longitude/latitude) points, see the \code{azimuth} function in the \code{geosphere} package } \examples{ r <- raster(ncol=36,nrow=18) values(r) <- NA r[306] <- 1 b <- direction(r) #plot(b) } \keyword{spatial} raster/man/Logic-methods.Rd0000644000176200001440000000255414160021141015306 0ustar liggesusers\name{Logic-methods} \docType{methods} \alias{Logic-methods} \alias{Logic,Raster,Raster-method} \alias{is.na,Raster-method} \alias{is.nan,Raster-method} \alias{is.finite,Raster-method} \alias{is.infinite,Raster-method} \alias{!,Raster-method} \title{Logical operators and functions} \description{ The following logical (boolean) operators are available for computations with RasterLayer objects: \code{&, |, and !} The following functions are available with a Raster* argument: \code{is.na}, \code{is.nan}, \code{is.finite}, \code{is.infinite} } \value{ A Raster object with logical (\code{TRUE/FALSE} values) } \section{Note}{ These are convenient operators/functions that are most usful for relatively small RasterLayers for which all the values can be held in memory. If the values of the output RasterLayer cannot be held in memory, they will be saved to a temporary file. In that case it could be more efficient to use \code{\link[raster]{calc}} instead. } \seealso{ \code{\link[raster]{Math-methods}}, \code{\link[raster]{overlay}}, \code{\link[raster]{calc}} } \examples{ r <- raster(ncols=10, nrows=10) values(r) <- runif(ncell(r)) * 10 r1 <- r < 3 | r > 6 r2 <- !r1 r3 <- r >= 3 & r <= 6 r4 <- r2 == r3 r[r>3] <- NA r5 <- is.na(r) r[1:5] r1[1:5] r2[1:5] r3[1:5] } \keyword{methods} \keyword{math} raster/DESCRIPTION0000644000176200001440000000627714173106421013273 0ustar liggesusersPackage: raster Type: Package Title: Geographic Data Analysis and Modeling Version: 3.5-15 Date: 2022-01-22 Imports: Rcpp, methods, terra (>= 1.5-12) LinkingTo: Rcpp Depends: sp (>= 1.4-5), R (>= 3.5.0) Suggests: rgdal (>= 1.5-23), rgeos (>= 0.5-3), ncdf4, igraph, tcltk, parallel, rasterVis, MASS, sf, tinytest, gstat, fields, exactextractr SystemRequirements: C++11 Description: Reading, writing, manipulating, analyzing and modeling of spatial data. The package implements basic and high-level functions for raster data and for vector data operations such as intersections. See the manual and tutorials on to get started. License: GPL (>= 3) URL: https://rspatial.org/raster BugReports: https://github.com/rspatial/raster/issues/ Authors@R: c( person("Robert J.", "Hijmans", role = c("cre", "aut"), email = "r.hijmans@gmail.com", comment = c(ORCID = "0000-0001-5872-2872")), person("Jacob", "van Etten", role = "ctb"), person("Michael", "Sumner", role = "ctb"), person("Joe", "Cheng", role = "ctb"), person("Dan", "Baston", role = "ctb"), person("Andrew", "Bevan", role = "ctb"), person("Roger", "Bivand", role = "ctb"), person("Lorenzo", "Busetto", role = "ctb"), person("Mort", "Canty", role = "ctb"), person("Ben", "Fasoli", role = "ctb"), person("David", "Forrest", role = "ctb"), person("Aniruddha", "Ghosh", role = "ctb"), person("Duncan", "Golicher", role = "ctb"), person("Josh", "Gray", role = "ctb"), person("Jonathan A.", "Greenberg", role = "ctb"), person("Paul", "Hiemstra", role = "ctb"), person("Kassel", "Hingee", role = "ctb"), person("Alex", "Ilich", role = "ctb"), person("Institute for Mathematics Applied Geosciences", role="cph"), person("Charles", "Karney", role = "ctb"), person("Matteo", "Mattiuzzi", role = "ctb"), person("Steven", "Mosher", role = "ctb"), person("Babak", "Naimi", role = "ctb"), person("Jakub", "Nowosad", role = "ctb"), person("Edzer", "Pebesma", role = "ctb"), person("Oscar", "Perpinan Lamigueiro", role = "ctb"), person("Etienne B.", "Racine", role = "ctb"), person("Barry", "Rowlingson", role = "ctb"), person("Ashton", "Shortridge", role = "ctb"), person("Bill", "Venables", role = "ctb"), person("Rafael", "Wueest", role = "ctb") ) NeedsCompilation: yes Packaged: 2022-01-22 18:13:14 UTC; rhijm Author: Robert J. Hijmans [cre, aut] (), Jacob van Etten [ctb], Michael Sumner [ctb], Joe Cheng [ctb], Dan Baston [ctb], Andrew Bevan [ctb], Roger Bivand [ctb], Lorenzo Busetto [ctb], Mort Canty [ctb], Ben Fasoli [ctb], David Forrest [ctb], Aniruddha Ghosh [ctb], Duncan Golicher [ctb], Josh Gray [ctb], Jonathan A. Greenberg [ctb], Paul Hiemstra [ctb], Kassel Hingee [ctb], Alex Ilich [ctb], Institute for Mathematics Applied Geosciences [cph], Charles Karney [ctb], Matteo Mattiuzzi [ctb], Steven Mosher [ctb], Babak Naimi [ctb], Jakub Nowosad [ctb], Edzer Pebesma [ctb], Oscar Perpinan Lamigueiro [ctb], Etienne B. Racine [ctb], Barry Rowlingson [ctb], Ashton Shortridge [ctb], Bill Venables [ctb], Rafael Wueest [ctb] Maintainer: Robert J. Hijmans Repository: CRAN Date/Publication: 2022-01-22 23:02:41 UTC raster/build/0000755000176200001440000000000014173044472012657 5ustar liggesusersraster/build/partial.rdb0000644000176200001440000000751214173044472015011 0ustar liggesusers]m{V8VvPM8-4 MKH cZ,ǢIr~a_v/tHcIǍ^bAXy΋r2 !7H3/881NɊenzのh9hs WG){C_LD5,qJFO}"rSep]|lޚ[&鲢||y[i lv$X}S_wx ?qCv~1_b&6O[K%5RnwvYZT*W,YՒ)Z62K Q+T>i'g6WφS߽(Xo4 G4}G7TlG~2\pk52pP#R;#&8 thJDU-@*LBzxtd _i]ar# Nu#OlVêIA4Ч{ " pZ l<%U &)+W:Ԧ&يJMUs#EB6 y[EU%X+Nx׫ .F0N&(-$0G#os.%MڣMMyo 4LKnLDvl/H5C\M;MUh(F t5B8q0OU]TVﯭ3tS@7S+Yy* 'n8gqL $vSEp[|~ שE.Jp[ME6U^IHx GjDzSW:o SE6bBD@WY3:RƸ^10h sPu-`Be!8),ۚ |Xa4SIpR6-q+VL#M#)_x,I9 -C..cvS9nS[ @4ت<tzŬQ'C`D %MfQc$0sX9Th.&-j`:#M~mET ޞŰc p .0u{]D- J9H"H cWhKE3>vp޴ ѻbG6(mo~".>;•r QZDN@>[YV Ds Obh9iCq @_|xlęT'>x)fhb7Xt+ ۇߞO1spy<_' tzn.41E">Ca7/<7N蓉 ui(:Ӝ!\ 2=U@Ns\~&ڜ<t+F%:./;[tlHuw7QG|R-6ҷLѨ+]M f器)G,9X#slQQ 4$өm/Q#3 R*Q6:$ &(+WWnڦеԜ9&E-q*`-Ml(-9#Uu0eBv/Q&VzDMFcqNS@O¶6ê9pAj[LB^qdԒ=@?H-Y7zc?WR:qM`؇-ws?Mʀ_E1Ad;@9BHT-!y+pZi~:~=]1w-c•-gL&7g5SY./21u,zk;_'v[DI0?;]Ѓ|YLt 9i×1Z^Rk+ gs_/GvIfcXx!Ɨ@Ktb.Ym6UNYhHS م9z*byC\Ot :> ) hWlj7"3k5]Zeu1cM!y;qQ!(+0dz.\L zv ??X`9/>n?0iVLm2eH@Λ=cE͔1;+޻=Pr;{u5ei"{C/6C.v;%U~,zg0A]_*62-gmV VjUtHkZPj6GT0#Thyjia)V'v$5:O^ :_lYtC8!QfCĜݲnDh ,Btk?ks :4YQ\CZvx>P>dq?}a08ͪ]Hה#&vs$k*v7 YeYzDlS`a4Sc@БXPeݦ=6(ԑL:AM@؄`BjѥLn\9PžכԽhxY5p;* ]SOPJMݔ4rN&)VV]:#KIU5!*tt2Z.;f 'k6i`Q}}ݦkQ [UCHVʿkvEz m(]פ͖v;pW_ue ə) 'bvTp4"8ޮ5wut5f{1` ' Z2(t´蠘F (=Ɔ#'j1udՄ wKk?XJ=5,UWYk@SY,XM?#~>Bs`w7o\Z]*Yz.UJ9m#dE*rɝ8w_!?E_2}PEb gPT ˡ"d@_ k > =נ9쑉ޞ+ɓ'{.X7o^J~8;8c4 #include #include #include class SpExtent { public: virtual ~SpExtent(){} double xmin, xmax, ymin, ymax; SpExtent() {xmin = -180; xmax = 180; ymin = -90; ymax = 90;} SpExtent(double _xmin, double _xmax, double _ymin, double _ymax) {xmin = _xmin; xmax = _xmax; ymin = _ymin; ymax = _ymax;} void intersect(SpExtent e) { xmin = std::max(xmin, e.xmin); xmax = std::min(xmax, e.xmax); ymin = std::max(ymin, e.ymin); ymax = std::min(ymax, e.ymax); } std::vector asVector() { std::vector e(4); e[0] = xmin; e[1] = xmax; e[2] = ymin; e[3] = ymax; return(e); } bool valid() { return ((xmax > xmin) && (ymax > ymin)); } }; class SpPolyPart { public: virtual ~SpPolyPart(){} std::vector x, y; std::vector< std::vector> xHole, yHole; SpExtent extent; bool hasHoles() { return xHole.size() > 0;} unsigned nHoles() { return xHole.size();} bool set(std::vector X, std::vector Y) { x = X; y = Y; extent.xmin = *std::min_element(X.begin(), X.end()); extent.xmax = *std::max_element(X.begin(), X.end()); extent.ymin = *std::min_element(Y.begin(), Y.end()); extent.ymax = *std::max_element(Y.begin(), Y.end()); return true; } bool setHole(std::vector X, std::vector Y) { xHole.push_back(X); yHole.push_back(Y); return true; } std::vector getHoleX(unsigned i) { return( xHole[i] ) ; } std::vector getHoleY(unsigned i) { return( yHole[i] ) ; } }; class SpPoly { public: virtual ~SpPoly(){} std::vector parts; SpExtent extent; unsigned size() { return parts.size(); }; SpPolyPart getPart(unsigned i) { return parts[i]; } bool addPart(SpPolyPart p) { parts.push_back(p); if (parts.size() > 1) { extent.xmin = std::min(extent.xmin, p.extent.xmin); extent.xmax = std::max(extent.xmax, p.extent.xmax); extent.ymin = std::min(extent.ymin, p.extent.ymin); extent.ymax = std::max(extent.ymax, p.extent.ymax); } else { extent = p.extent; } return true; } }; class SpPolygons { public: virtual ~SpPolygons(){} std::vector polys; SpExtent extent; std::string crs; std::vector attr; unsigned size() { return polys.size(); }; SpPoly getPoly(unsigned i) { return polys[i]; }; bool addPoly(SpPoly p) { polys.push_back(p); if (polys.size() > 1) { extent.xmin = std::min(extent.xmin, p.extent.xmin); extent.xmax = std::max(extent.xmax, p.extent.xmax); extent.ymin = std::min(extent.ymin, p.extent.ymin); extent.ymax = std::max(extent.ymax, p.extent.ymax); } else { extent = p.extent; } attr.push_back(NAN); return true; } double getAtt(unsigned i) { return attr[i]; }; bool setAtt(unsigned i, double a) { attr[i] = a; return true; }; std::vector rasterize(unsigned nrow, unsigned ncol, std::vector extent, std::vector values, double background); SpPolygons subset(std::vector range) { SpPolygons out; for (size_t i=0; i < range.size(); i++) { out.addPoly( polys[range[i]] ); out.attr.push_back(attr[i]); } out.crs = crs; return out; }; }; class RasterSource { public: virtual ~RasterSource(){} std::vector memory; std::vector filename; std::vector driver; std::vector nlayers; std::vector > layers; std::vector datatype; std::vector NAflag; }; class BlockSize { public: virtual ~BlockSize(){} std::vector row; std::vector nrows; unsigned n; }; class SpRaster { private: std::string msg; fstream* fs; protected: SpExtent extent; std::string crs ="+proj=longlat +datum=WGS84"; void setnlyr() { nlyr = std::accumulate(source.nlayers.begin(), source.nlayers.end(), 0); } BlockSize getBlockSize(); public: virtual ~SpRaster(){} //double NA = std::numeric_limits::quiet_NaN(); RasterSource source; std::vector getnlayers() { return source.nlayers; } unsigned nrow, ncol, nlyr; unsigned size() { return ncol * nrow * nlyr ; } bool hasValues; BlockSize bs; std::vector values; std::vector hasRange; std::vector range_min; std::vector range_max; std::vector names; std::vector inMemory() { return source.memory; } // constructors SpRaster(std::string fname); SpRaster(); SpRaster(std::vector rcl, std::vector ext, std::string _crs); SpRaster(unsigned _nrow, unsigned _ncol, unsigned _nlyr, SpExtent ext, std::string _crs); double ncell() { return nrow * ncol; } // void setExtent(std::vector e) { extent.xmin = e[0]; extent.xmax = e[1]; extent.ymin = e[2]; extent.ymax = e[3]; } SpExtent getExtent() { return extent; } void setExtent(SpExtent e) { extent = e ; } void setExtent(SpExtent ext, bool keepRes=false, std::string snap=""); std::string getCRS() { return(crs); } void setCRS(std::string _crs) { crs = _crs; } std::vector getNames() { if (names.size() < 1) { return std::vector {"layer"}; // rep for each layer } return(names); } void setNames(std::vector _names) { names = _names; } std::vector resolution() { return std::vector { (extent.xmax - extent.xmin) / ncol, (extent.ymax - extent.ymin) / nrow };} double xres() { return (extent.xmax - extent.xmin) / ncol ;} double yres() { return (extent.ymax - extent.ymin) / nrow ;} std::vector origin(); //std::vector filenames() { return source.filename; } bool compare(unsigned nrows, unsigned ncols, SpExtent e ); std::vector getValues(); void setValues(std::vector _values); bool constructFromFile(std::string fname); std::vector cellFromXY (std::vector x, std::vector y); double cellFromXY(double x, double y); std::vector cellFromRowCol(std::vector rownr, std::vector colnr); double cellFromRowCol(unsigned rownr, unsigned colnr); std::vector yFromRow(std::vector rownr); double yFromRow(unsigned rownr); std::vector xFromCol(std::vector colnr); double xFromCol(unsigned colnr); std::vector colFromX(std::vector x); double colFromX(double x); std::vector rowFromY(std::vector y); double rowFromY(double y); std::vector< std::vector > xyFromCell( std::vector cell ); std::vector< std::vector > xyFromCell( double cell ); std::vector< std::vector > rowColFromCell(std::vector cell); double valuesCell(double); double valuesCell(int, int); std::vector valuesCell(std::vector); std::vector valuesRow(int); void setRange(); bool readStart(); bool readStop(); std::vector readValues(unsigned row, unsigned nrows, unsigned col, unsigned ncols); bool writeStart(std::string filename, bool overwrite); bool writeStartFs(std::string filename, bool overwrite, fstream& f); bool writeValues(std::vector vals, unsigned row); bool writeStop(); bool writeHDR(); void openFS(string const &filename); SpRaster writeRaster(std::string filename, bool overwrite); SpExtent align(SpExtent e, string snap="near"); SpRaster test(string filename); SpRaster crop(SpExtent e, string filename="", string snap="near", bool overwrite=false); SpRaster trim(unsigned padding=0, std::string filename="", bool overwrite=false); SpRaster mask(SpRaster mask, string filename="", bool overwrite=false); SpRaster focal(std::vector w, double fillvalue, bool narm, unsigned fun, std::string filename, bool overwrite); SpRaster rasterizePolygons(SpPolygons p, double background, string filename, bool overwrite); std::vector focal_values(std::vector w, double fillvalue, unsigned row, unsigned nrows); SpRaster aggregate(std::vector fact, string fun, bool narm, string filename="", bool overwrite=false); //std::vector aggregate(std::vector fact, bool narm, string fun, string filename=""); std::vector get_aggregate_dims( std::vector fact ); std::vector > get_aggregates(std::vector dim); std::vector sampleRegular(unsigned size, bool cells, bool asRaster); }; /* SpRaster SQRT() { SpRaster r = *this; std::transform(r.values.begin(), r.values.end(), r.values.begin(), (double(*)(double)) sqrt); return r; } SpRaster SQRTfree(SpRaster* g) { SpRaster r = *g; std::transform(r.values.begin(), r.values.end(), r.values.begin(), (double(*)(double)) sqrt); return r; } */ raster/src/focal_get.cpp0000644000176200001440000000154714160021141014765 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".focal_get")]] std::vector do_focal_get(std::vector d, std::vector dim, std::vector ngb) { int nrow = dim[0]; int ncol = dim[1]; int wrows = ngb[0]; int wcols = ngb[1]; size_t n = (nrow-wrows+1) * (ncol-wcols+1) * wrows * wcols; std::vector val(n); if ((wrows % 2 == 0) | (wcols % 2 == 0)) { Rcpp::Rcerr << "weights matrix must have uneven sides"; return(val); } int wr = wrows / 2; int wc = wcols / 2; wr = std::min(wr, nrow); wc = std::min(wc, ncol); int f = 0; for (int i = 0+wr; i < nrow-wr; i++) { for (int j = 0+wc; j < ncol-wc; j++) { for (int a=-wr; a <= wr ; a++) { int aa = (i+a) * ncol; for (int b=-wc; b <= wc ; b++) { val[f] = d[aa+j+b]; f++; } } } } return(val); } raster/src/clamp.cpp0000644000176200001440000000111414160021141014124 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".clamp")]] Rcpp::NumericVector do_clamp(std::vector d, std::vector r, bool usevals) { size_t n = d.size(); Rcpp::NumericVector val(n); if (usevals) { for (size_t i=0; i r[1] ) { val[i] = r[1]; } else { val[i] = d[i]; } } } else { for (size_t i=0; i r[1])) { val[i] = NAN; } else { val[i] = d[i]; } } } return(val); } raster/src/rasterize.cpp0000644000176200001440000000473214160021141015051 0ustar liggesusers/* Robert Hijmans, June 2011, July 2016 // Based on public-domain code by Darel Rex Finley, 2007 // http://alienryderflex.com/polygon_fill/ */ #include using namespace Rcpp; using namespace std; #include #include "spat.h" std::vector rasterize_polygon(std::vector r, double value, std::vector pX, std::vector pY, unsigned nrows, unsigned ncols, double xmin, double ymax, double rx, double ry) { unsigned n = pX.size(); std::vector nCol(n); for (size_t row=0; row= y)) || ((pY[j] < y) && (pY[i] >= y))) { double nds = ((pX[i] - xmin + (y-pY[i])/(pY[j]-pY[i]) * (pX[j]-pX[i])) + 0.5 * rx ) / rx; nds = nds < 0 ? 0 : nds; nds = nds > ncols ? ncols : nds; nCol[nodes] = (unsigned) nds; nodes++; } j = i; } std::sort(nCol.begin(), nCol.begin()+nodes); unsigned ncell = ncols * row; // Fill the cells between node pairs. for (size_t i=0; i < nodes; i+=2) { if (nCol[i+1] > 0 && nCol[i] < ncols) { //if (nCol[i] >= ncols || nCol[i+1] <= 0) break; for (size_t col = nCol[i]; col < nCol[i+1]; col++) { r[col + ncell] = value; } } } } return(r); } std::vector SpPolygons::rasterize(unsigned nrow, unsigned ncol, std::vector extent, std::vector values, double background) { unsigned n = size(); std::vector v(nrow*ncol, background); double resx = (extent[1] - extent[0]) / ncol; double resy = (extent[3] - extent[2]) / nrow; for (size_t j = 0; j < n; j++) { SpPoly poly = getPoly(j); double value = values[j]; unsigned np = poly.size(); for (size_t k = 0; k < np; k++) { SpPolyPart part = poly.getPart(k); if (part.hasHoles()) { std::vector vv = rasterize_polygon(v, value, part.x, part.y, nrow, ncol, extent[0], extent[3], resx, resy); for (size_t h=0; h < part.nHoles(); h++) { vv = rasterize_polygon(vv, background, part.xHole[h], part.yHole[h], nrow, ncol, extent[0], extent[3], resx, resy); } for (size_t q=0; q < vv.size(); q++) { if ((vv[q] != background) && (!std::isnan(vv[q]))) { //if (vv[q] != background) { v[q] = vv[q]; } } } else { v = rasterize_polygon(v, value, part.x, part.y, nrow, ncol, extent[0], extent[3], resx, resy); } } } return(v); } raster/src/RasterModule.cpp0000644000176200001440000000335414162265464015472 0ustar liggesusers#include #include "spat.h" using namespace Rcpp; RCPP_EXPOSED_CLASS(SpExtent) RCPP_EXPOSED_CLASS(SpPolyPart) RCPP_EXPOSED_CLASS(SpPoly) RCPP_EXPOSED_CLASS(SpPolygons) RCPP_MODULE(spmod){ using namespace Rcpp; class_("SpPolyPart") .constructor() .field_readonly("x", &SpPolyPart::x ) .field_readonly("y", &SpPolyPart::y ) .field_readonly("extent", &SpPolyPart::extent ) .method("set", &SpPolyPart::set, "set") .method("setHole", &SpPolyPart::setHole, "setHole") .method("getHoleX", &SpPolyPart::getHoleX, "getHoleX") .method("getHoleY", &SpPolyPart::getHoleY, "getHoleY") .method("nHoles", &SpPolyPart::nHoles, "nHoles") .method("hasHoles", &SpPolyPart::hasHoles, "hasHoles") ; class_("SpPoly") .constructor() .field_readonly("extent", &SpPoly::extent ) .method("getPart", &SpPoly::getPart, "getPart") .method("addPart", &SpPoly::addPart, "addPart") .method("size", &SpPoly::size, "size") ; class_("SpPolygons") // .field("polygons", &SpPolygons::polys ) .field_readonly("extent", &SpPolygons::extent ) .field("attr", &SpPolygons::attr ) .field("crs", &SpPolygons::crs ) .constructor() .method("getPoly", &SpPolygons::getPoly, "getPoly") .method("addPoly", &SpPolygons::addPoly, "addPoly") .method("size", &SpPolygons::size, "size") .method("getAtt", &SpPolygons::getAtt, "getAtt") .method("setAtt", &SpPolygons::setAtt, "setAtt") .method("rasterize", &SpPolygons::rasterize, "rasterize") .method("subset", &SpPolygons::subset, "subset") ; class_("SpExtent") .constructor() .constructor() .property("vector", &SpExtent::asVector) .property("valid", &SpExtent::valid) ; } raster/src/broom.cpp0000644000176200001440000000774014160021141014161 0ustar liggesusers/* Robert Hijmans, October 2011 This is an implementation of J. Ronald Eastman's pushbroom algorithm */ #include #include #define min( a, b ) ( ((a) < (b)) ? (a) : (b) ) // [[Rcpp::export(name = ".broom")]] std::vector broom(std::vector d, std::vector f, std::vector dm, std::vector dist, bool down) { double dx = dist[0]; double dy = dist[1]; double dxy = dist[2]; int leftright = 2; //INTEGER(lr)[0]; size_t nr = dm[0]; size_t nc = dm[1]; size_t n = nr * nc; // Rprintf ("n = %i \n", n); std::vector dis(n); for (size_t i=0; i::infinity(); } if (down) { //left to right //r = 0; first row, no row above it, use 'f' if (leftright >= 1) { //i = 0; first cell, no cell left of it if ( std::isnan(d[0])) { dis[0] = f[0] + dy; } else { dis[0] = 0; } // other cells for (size_t i=1; i 1)) { if ( std::isnan(d[nc-1])) { dis[nc-1] = min(dis[nc-1], f[nc-1] + dy); } else { dis[nc-1] = 0; } // other cells for (int i=(nc-2); i > -1; i--) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], f[i] + dy), f[i+1] + dxy), dis[i+1] + dx); } else { dis[i] = 0; } } // other rows for (size_t r=1; r(r*nc-1); i--) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], dis[i+1] + dx), dis[i-nc] + dy), dis[i-nc+1] + dxy); } else { dis[i] = 0; } } } } } else { // bottom to top // left to right // first (last) row if (leftright >= 1) { size_t r = nr-1; // first cell size_t i = r*nc; if (std::isnan(d[i])) { dis[i] = min(dis[i], f[0] + dy); } else { dis[i] = 0; } // other cells for (size_t i=(r*nc+1); i= 0; r--) { i=r*nc; if (std::isnan(d[i])) { dis[i] = min(dis[i], dis[i+nc] + dy); } else { dis[i] = 0; } for (size_t i=(r*nc+1); i<((r+1)*nc); i++) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], dis[i-1] + dx), dis[i+nc] + dy), dis[i+nc-1] + dxy); } else { dis[i] = 0; } } } } if ((leftright == 0) | (leftright > 1)) { // right to left // first row // first cell if (std::isnan(d[n-1])) { dis[n-1] = min(dis[n-1], f[nc-1] + dy); } else { dis[n-1] = 0; } // other cells size_t r = nr-1; for (size_t i=n-2; i > (r*nc-1); i--) { if (std::isnan(d[i])) { size_t j = i - r*nc; dis[i] = min(min(min(dis[i], f[j] + dx), f[j+1] + dxy), dis[i+1] + dx); } else { dis[i] = 0; } } // other rows for (size_t r=nr-2; r >= 0; r--) { size_t i = (r+1)*nc-1; if (std::isnan(d[i])) { dis[i] = min(dis[i], dis[i+nc] + dy); } else { dis[i] = 0; } for (size_t i=(r+1)*nc-2; i>(r*nc-1); i--) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], dis[i+1] + dx), dis[i+nc] + dy), dis[i+nc+1] + dxy); } else { dis[i] = 0; } } } } } return(dis); } raster/src/terrain.cpp0000644000176200001440000002354114160021141014504 0ustar liggesusers #include #include "util.h" #include double dmod(double x, double n) { return(x - n * floor(x/n)); } double distPlane(double x1, double y1, double x2, double y2) { return( sqrt(pow((x2-x1),2) + pow((y2-y1), 2)) ); } double distHav(double lon1, double lat1, double lon2, double lat2, double r) { double dLat, dLon, a; lon1 = toRad(lon1); lon2 = toRad(lon2); lat1 = toRad(lat1); lat2 = toRad(lat2); dLat = lat2-lat1; dLon = lon2-lon1; a = sin(dLat/2.) * sin(dLat/2.) + cos(lat1) * cos(lat2) * sin(dLon/2.) * sin(dLon/2.); return 2. * atan2(sqrt(a), sqrt(1.-a)) * r; } // [[Rcpp::export(name = ".terrain")]] std::vector do_terrains(std::vector d, std::vector dim, std::vector res, int unit, std::vector option, bool geo, std::vector gy) { double zy, zx; size_t nrow = dim[0]; size_t ncol = dim[1]; size_t n = nrow * ncol; double dx = res[0]; double dy = res[1]; int nopt = 0; for (size_t i =0; i<8; i++) { nopt += option[i]; } std::vector ddx; if (geo) { double r = 6378137; ddx.resize(nrow); for (size_t i=0; i val(n*nopt); size_t add=0; int addn=0; if (option[0]) { // terrain ruggedness for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i] = (fabs(d[i-1-ncol]-d[i]) + fabs(d[i-1]-d[i]) + fabs(d[i-1+ncol]-d[i]) + fabs(d[i-ncol]-d[i]) + fabs(d[i+ncol]-d[i]) + fabs(d[i+1-ncol]-d[i]) + fabs(d[i+1]-d[i]) + fabs(d[i+1+ncol]-d[i])) / 8; } add++; } if (option[1]) { addn = add * n; // topograhic position for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = d[i] - (d[i-1-ncol] + d[i-1] + d[i-1+ncol] + d[i-ncol] + d[i+ncol] + d[i+1-ncol] + d[i+1] + d[i+1+ncol]) / 8; } add++; } if (option[2]) { // roughness addn = add * n; int incol = ncol; int a[9] = { -1-incol, -1, -1+incol, -incol, 0, incol, 1-incol, 1, 1+incol }; double min, max, v; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { min = d[i + a[0]]; max = d[i + a[0]]; for (size_t j = 1; j < 9; j++) { v = d[i + a[j]]; if (v > max) { max = v; } else if (v < min) { min = v; } } val[i+addn] = max - min; } add++; } if (option[3]) { // slope 4 neighbors addn = add * n; if (geo) { int q; double xwi[2] = {-1,1}; double xw[2] = {0,0}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<2; k++) { xw[k] = xwi[k] / (-2 * ddx[q]); } } zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ) ; } } else { double xw[2] = {-1,1}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { xw[i] = xw[i] / (-2 * dx); yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ); } } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]) * adj; } } else if (unit == 1) { for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]); } } add++; } if (option[4]) { // aspect 4 neighbors addn = add * n; if (geo) { int q; double xwi[2] = {-1,1}; double xw[2] = {0,0}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<2; k++) { xw[k] = xwi[k] / (-2 * ddx[q]); } } zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 - zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } else { double xw[2] = {-1,1}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { xw[i] = xw[i] / (-2 * dx); yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 -zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } add++; } if (option[5]) { // slope 8 neighbors addn = add * n; if (geo) { int q; double xwi[6] = {-1,-2,-1,1,2,1}; double xw[6] = {0,0,0,0,0,0}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { yw[i] = yw[i] / (8 * dy); xw[i] = xwi[i] / (-8 * ddx[1]); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<6; k++) { xw[k] = xwi[k] / (8 * ddx[q]); } } zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ); } } else { double xw[6] = {-1,-2,-1,1,2,1}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { xw[i] = xw[i] / (-8 * dx); yw[i] = yw[i] / (8 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ); } } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]) * adj; } } else if (unit == 1) { for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]); } } add++; } if (option[6]) { // aspect 8 neighbors addn = add * n; if (geo) { int q; double xwi[6] = {-1,-2,-1,1,2,1}; double xw[6] = {0,0,0,0,0,0}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { yw[i] = yw[i] / (8 * dy); xw[i] = xwi[i] / (-8 * ddx[1]); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<6; k++) { xw[k] = xwi[k] / (-8 * ddx[q]); } } zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 -zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } else { double xw[6] = {-1,-2,-1,1,2,1}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { xw[i] = xw[i] / (-8 * dx); yw[i] = yw[i] / (8 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 -zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } add++; } if (option[7]) { // flow direction std::default_random_engine generator(std::random_device{}()); //generator.seed(seed); std::uniform_int_distribution<> distrib(0, 1); //auto gen = std::bind(std::uniform_int_distribution<>(0,1),std::default_random_engine()); addn = add * n; double r[8] = {0,0,0,0,0,0,0,0}; double p[8] = {1,2,4,8,16,32,64,128}; // pow(2, j) double dxy = sqrt(dx * dx + dy * dy); for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { if (std::isnan(d[i])) { val[i+addn] = NAN; } else { r[0] = (d[i] - d[i+1]) / dx; r[1] = (d[i] - d[i+1+ncol]) / dxy; r[2] = (d[i] - d[i+ncol]) / dy; r[3] = (d[i] - d[i-1+ncol]) / dxy; r[4] = (d[i] - d[i-1]) / dx; r[5] = (d[i] - d[i-1-ncol]) / dxy; r[6] = (d[i] - d[i-ncol]) / dy; r[7] = (d[i] - d[i+1-ncol]) / dxy; // using the lowest neighbor, even if it is higher than the focal cell. double dmin = r[0]; int k = 0; for (size_t j=1; j<8; j++) { if (r[j] > dmin) { dmin = r[j]; k = j; } else if (r[j] == dmin) { bool b = distrib(generator); if (b) { dmin = r[j]; k = j; } } } val[i+addn] = p[k]; } } add++; } // Set edges to NA // first row for (size_t j=0; j #include "Rmath.h" #ifndef M_PI #define M_PI (3.14159265358979323846) #endif double mod(double x, double n) { return(x - n * floor(x/n)); } double normalizeLonDeg(double lon) { return( mod( (lon + 180), 360 ) - 180 ); } double normalizeLonRad(double lon) { return( mod( (lon + M_PI), M_2PI) - M_PI); } /* Convert degrees to radians */ double toRad(double deg) { return( deg * 0.0174532925199433 ); } double toDeg(double rad) { return( rad * 57.2957795130823 ); } #endif raster/src/layerize.cpp0000644000176200001440000000074514160021141014665 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".layerize")]] Rcpp::NumericVector layerize(std::vector d, std::vector cls, bool falsena) { int vna = falsena ? R_NaInt : 0; size_t m = d.size(); size_t n = cls.size(); Rcpp::NumericVector v(m * n, vna); for (size_t i=0; i get_dims( std::vector dim); std::vector > get_aggregates(std::vector > data, std::vector dim); std::vector > aggregate(std::vector > data, std::vector dim, bool narm, int fun); raster/src/ppmin.cpp0000644000176200001440000000602514160021141014161 0ustar liggesusers#include using namespace Rcpp; // Simple & fast pmin & pmax with no checking for NA values! // [[Rcpp::export(name = ".doSpmin")]] NumericVector doSpmin(NumericVector x, NumericVector y) { int n = x.length(); // NumericVector out = clone(x); for (int i = 0; i < n; ++i) { if (x[i] > y[i]) { x[i] = y[i]; } } return x; } // [[Rcpp::export(name = ".doSpmax")]] NumericVector doSpmax(NumericVector x, NumericVector y) { int n = x.length(); //NumericVector out = clone(x); for (int i = 0; i < n; ++i) { if (x[i] < y[i]) { x[i] = y[i]; } } return x; } // These functions check for NA, but are not that much faster than pmin // [[Rcpp::export(name = ".ppmin")]] NumericVector ppmin(NumericVector x, NumericVector y, bool narm) { int n = x.length(); //NumericVector out = clone(x); if (narm) { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(x[i])) { x[i] = y[i]; } else if (x[i] > y[i]) { x[i] = y[i]; } } } else { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(y[i])) { x[i] = y[i]; } else if (x[i] > y[i]) { x[i] = y[i]; } } } return x; } // [[Rcpp::export(name = ".ppmax")]] NumericVector ppmax(NumericVector x, NumericVector y, bool narm) { int n = x.length(); //NumericVector out = clone(x); if (narm) { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(x[i])) { x[i] = y[i]; } else if (x[i] < y[i]) { x[i] = y[i]; } } } else { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(y[i])) { x[i] = y[i]; } else if (x[i] < y[i]) { x[i] = y[i]; } } } return x; } // fast rowMin and rowMax // [[Rcpp::export(name = ".doRowMin")]] NumericVector doRowMin(NumericMatrix x, bool narm) { int nrow = x.nrow(), ncol = x.ncol(); NumericVector out(nrow); if (narm) { for (int i = 0; i < nrow; i++) { out[i] = INFINITY; for (int j = 0; j < ncol; j++) { if (x(i,j) < out[i]) { out[i] = x(i,j); } } if (out[i] == INFINITY) { out[i] = NA_REAL; } } } else { for (int i = 0; i < nrow; i++) { out[i] = INFINITY; for (int j = 0; j < ncol; j++) { if (NumericVector::is_na(x(i,j))) { out[i] = NA_REAL; break; } if (x(i,j) < out[i]) { out[i] = x(i,j); } } if (out[i] == INFINITY) { out[i] = NA_REAL; } } } return out; } // [[Rcpp::export(name = ".doRowMax")]] NumericVector doRowMax(NumericMatrix x, bool narm) { int nrow = x.nrow(), ncol = x.ncol(); NumericVector out(nrow); if (narm) { for (int i = 0; i < nrow; i++) { out[i] = -INFINITY; for (int j = 0; j < ncol; j++) { if (x(i,j) > out[i]) { out[i] = x(i,j); } } if (out[i] == -INFINITY) { out[i] = NA_REAL; } } } else { for (int i = 0; i < nrow; i++) { out[i] = -INFINITY; for (int j = 0; j < ncol; j++) { if (NumericVector::is_na(x(i,j))) { out[i] = NA_REAL; break; } if (x(i,j) > out[i]) { out[i] = x(i,j); } } if (out[i] == -INFINITY) { out[i] = NA_REAL; } } } return out; } raster/src/memory.cpp0000644000176200001440000000406014160021141014343 0ustar liggesusers// Robert Hijmans with improvements by Ben Fasoli // https://github.com/rspatial/raster/pull/175 #ifdef _WIN32 #include #elif __linux__ #include #elif __APPLE__ #include #include #include #include #endif // [[Rcpp::export(name = ".availableRAM")]] double availableRAM(double ram) { // return available RAM #ifdef _WIN32 MEMORYSTATUSEX statex; statex.dwLength = sizeof(statex); GlobalMemoryStatusEx(&statex); ram = statex.ullAvailPhys; #elif __linux__ // source available memory from /proc/meminfo // default to searching for MemAvailable field (kernel versions >= 3.14) FILE *fp = popen("awk '/MemAvailable/ {print $2}' /proc/meminfo", "r"); if (fp == NULL) { return ram; } double ramkb; int ok = fscanf(fp, "%lf", &ramkb); // returned in kB pclose(fp); if (ramkb > 0) { return ramkb * 1000.; } // fallback to estimating memory from other fields if MemAvailable not found FILE *fp2 = popen("awk -v low=$(grep low /proc/zoneinfo | awk '{k+=$2}END{print k}') '{a[$1]=$2}END{print a[\"MemFree:\"]+a[\"Active(file):\"]+a[\"Inactive(file):\"]+a[\"SReclaimable:\"]-(12*low);}' /proc/meminfo", "r"); if (fp2 == NULL) { return ram; } ok = fscanf(fp2, "%lf", &ramkb); // returned in kB pclose(fp2); if (ramkb > 0) { return ramkb * 1000.; } #elif __APPLE__ vm_size_t page_size; mach_port_t mach_port; mach_msg_type_number_t count; vm_statistics64_data_t vm_stats; mach_port = mach_host_self(); count = sizeof(vm_stats) / sizeof(natural_t); if (KERN_SUCCESS == host_page_size(mach_port, &page_size) && KERN_SUCCESS == host_statistics64(mach_port, HOST_VM_INFO, (host_info64_t)&vm_stats, &count)) { long long free_memory = ((int64_t)vm_stats.free_count + (int64_t)vm_stats.inactive_count) * (int64_t)page_size; ram = free_memory; //https://stackoverflow.com/questions/63166/how-to-determine-cpu-and-memory-consumption-from-inside-a-process } #endif return ram; } raster/src/modal.cpp0000644000176200001440000000276114160021141014135 0ustar liggesusers#include using namespace Rcpp; // [[Rcpp::export(name = ".getMode")]] double getMode(NumericVector values, int ties) { int n = values.length(); IntegerVector counts(n); if (ties < 2) { std::sort(values.begin(), values.end()); } for (int i = 0; i < n; ++i) { counts[i] = 0; int j = 0; while ((j < i) && (values[i] != values[j])) { ++j; } ++(counts[j]); } int maxCount = 0; // first (lowest due to sorting) if (ties == 0) { for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; } } // last } else if (ties == 1) { for (int i = 1; i < n; ++i) { if (counts[i] >= counts[maxCount]) { maxCount = i; } } // dont care (first, but not sorted) } else if (ties == 2) { for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; } } // random } else if (ties == 3) { int tieCount = 1; for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; tieCount = 1; } else if (counts[i] == counts[maxCount]) { tieCount++; if (R::runif(0,1) < (1.0 / tieCount)) { maxCount = i; } } } // NA } else { int tieCount = 1; for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; tieCount = 1; } else if (counts[i] == counts[maxCount]) { tieCount++; } } if (tieCount > 1 ) { return(NA_REAL); } } return values[maxCount]; } raster/src/distance.h0000644000176200001440000000534014160021141014274 0ustar liggesusers// distance double distance_plane(double x1, double y1, double x2, double y2); std::vector distance_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2); std::vector distanceToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2); double distance_lonlat(double lon1, double lat1, double lon2, double lat2, double a, double f); std::vector distance_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f) ; std::vector distanceToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f); // direction double direction_lonlat(double lon1, double lat1, double lon2, double lat2, bool degrees, double a, double f); std::vector direction_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, double a, double f); std::vector directionToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, bool from, double a, double f); double direction_plane(double x1, double y1, double x2, double y2, bool degrees); std::vector direction_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees); std::vector directionToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees, bool from); // destination std::vector destpoint_lonlat(double longitude, double latitude, double bearing, double distance, double a, double f); std::vector > destpoint_lonlat(std::vector longitude, std::vector latitude, std::vector bearing, std::vector distance, double a, double f); std::vector destpoint_plane(double x, double y, double bearing, double distance); std::vector > destpoint_plane(std::vector x, std::vector y, std::vector bearing, std::vector distance); // area double area_polygon_lonlat(std::vector lon, std::vector lat, double a, double f); double area_polygon_plane(std::vector x, std::vector y); std::vector area_polygon_lonlat(std::vector lon, std::vector lat, std::vector pols, std::vector parts, std::vector holes, double a, double f); std::vector area_polygon_plane(std::vector x, std::vector y, std::vector pols, std::vector parts, std::vector holes); raster/src/focal_fun.cpp0000644000176200001440000000420414160021141014767 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".focal_fun")]] std::vector do_focal_fun(std::vector d, Rcpp::NumericMatrix w, std::vector dim, Rcpp::Function fun, bool naonly) { int nrow = dim[0]; int ncol = dim[1]; int n = nrow * ncol; int wrows = w.nrow(); int wcols = w.ncol(); size_t wn = wrows * wcols; std::vector ans(n); std::vector x; if ((wrows % 2 == 0) | (wcols % 2 == 0)){ Rcpp::Rcerr << "weights matrix must have uneven sides\n"; return(ans); } int wr = wrows / 2; int wc = wcols / 2; wr = std::min(wr, nrow); wc = std::min(wc, ncol); int nwc = ncol - wc - 1; int col = 0; if (naonly) { // first rows for (int i = 0; i < ncol*wr; i++) { ans[i] = d[i]; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { if (!std::isnan(d[i])) { ans[i] = d[i]; } else { col = i % ncol; if ((col < wc) | (col > nwc)) { ans[i] = d[i]; } else { size_t q = 0; x.resize(0); x.reserve(wn); for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { x.push_back( d[j * ncol + k + i] * w[q] ); } q++; } } Rcpp::NumericVector out = fun(x); ans[i] = out[0]; if (std::isnan(ans[i])) { ans[i] = NAN; } } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { ans[i] = d[i]; } } else { // first rows for (int i = 0; i < ncol*wr; i++) { ans[i] = NAN; } for (int i = ncol*wr; i < (ncol * (nrow-wr)); i++) { col = i % ncol; if ((col < wc) | (col > nwc)) { ans[i] = NAN; } else { size_t q = 0; x.resize(0); x.reserve(wn); for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { x.push_back( d[j * ncol + k + i] * w[q] ); } q++; } } Rcpp::NumericVector out = fun(x); ans[i] = out[0]; if (std::isnan(ans[i])) { ans[i] = NAN; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { ans[i] = NAN; } } return(ans); } raster/src/aggregate.cpp0000644000176200001440000000773314160021141014773 0ustar liggesusers/* Robert Hijmans, October 2014 */ #include #include #include std::vector get_dims( std::vector dim) { dim.resize(9); for (int i=0; i < 3; i++) { dim[i+6] = std::ceil(dim[i] / double(dim[i+3])); } return(dim); /* // raster dimensions int nr = dim[0], nc = dim[1], nl =dim[2]; // aggregation factors in the three dimensions int dy = dim[3], dx = dim[4], dz = dim[5]; // new dimensions: rows, cols, lays dim[6] = std::ceil(nr / double(dy)); dim[7] = std::ceil(nc / double(dx)); dim[8] = std::ceil(nl / double(dz)); */ } std::vector > get_aggregates(std::vector > data, std::vector dim) { // raster nrow, ncol, nlay int nr = dim[0], nc = dim[1], nl =dim[2]; // nl == data.size(); // data[0].size() == nr * nc == ncell; // aggregation factor in three dimensions int dy = dim[3], dx = dim[4], dz = dim[5]; // blocks per row (=ncol), col (=nrow) int bpC = dim[6], bpR = dim[7]; // blocks per layer int bpL = bpR * bpC; // new number of layers int newNL = dim[8]; // new number of rows, adjusted for additional (expansion) rows int adjnr = bpC * dy; // number of aggregates int nblocks = (bpR * bpC * newNL); // cells per aggregate int blockcells = dx * dy * dz; // output: each row is a block std::vector< std::vector > a(nblocks, std::vector(blockcells, std::numeric_limits::quiet_NaN())); for (int b = 0; b < nblocks; b++) { int lstart = dz * (b / bpL); int rstart = (dy * (b / bpR)) % adjnr; int cstart = dx * (b % bpR); int lmax = std::min(nl, (lstart + dz)); int rmax = std::min(nr, (rstart + dy)); int cmax = std::min(nc, (cstart + dx)); // Rcout << b << ", " << lstart << ", " << rstart << ", " << cstart << "\n"; int f = 0; for (int j = lstart; j < lmax; j++) { for (int r = rstart; r < rmax; r++) { int cell = r * nc; for (int c = cstart; c < cmax; c++) { //Rcout << "cell : " << cell + c << "\n"; a[b][f] = data[cell + c][j]; f++; } } } } return(a); } std::vector > aggregate(std::vector > data, std::vector dim, bool narm, int fun) { // fun = 'sum', 'mean', 'min', 'max' // 0, 1, 2, 3 int mean = 0; if (fun==1) { fun = 0; mean = 1; } // blocks per row (=ncol), col (=nrow) int ncol = dim[6], nrow = dim[7]; // new number of layers int nl = dim[8]; // output: each row is a new cell double NA = std::numeric_limits::quiet_NaN(); std::vector< std::vector > v(nrow*ncol, std::vector(nl, NA)); // get the aggregates std::vector > a = get_aggregates(data, dim); int nblocks = a.size(); int naggs = a[0].size(); // Rcout << nblocks << ", " << naggs << "\n"; for (int i = 0; i < nblocks; i++) { int row = (i / ncol) % nrow; int col = i % ncol; int cell = row * ncol + col; int lyr = std::floor(i / (nrow * ncol)); // Rcout << row << ", " << col << ", " << lyr << "\n"; double x = 0; if (fun==2) { // min x = std::numeric_limits::infinity(); } else if (fun==3) { // max x = - std::numeric_limits::infinity() ; } double cnt = 0; for (int j = 0; j < naggs; j++) { //Rcout << x << ", " << a[i][j] << "\n"; if (std::isnan(a[i][j])) { if (!narm) { x = NA; goto breakout; } } else { if (fun==2) { // min x = std::min(x, a[i][j]); } else if (fun==3) { // max x = std::max(x, a[i][j]); } else { // sum or mean x += a[i][j]; } cnt++; } } if (cnt > 0) { if (mean) { x = x / cnt; } } else { x = NA; } breakout: v[cell][lyr] = x; } return(v); } raster/src/reclass.cpp0000644000176200001440000000625314160021141014475 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".reclassify")]] Rcpp::NumericVector reclassify(Rcpp::NumericVector d, Rcpp::NumericMatrix rcl, bool dolowest, bool doright, bool doleftright, bool NAonly, double NAval) { double lowval, lowres; size_t a = rcl.nrow(); size_t nc = rcl.ncol(); size_t b = a * 2; size_t n = d.size(); Rcpp::NumericVector val(n); if (NAonly) { // only change NA values for (size_t i=0; i= rcl[j]) & (d[i] <= rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } else if (doright) { // interval closed at right if (dolowest) { // include lowest value (left) of interval lowval = rcl[0]; lowres = rcl[b]; for (size_t j=1; j rcl[j]) & (d[i] <= rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } else { // !dolowest for (size_t i=0; i rcl[j]) & (d[i] <= rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } } else { // !doright if (dolowest) { // which here means highest because right=FALSE lowval = rcl[a]; lowres = rcl[b]; for (size_t j=a+1; j lowval) { lowval = rcl[j]; lowres = rcl[a+j]; } } for (size_t i=0; i= rcl[j]) & (d[i] < rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } else { //!dolowest for (size_t i=0; i= rcl[j]) & (d[i] < rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } } } return(val); } raster/src/edge.cpp0000644000176200001440000000331114160021141013735 0ustar liggesusers/* Robert Hijmans, November 2011 */ #include // [[Rcpp::export(name = ".edge")]] std::vector do_edge(std::vector d, std::vector dim, bool classes, bool edgetype, unsigned dirs) { bool falseval = 0; size_t nrow = dim[0]; size_t ncol = dim[1]; size_t n = nrow * ncol; std::vector val(n); int r[8] = { -1,0,0,1 , -1,-1,1,1}; int c[8] = { 0,-1,1,0 , -1,1,-1,1}; if (!classes) { if (!edgetype) { // inner for (size_t i = 1; i < (nrow-1); i++) { for (size_t j = 1; j < (ncol-1); j++) { size_t cell = i*ncol+j; val[cell] = NAN; if ( !std::isnan(d[cell])) { val[cell] = falseval; for (size_t k=0; k< dirs; k++) { if ( std::isnan(d[cell + r[k] * ncol + c[k]])) { val[cell] = 1; break; } } } } } } else { //outer for (size_t i = 1; i < (nrow-1); i++) { for (size_t j = 1; j < (ncol-1); j++) { size_t cell = i*ncol+j; val[cell] = falseval; if (std::isnan(d[cell])) { val[cell] = NAN; for (size_t k=0; k < dirs; k++) { if ( !std::isnan(d[cell+ r[k] * ncol + c[k] ])) { val[cell] = 1; break; } } } } } } } else { // by class for (size_t i = 1; i < (nrow-1); i++) { for (size_t j = 1; j < (ncol-1); j++) { size_t cell = i*ncol+j; double test = d[cell+r[0]*ncol+c[0]]; val[cell] = std::isnan(test) ? NAN : falseval; for (size_t k=1; k using namespace Rcpp; // [[Rcpp::export(name = ".getPolygons")]] NumericMatrix getPolygons(NumericMatrix xyv, NumericVector res, int nodes) { int n = xyv.nrow(); double xr = res(0)/2; double yr = res(1)/2; if (nodes == 4) { NumericMatrix cr(n, 10); for (int i = 0; i < n; i++) { cr(i, 0) = xyv(i, 0) - xr; cr(i, 1) = xyv(i, 0) + xr; cr(i, 2) = cr(i, 1); cr(i, 3) = cr(i, 0); cr(i, 4) = cr(i, 0); cr(i, 5) = xyv(i, 1) + yr; cr(i, 6) = cr(i, 5); cr(i, 7) = xyv(i, 1) - yr; cr(i, 8) = cr(i, 7); cr(i, 9) = cr(i, 5); } return cr; } else if (nodes == 8) { NumericMatrix cr(n, 18); for (int i = 0; i < n; i++) { cr(i, 0) = xyv(i, 0) - xr; cr(i, 1) = xyv(i, 0); cr(i, 2) = xyv(i, 0) + xr; cr(i, 3) = cr(i, 2); cr(i, 4) = cr(i, 2); cr(i, 5) = cr(i, 1); cr(i, 6) = cr(i, 0); cr(i, 7) = cr(i, 0); cr(i, 8) = cr(i, 0); cr(i, 9) = xyv(i, 1) + yr; cr(i, 10) = cr(i, 9); cr(i, 11) = cr(i, 9); cr(i, 12) = xyv(i, 1); cr(i, 13) = xyv(i, 1) - yr; cr(i, 14) = cr(i, 13); cr(i, 15) = cr(i, 13); cr(i, 16) = cr(i, 12); cr(i, 17) = cr(i, 9); } return cr; } else { NumericMatrix cr(n, 34); for (int i = 0; i < n; i++) { cr(i, 0) = xyv(i, 0) - xr; cr(i, 1) = xyv(i, 0) - 0.5 * xr; cr(i, 2) = xyv(i, 0); cr(i, 3) = xyv(i, 0) + 0.5 * xr; cr(i, 4) = xyv(i, 0) + xr; cr(i, 5) = cr(i, 4); cr(i, 6) = cr(i, 4); cr(i, 7) = cr(i, 4); cr(i, 8) = cr(i, 4); cr(i, 9) = cr(i, 3); cr(i, 10) = cr(i, 2); cr(i, 11) = cr(i, 1); cr(i, 12) = cr(i, 0); cr(i, 13) = cr(i, 0); cr(i, 14) = cr(i, 0); cr(i, 15) = cr(i, 0); cr(i, 16) = cr(i, 0); cr(i, 17) = xyv(i, 1) + yr; cr(i, 18) = cr(i, 17); cr(i, 19) = cr(i, 17); cr(i, 20) = cr(i, 17); cr(i, 21) = cr(i, 17); cr(i, 22) = xyv(i, 1) + 0.5 * yr; cr(i, 23) = xyv(i, 1); cr(i, 24) = xyv(i, 1) - 0.5 * yr; cr(i, 25) = xyv(i, 1) - yr; cr(i, 26) = cr(i, 25); cr(i, 27) = cr(i, 25); cr(i, 28) = cr(i, 25); cr(i, 29) = cr(i, 25); cr(i, 30) = cr(i, 24); cr(i, 31) = cr(i, 23); cr(i, 32) = cr(i, 22); cr(i, 33) = cr(i, 17); } return cr; } } raster/src/raster_distance.cpp0000644000176200001440000000674114160021141016215 0ustar liggesusers/* Robert Hijmans, October 2011 July 2016 */ #include #include "distance.h" // [[Rcpp::export(name = ".get_area_polygon")]] Rcpp::NumericVector get_area_polygon(Rcpp::NumericMatrix d, bool lonlat) { std::vector pols(d(Rcpp::_,0).begin(), d(Rcpp::_,0).end()); std::vector parts(d(Rcpp::_,1).begin(), d(Rcpp::_,1).end()); std::vector holes(d(Rcpp::_,3).begin(), d(Rcpp::_,3).end()); std::vector x(d(Rcpp::_,4).begin(), d(Rcpp::_,4).end()); std::vector y(d(Rcpp::_,5).begin(), d(Rcpp::_,5).end()); std::vector out; if (lonlat) { // wgs84 double a = 6378137; double f = 1/298.257223563; out = area_polygon_lonlat(x, y, pols, parts, holes, a, f); } else { out = area_polygon_plane(x, y, pols, parts, holes); } Rcpp::NumericVector r( out.begin(), out.end() ); return( r ); } // [[Rcpp::export(name = ".point_distance")]] Rcpp::NumericVector point_distance(Rcpp::NumericMatrix p1, Rcpp::NumericMatrix p2, bool lonlat, double a, double f) { std::vector px1(p1(Rcpp::_,0).begin(), p1(Rcpp::_,0).end()); std::vector py1(p1(Rcpp::_,1).begin(), p1(Rcpp::_,1).end()); std::vector px2(p2(Rcpp::_,0).begin(), p2(Rcpp::_,0).end()); std::vector py2(p2(Rcpp::_,1).begin(), p2(Rcpp::_,1).end()); Rcpp::NumericVector res; if (lonlat) { res = distance_lonlat(px1, py1, px2, py2, a, f); } else { res = distance_plane(px1, py1, px2, py2); } return(res); } // [[Rcpp::export(name = ".distanceToNearestPoint")]] Rcpp::NumericVector distanceToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, double a, double f) { std::vector dx(d(Rcpp::_,0).begin(), d(Rcpp::_,0).end()); std::vector dy(d(Rcpp::_,1).begin(), d(Rcpp::_,1).end()); std::vector px(p(Rcpp::_,0).begin(), p(Rcpp::_,0).end()); std::vector py(p(Rcpp::_,1).begin(), p(Rcpp::_,1).end()); Rcpp::NumericVector res; if (lonlat) { res = distanceToNearest_lonlat(dx, dy, px, py, a, f); } else { res = distanceToNearest_plane(dx, dy, px, py); } return(res) ; } // [[Rcpp::export(name = ".directionToNearestPoint")]] Rcpp::NumericVector directionToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, bool degrees, bool from, double a, double f) { std::vector dx(d(Rcpp::_,0).begin(), d(Rcpp::_,0).end()); std::vector dy(d(Rcpp::_,1).begin(), d(Rcpp::_,1).end()); std::vector px(p(Rcpp::_,0).begin(), p(Rcpp::_,0).end()); std::vector py(p(Rcpp::_,1).begin(), p(Rcpp::_,1).end()); Rcpp::NumericVector res; if (lonlat) { res = directionToNearest_lonlat(dx, dy, px, py, degrees, from, a, f); } else { res = directionToNearest_plane(dx, dy, px, py, degrees, from); } return(res) ; } // [[Rcpp::export(name = ".dest_point")]] Rcpp::NumericMatrix dest_point(Rcpp::NumericMatrix xybd, bool lonlat, double a, double f) { std::vector x(xybd(Rcpp::_,0).begin(), xybd(Rcpp::_,0).end()); std::vector y(xybd(Rcpp::_,1).begin(), xybd(Rcpp::_,1).end()); std::vector b(xybd(Rcpp::_,2).begin(), xybd(Rcpp::_,2).end()); std::vector d(xybd(Rcpp::_,3).begin(), xybd(Rcpp::_,3).end()); std::vector > res; if (lonlat) { res = destpoint_lonlat(x, y, b, d, a, f); } else { res = destpoint_plane(x, y, b, d); } int n = res.size(); int m = res[0].size(); Rcpp::NumericMatrix r(n, m); for (int i=0; i < n; i++) { for (int j=0; j < m; j++) { r(i,j) = res[i][j]; } } return(r); } raster/src/bilinear.cpp0000644000176200001440000000201014160021141014611 0ustar liggesusers#include using namespace std; using namespace Rcpp; // xy: num[1:n, 1:2] // x: num[1:2, 1:n] // y: num[1:2, 1:n] // v: num[1:n, 1:4] // columns are: bottom-left, top-left, top-right, bottom-right // [[Rcpp::export(name = ".doBilinear")]] NumericVector doBilinear(NumericMatrix xy, NumericMatrix x, NumericMatrix y, NumericMatrix v) { size_t len = v.nrow(); NumericVector result(len); for (size_t i = 0; i < len; i++) { double left = x(0,i); double right = x(1,i); double top = y(1,i); double bottom = y(0,i); double horiz = xy(i,0); double vert = xy(i,1); double denom = (right - left) * (top - bottom); double bottomLeftValue = v(i,0) / denom; double topLeftValue = v(i,1) / denom; double topRightValue = v(i,3) / denom; double bottomRightValue = v(i,2) / denom; result[i] = bottomLeftValue*(right-horiz)*(top-vert) + bottomRightValue*(horiz-left)*(top-vert) + topLeftValue*(right-horiz)*(vert-bottom) + topRightValue*(horiz-left)*(vert-bottom); } return result; } raster/src/memory.h0000644000176200001440000000002714160021141014007 0ustar liggesusersdouble availableRAM(); raster/src/focal_sum.cpp0000644000176200001440000001001214160021141014775 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".focal_sum")]] std::vector do_focal_sum(std::vector d, Rcpp::NumericMatrix w, std::vector dim, bool narm, bool naonly, bool bemean) { int wrows = w.nrow(); int wcols = w.ncol(); int nrow = dim[0]; int ncol = dim[1]; int n = nrow * ncol; std::vector val(n); if ((wrows % 2 == 0) | (wcols % 2 == 0)){ Rcpp::Rcerr << wrows << " " << wcols << "\n"; Rcpp::Rcerr << "weights matrix must have uneven sides\n"; return(val); } int wr = wrows / 2; int wc = wcols / 2; wr = std::min(wr, nrow); wc = std::min(wc, ncol); int nwc = ncol - wc - 1; int col = 0; if (narm) { if (naonly) { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = d[i]; } for (int i = ncol*wr; i < ncol*(nrow-wr); i++) { if (! std::isnan(d[i])) { val[i] = d[i]; } else { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = d[i]; } else { val[i] = 0; size_t q = 0; size_t p = 0; for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { double a = d[j * ncol + k + i]; if ( !std::isnan(a) ) { val[i] += a * w[q]; p++; } q++; } } } if (p==0) { val[i] = NAN; } else if (bemean) { val[i] = val[i] / p; } } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = d[i]; } } else { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = NAN; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = NAN; } else { size_t q = 0; size_t p = 0; val[i] = 0; for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { double a = d[j * ncol + k + i]; if ( !std::isnan(a) ) { val[i] += a * w[q]; p++; } } q++; } } if (p==0) { val[i] = NAN; } else if (bemean) { val[i] = val[i] / p; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = NAN; } } } else { if (naonly) { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = d[i]; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { bool disnan = std::isnan(d[i]); if (!disnan) { val[i] = d[i]; } else { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = NAN; } else { val[i] = 0; size_t q = 0; if (disnan) { for (int j = -wr; j <= wr; j++) { bool jnot0 = j != 0; for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { if (jnot0 && (k != 0)) { val[i] += d[j * ncol + k + i] * w[q]; } q++; } } } } else { for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { val[i] += d[j * ncol + k + i] * w[q]; } q++; } } } if (bemean) { val[i] = val[i] / q; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = d[i]; } } } else { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = NAN; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = NAN; } else { val[i] = 0; size_t q = 0; for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { val[i] += d[j * ncol + k + i] * w[q]; } q++; } } if (bemean) { val[i] = val[i] / q; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = NAN; } } } return(val); } raster/src/util.h0000644000176200001440000000054014160021141013454 0ustar liggesusers/* modulo */ double mod(double x, double n) ; /* Convert degrees to radians */ double toRad(double deg) ; /* Convert radians to degrees */ double toDeg(double rad) ; /* normatlize longitude between -180 .. 180 degrees*/ double normalizeLonDeg(double lon); /* normatlize longitude between -pi .. p1 radians*/ double normalizeLonRad(double lon); raster/src/distance.cpp0000644000176200001440000002523314160021141014632 0ustar liggesusers/* Robert Hijmans, June 2011, July 2016 */ #include using namespace Rcpp; using namespace std; #include #include "geodesic.h" #include #include "util.h" double distance_lonlat(double lon1, double lat1, double lon2, double lat2, double a, double f) { double s12, azi1, azi2; struct geod_geodesic g; geod_init(&g, a, f); geod_inverse(&g, lat1, lon1, lat2, lon2, &s12, &azi1, &azi2); return s12; } std::vector distance_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f) { // lonlat1 and lonlat2 should have the same length std::vector r (lon1.size()); double azi1, azi2; struct geod_geodesic g; geod_init(&g, a, f); int n = lat1.size(); for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &r[i], &azi1, &azi2); } return r; } std::vector distanceToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f) { double azi1, azi2, s12; int n = lon1.size(); int m = lon2.size(); std::vector r(n); struct geod_geodesic g; geod_init(&g, a, f); for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[0], lon2[0], &r[i], &azi1, &azi2); for (int j=1; j distance_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2) { // xy1 and xy2 should have the same length std::vector r (x1.size()); int n = x1.size(); for (int i=0; i < n; i++) { r[i] = sqrt(pow((x2[i]-x1[i]),2) + pow((y2[i]-y1[i]), 2)); } return r; } std::vector distanceToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2) { int n = x1.size(); int m = x2.size(); std::vector r(n); double d; for (int i=0; i < n; i++) { r[i] = sqrt(pow((x2[0]-x1[i]),2) + pow((y2[0]-y1[i]), 2)); for (int j=1; j < m; j++) { d = sqrt(pow((x2[j]-x1[i]),2) + pow((y2[j]-y1[i]), 2)); if (d < r[i]) { r[i] = d; } } } return r; } double direction_lonlat(double lon1, double lat1, double lon2, double lat2, bool degrees, double a, double f) { double s12, azi1, azi2; struct geod_geodesic g; geod_init(&g, a, f); geod_inverse(&g, lat1, lon1, lat2, lon2, &s12, &azi1, &azi2); if (!degrees) { return(toRad(azi1)); } return( azi1) ; } std::vector direction_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, double a, double f) { // lonlat1 and lonlat2 should have the same length std::vector azi1(lon1.size()); double s12, azi2; struct geod_geodesic g; geod_init(&g, a, f); int n = lat1.size(); if (degrees) { for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &s12, &azi1[i], &azi2); } } else { for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &s12, &azi1[i], &azi2); azi1[i] = toRad(azi1[i]); } } return azi1; } std::vector directionToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, bool from, double a, double f) { double azi1, azi2, s12, dist; int n = lon1.size(); int m = lon2.size(); std::vector azi(n); struct geod_geodesic g; geod_init(&g, a, f); if (from) { for (int i=0; i < n; i++) { geod_inverse(&g, lat2[0], lon2[0], lat1[i], lon1[i], &dist, &azi1, &azi2); azi[i] = azi1; for (int j=1; j direction_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees) { // xy1 and xy2 should have the same length std::vector r (x1.size()); //double a; int n = x1.size(); for (int i=0; i < n; i++) { r[i] = direction_plane(x1[i], y1[i], x2[i], y2[i], degrees); } return r; } std::vector directionToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees, bool from) { int n = x1.size(); int m = x2.size(); std::vector r(n); double d, mind; int minj; if (from) { for (int i = 0; i < n; i++) { mind = distance_plane(x1[i], y1[i], x2[0], y2[0]); minj = 0; for (int j = 1; j < m; j++) { d = distance_plane(x1[i], y1[i], x2[j], y2[j]); if (d < mind) { mind = d; minj = j; } } r[i] = direction_plane(x2[minj], y2[minj], x1[i], y1[i], degrees); } } else { for (int i = 0; i < n; i++) { mind = distance_plane(x1[i], y1[i], x2[0], y2[0]); minj = 0; for (int j = 1; j < m; j++) { d = distance_plane(x1[i], y1[i], x2[j], y2[j]); if (d < mind) { mind = d; minj = j; } } r[i] = direction_plane(x1[i], y1[i], x2[minj], y2[minj], degrees); } } return r; } std::vector destpoint_lonlat(double longitude, double latitude, double bearing, double distance, double a, double f) { struct geod_geodesic g; geod_init(&g, a, f); double lat2, lon2, azi2; geod_direct(&g, latitude, longitude, bearing, distance, &lat2, &lon2, &azi2); std::vector out = {lon2, lat2, azi2 }; return out; } std::vector > destpoint_lonlat(std::vector longitude, std::vector latitude, std::vector bearing, std::vector distance, double a, double f) { struct geod_geodesic g; geod_init(&g, a, f); int n = longitude.size(); std::vector > out; double lat2, lon2, azi2; for (int i=0; i < n; i++) { geod_direct(&g, latitude[i], longitude[i], bearing[i], distance[i], &lat2, &lon2, &azi2); out.push_back( {lon2, lat2, azi2 }); } return out; } std::vector destpoint_plane(double x, double y, double bearing, double distance) { bearing = bearing * M_PI / 180; x += distance * cos(bearing); y += distance * sin(bearing); std::vector out = {x, y}; return(out); } std::vector > destpoint_plane(std::vector x, std::vector y, std::vector bearing, std::vector distance) { int n = x.size(); std::vector > out(n, std::vector(3)); double xd, yd, b; for (int i=0; i < n; i++) { b = bearing[i] * M_PI / 180; xd = x[i] + distance[i] * cos(b); yd = y[i] + distance[i] * sin(b); out.push_back( {xd, yd }); } return(out); } double area_polygon_lonlat(std::vector lon, std::vector lat, double a, double f) { struct geod_geodesic g; struct geod_polygon p; geod_init(&g, a, f); geod_polygon_init(&p, 0); int n = lat.size(); for (int i=0; i < n; i++) { geod_polygon_addpoint(&g, &p, lat[i], lon[i]); } double area, P; geod_polygon_compute(&g, &p, 0, 1, &area, &P); return(area < 0 ? -area : area); } std::vector area_polygon_lonlat(std::vector lon, std::vector lat, std::vector pols, std::vector parts, std::vector holes, double a, double f) { std::vector out; struct geod_geodesic g; struct geod_polygon p; geod_init(&g, a, f); geod_polygon_init(&p, 0); double area, P, pa, tota; int pol = 1; int part = 1; int n = lon.size(); tota = 0; for (int i=0; i < n; i++) { if (parts[i] != part || pols[i] != pol) { geod_polygon_compute(&g, &p, 0, 1, &area, &P); pa = fabs(area); tota += (holes[i-1] > 0 ? -pa : pa); // hole part = parts[i]; if (pols[i] != pol) { out.push_back(tota); tota = 0; pol = pols[i]; } geod_polygon_init(&p, 0); } geod_polygon_addpoint(&g, &p, lat[i], lon[i]); } geod_polygon_compute(&g, &p, 0, 1, &area, &P); pa = fabs(area); tota += (holes[n-1] > 0 ? -pa : pa); // hole out.push_back(tota); return(out); } double area_polygon_plane(std::vector x, std::vector y) { // based on http://paulbourke.net/geometry/polygonmesh/source1.c int n = x.size(); double area = x[n-1] * y[0]; area -= y[n-1] * x[0]; for (int i=0; i < (n-1); i++) { area += x[i] * y[i+1]; area -= x[i+1] * y[i]; } area /= 2; return(area < 0 ? -area : area); } /* std::vector area_polygon_plane(std::vector x, std::vector y, std::vector pols, std::vector parts, std::vector holes) { std::vector out; std::vector px; std::vector py; int pol = 1; int part = 1; int n = x.size(); double tota = 0; double pa; for (int i=0; i < n; i++) { if (parts[i] != part || pols[i] != pol) { pa = area_polygon_plane(px, py); tota += (holes[i-1] > 0 ? -pa : pa); part = parts[i]; if (pols[i] != pol) { out.push_back(tota); tota = 0; pol = pols[i]; } px.resize(0); py.resize(0); } px.push_back(x[i]); py.push_back(y[i]); } pa = area_polygon_plane(px, py); tota += (holes[n-1] > 0 ? -pa : pa); out.push_back(tota); return(out); } */ std::vector area_polygon_plane(std::vector x, std::vector y, std::vector pols, std::vector parts, std::vector holes) { std::vector out; int pol = 1; int part = 1; int n = x.size(); double tota = 0; double pa; int ps = 0; for (int i=0; i < n; i++) { if (parts[i] != part || pols[i] != pol) { pa = area_polygon_plane(std::vector (x.begin() + ps, x.begin() + i - 1), std::vector (y.begin() + ps, y.begin() + i - 1)); tota += (holes[i-1] > 0 ? -pa : pa); part = parts[i]; ps = i; if (pols[i] != pol) { out.push_back(tota); tota = 0; pol = pols[i]; } } } pa = area_polygon_plane(std::vector (x.begin() + ps, x.end()), std::vector (y.begin() + ps, y.end())); tota += (holes[n-1] > 0 ? -pa : pa); out.push_back(tota); return(out); } raster/src/cellRowCol.cpp0000644000176200001440000000156514160021141015107 0ustar liggesusers#include using namespace Rcpp; // [[Rcpp::export(name = ".doCellFromRowCol")]] NumericVector doCellFromRowCol(IntegerVector nrow, IntegerVector ncol, IntegerVector rownr, IntegerVector colnr) { int nr = nrow[0]; int nc = ncol[0]; size_t rownr_size = rownr.size(); size_t colnr_size = colnr.size(); NumericVector result(std::max(rownr_size, colnr_size)); // Manually recycle the shorter of rownr/colnr to match the other size_t len = std::max(rownr.size(), colnr.size()); for (size_t i = 0; i < len; i++) { // The % is to recycle elements if they're not the same length double r = rownr[i < rownr_size ? i : i % rownr_size]; double c = colnr[i < colnr_size ? i : i % colnr_size]; // Detect out-of-bounds rows/cols and use NA for those result[i] = (r<1 || r>nr || c<1 || c>nc) ? NA_REAL : (r-1) * nc + c; } return result; } raster/src/geodesic.h0000644000176200001440000011424414160021141014270 0ustar liggesusers/** * \file geodesic.h * \brief Header for the geodesic routines in C * * This an implementation in C of the geodesic algorithms described in * - C. F. F. Karney, * * Algorithms for geodesics, * J. Geodesy 87, 43--55 (2013); * DOI: * 10.1007/s00190-012-0578-z; * addenda: * geod-addenda.html. * . * The principal advantages of these algorithms over previous ones (e.g., * Vincenty, 1975) are * - accurate to round off for |f| < 1/50; * - the solution of the inverse problem is always found; * - differential and integral properties of geodesics are computed. * * The shortest path between two points on the ellipsoid at (\e lat1, \e * lon1) and (\e lat2, \e lon2) is called the geodesic. Its length is * \e s12 and the geodesic from point 1 to point 2 has forward azimuths * \e azi1 and \e azi2 at the two end points. * * Traditionally two geodesic problems are considered: * - the direct problem -- given \e lat1, \e lon1, \e s12, and \e azi1, * determine \e lat2, \e lon2, and \e azi2. This is solved by the function * geod_direct(). * - the inverse problem -- given \e lat1, \e lon1, and \e lat2, \e lon2, * determine \e s12, \e azi1, and \e azi2. This is solved by the function * geod_inverse(). * * The ellipsoid is specified by its equatorial radius \e a (typically in * meters) and flattening \e f. The routines are accurate to round off with * double precision arithmetic provided that |f| < 1/50; for the * WGS84 ellipsoid, the errors are less than 15 nanometers. (Reasonably * accurate results are obtained for |f| < 1/5.) For a prolate * ellipsoid, specify \e f < 0. * * The routines also calculate several other quantities of interest * - \e S12 is the area between the geodesic from point 1 to point 2 and the * equator; i.e., it is the area, measured counter-clockwise, of the * quadrilateral with corners (\e lat1,\e lon1), (0,\e lon1), (0,\e lon2), * and (\e lat2,\e lon2). * - \e m12, the reduced length of the geodesic is defined such that if * the initial azimuth is perturbed by \e dazi1 (radians) then the * second point is displaced by \e m12 \e dazi1 in the direction * perpendicular to the geodesic. On a curved surface the reduced * length obeys a symmetry relation, \e m12 + \e m21 = 0. On a flat * surface, we have \e m12 = \e s12. * - \e M12 and \e M21 are geodesic scales. If two geodesics are * parallel at point 1 and separated by a small distance \e dt, then * they are separated by a distance \e M12 \e dt at point 2. \e M21 * is defined similarly (with the geodesics being parallel to one * another at point 2). On a flat surface, we have \e M12 = \e M21 * = 1. * - \e a12 is the arc length on the auxiliary sphere. This is a * construct for converting the problem to one in spherical * trigonometry. \e a12 is measured in degrees. The spherical arc * length from one equator crossing to the next is always 180°. * * If points 1, 2, and 3 lie on a single geodesic, then the following * addition rules hold: * - \e s13 = \e s12 + \e s23 * - \e a13 = \e a12 + \e a23 * - \e S13 = \e S12 + \e S23 * - \e m13 = \e m12 \e M23 + \e m23 \e M21 * - \e M13 = \e M12 \e M23 − (1 − \e M12 \e M21) \e * m23 / \e m12 * - \e M31 = \e M32 \e M21 − (1 − \e M23 \e M32) \e * m12 / \e m23 * * The shortest distance returned by the solution of the inverse problem is * (obviously) uniquely defined. However, in a few special cases there are * multiple azimuths which yield the same shortest distance. Here is a * catalog of those cases: * - \e lat1 = −\e lat2 (with neither point at a pole). If \e azi1 = * \e azi2, the geodesic is unique. Otherwise there are two geodesics * and the second one is obtained by setting [\e azi1, \e azi2] = [\e * azi2, \e azi1], [\e M12, \e M21] = [\e M21, \e M12], \e S12 = * −\e S12. (This occurs when the longitude difference is near * ±180° for oblate ellipsoids.) * - \e lon2 = \e lon1 ± 180° (with neither point at a pole). * If \e azi1 = 0° or ±180°, the geodesic is unique. * Otherwise there are two geodesics and the second one is obtained by * setting [\e azi1, \e azi2] = [−\e azi1, −\e azi2], \e S12 * = −\e S12. (This occurs when \e lat2 is near −\e lat1 for * prolate ellipsoids.) * - Points 1 and 2 at opposite poles. There are infinitely many * geodesics which can be generated by setting [\e azi1, \e azi2] = * [\e azi1, \e azi2] + [\e d, −\e d], for arbitrary \e d. (For * spheres, this prescription applies when points 1 and 2 are * antipodal.) * - \e s12 = 0 (coincident points). There are infinitely many geodesics * which can be generated by setting [\e azi1, \e azi2] = [\e azi1, \e * azi2] + [\e d, \e d], for arbitrary \e d. * * These routines are a simple transcription of the corresponding C++ classes * in GeographicLib. The "class * data" is represented by the structs geod_geodesic, geod_geodesicline, * geod_polygon and pointers to these objects are passed as initial arguments * to the member functions. Most of the internal comments have been retained. * However, in the process of transcription some documentation has been lost * and the documentation for the C++ classes, GeographicLib::Geodesic, * GeographicLib::GeodesicLine, and GeographicLib::PolygonAreaT, should be * consulted. The C++ code remains the "reference implementation". Think * twice about restructuring the internals of the C code since this may make * porting fixes from the C++ code more difficult. * * Copyright (c) Charles Karney (2012-2014) and licensed * under the MIT/X11 License. For more information, see * http://geographiclib.sourceforge.net/ * * This library was distributed with * GeographicLib 1.42. **********************************************************************/ #if !defined(GEODESIC_H) #define GEODESIC_H 1 /** * The major version of the geodesic library. (This tracks the version of * GeographicLib.) **********************************************************************/ #define GEODESIC_VERSION_MAJOR 1 /** * The minor version of the geodesic library. (This tracks the version of * GeographicLib.) **********************************************************************/ #define GEODESIC_VERSION_MINOR 42 /** * The patch level of the geodesic library. (This tracks the version of * GeographicLib.) **********************************************************************/ #define GEODESIC_VERSION_PATCH 0 /** * Pack the version components into a single integer. Users should not rely on * this particular packing of the components of the version number; see the * documentation for GEODESIC_VERSION, below. **********************************************************************/ #define GEODESIC_VERSION_NUM(a,b,c) ((((a) * 10000 + (b)) * 100) + (c)) /** * The version of the geodesic library as a single integer, packed as MMmmmmpp * where MM is the major version, mmmm is the minor version, and pp is the * patch level. Users should not rely on this particular packing of the * components of the version number. Instead they should use a test such as * \code #if GEODESIC_VERSION >= GEODESIC_VERSION_NUM(1,40,0) ... #endif * \endcode **********************************************************************/ #define GEODESIC_VERSION \ GEODESIC_VERSION_NUM(GEODESIC_VERSION_MAJOR, \ GEODESIC_VERSION_MINOR, \ GEODESIC_VERSION_PATCH) #if defined(__cplusplus) extern "C" { #endif /** * The struct containing information about the ellipsoid. This must be * initialized by geod_init() before use. **********************************************************************/ struct geod_geodesic { double a; /**< the equatorial radius */ double f; /**< the flattening */ /**< @cond SKIP */ double f1, e2, ep2, n, b, c2, etol2; double A3x[6], C3x[15], C4x[21]; /**< @endcond */ }; /** * The struct containing information about a single geodesic. This must be * initialized by geod_lineinit() before use. **********************************************************************/ struct geod_geodesicline { double lat1; /**< the starting latitude */ double lon1; /**< the starting longitude */ double azi1; /**< the starting azimuth */ double a; /**< the equatorial radius */ double f; /**< the flattening */ /**< @cond SKIP */ double b, c2, f1, salp0, calp0, k2, salp1, calp1, ssig1, csig1, dn1, stau1, ctau1, somg1, comg1, A1m1, A2m1, A3c, B11, B21, B31, A4, B41; double C1a[6+1], C1pa[6+1], C2a[6+1], C3a[6], C4a[6]; /**< @endcond */ unsigned caps; /**< the capabilities */ }; /** * The struct for accumulating information about a geodesic polygon. This is * used for computing the perimeter and area of a polygon. This must be * initialized by geod_polygon_init() before use. **********************************************************************/ struct geod_polygon { double lat; /**< the current latitude */ double lon; /**< the current longitude */ /**< @cond SKIP */ double lat0; double lon0; double A[2]; double P[2]; int polyline; int crossings; /**< @endcond */ unsigned num; /**< the number of points so far */ }; /** * Initialize a geod_geodesic object. * * @param[out] g a pointer to the object to be initialized. * @param[in] a the equatorial radius (meters). * @param[in] f the flattening. **********************************************************************/ void geod_init(struct geod_geodesic* g, double a, double f); /** * Initialize a geod_geodesicline object. * * @param[out] l a pointer to the object to be initialized. * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lat1 latitude of point 1 (degrees). * @param[in] lon1 longitude of point 1 (degrees). * @param[in] azi1 azimuth at point 1 (degrees). * @param[in] caps bitor'ed combination of geod_mask() values specifying the * capabilities the geod_geodesicline object should possess, i.e., which * quantities can be returned in calls to geod_position() and * geod_genposition(). * * \e g must have been initialized with a call to geod_init(). \e lat1 * should be in the range [−90°, 90°]; \e lon1 and \e azi1 * should be in the range [−540°, 540°). * * The geod_mask values are [see geod_mask()]: * - \e caps |= GEOD_LATITUDE for the latitude \e lat2; this is * added automatically, * - \e caps |= GEOD_LONGITUDE for the latitude \e lon2, * - \e caps |= GEOD_AZIMUTH for the latitude \e azi2; this is * added automatically, * - \e caps |= GEOD_DISTANCE for the distance \e s12, * - \e caps |= GEOD_REDUCEDLENGTH for the reduced length \e m12, * - \e caps |= GEOD_GEODESICSCALE for the geodesic scales \e M12 * and \e M21, * - \e caps |= GEOD_AREA for the area \e S12, * - \e caps |= GEOD_DISTANCE_IN permits the length of the * geodesic to be given in terms of \e s12; without this capability the * length can only be specified in terms of arc length. * . * A value of \e caps = 0 is treated as GEOD_LATITUDE | GEOD_LONGITUDE | * GEOD_AZIMUTH | GEOD_DISTANCE_IN (to support the solution of the "standard" * direct problem). **********************************************************************/ void geod_lineinit(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, unsigned caps); /** * Solve the direct geodesic problem. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lat1 latitude of point 1 (degrees). * @param[in] lon1 longitude of point 1 (degrees). * @param[in] azi1 azimuth at point 1 (degrees). * @param[in] s12 distance between point 1 and point 2 (meters); it can be * negative. * @param[out] plat2 pointer to the latitude of point 2 (degrees). * @param[out] plon2 pointer to the longitude of point 2 (degrees). * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * * \e g must have been initialized with a call to geod_init(). \e lat1 * should be in the range [−90°, 90°]; \e lon1 and \e azi1 * should be in the range [−540°, 540°). The values of \e lon2 * and \e azi2 returned are in the range [−180°, 180°). Any of * the "return" arguments \e plat2, etc., may be replaced by 0, if you do not * need some quantities computed. * * If either point is at a pole, the azimuth is defined by keeping the * longitude fixed, writing \e lat = ±(90° − ε), and * taking the limit ε → 0+. An arc length greater that 180° * signifies a geodesic which is not a shortest path. (For a prolate * ellipsoid, an additional condition is necessary for a shortest path: the * longitudinal extent must not exceed of 180°.) * * Example, determine the point 10000 km NE of JFK: @code struct geod_geodesic g; double lat, lon; geod_init(&g, 6378137, 1/298.257223563); geod_direct(&g, 40.64, -73.78, 45.0, 10e6, &lat, &lon, 0); printf("%.5f %.5f\n", lat, lon); @endcode **********************************************************************/ void geod_direct(const struct geod_geodesic* g, double lat1, double lon1, double azi1, double s12, double* plat2, double* plon2, double* pazi2); /** * Solve the inverse geodesic problem. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lat1 latitude of point 1 (degrees). * @param[in] lon1 longitude of point 1 (degrees). * @param[in] lat2 latitude of point 2 (degrees). * @param[in] lon2 longitude of point 2 (degrees). * @param[out] ps12 pointer to the distance between point 1 and point 2 * (meters). * @param[out] pazi1 pointer to the azimuth at point 1 (degrees). * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * * \e g must have been initialized with a call to geod_init(). \e lat1 * and \e lat2 should be in the range [−90°, 90°]; \e lon1 and * \e lon2 should be in the range [−540°, 540°). The values of * \e azi1 and \e azi2 returned are in the range [−180°, 180°). * Any of the "return" arguments \e ps12, etc., may be replaced by 0, if you * do not need some quantities computed. * * If either point is at a pole, the azimuth is defined by keeping the * longitude fixed, writing \e lat = ±(90° − ε), and * taking the limit ε → 0+. * * The solution to the inverse problem is found using Newton's method. If * this fails to converge (this is very unlikely in geodetic applications * but does occur for very eccentric ellipsoids), then the bisection method * is used to refine the solution. * * Example, determine the distance between JFK and Singapore Changi Airport: @code struct geod_geodesic g; double s12; geod_init(&g, 6378137, 1/298.257223563); geod_inverse(&g, 40.64, -73.78, 1.36, 103.99, &s12, 0, 0); printf("%.3f\n", s12); @endcode **********************************************************************/ void geod_inverse(const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, double* ps12, double* pazi1, double* pazi2); /** * Compute the position along a geod_geodesicline. * * @param[in] l a pointer to the geod_geodesicline object specifying the * geodesic line. * @param[in] s12 distance between point 1 and point 2 (meters); it can be * negative. * @param[out] plat2 pointer to the latitude of point 2 (degrees). * @param[out] plon2 pointer to the longitude of point 2 (degrees); requires * that \e l was initialized with \e caps |= GEOD_LONGITUDE. * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * * \e l must have been initialized with a call to geod_lineinit() with \e * caps |= GEOD_DISTANCE_IN. The values of \e lon2 and \e azi2 returned are * in the range [−180°, 180°). Any of the "return" arguments * \e plat2, etc., may be replaced by 0, if you do not need some quantities * computed. * * Example, compute way points between JFK and Singapore Changi Airport * the "obvious" way using geod_direct(): @code struct geod_geodesic g; double s12, azi1, lat[101],lon[101]; int i; geod_init(&g, 6378137, 1/298.257223563); geod_inverse(&g, 40.64, -73.78, 1.36, 103.99, &s12, &azi1, 0); for (i = 0; i < 101; ++i) { geod_direct(&g, 40.64, -73.78, azi1, i * s12 * 0.01, lat + i, lon + i, 0); printf("%.5f %.5f\n", lat[i], lon[i]); } @endcode * A faster way using geod_position(): @code struct geod_geodesic g; struct geod_geodesicline l; double s12, azi1, lat[101],lon[101]; int i; geod_init(&g, 6378137, 1/298.257223563); geod_inverse(&g, 40.64, -73.78, 1.36, 103.99, &s12, &azi1, 0); geod_lineinit(&l, &g, 40.64, -73.78, azi1, 0); for (i = 0; i < 101; ++i) { geod_position(&l, i * s12 * 0.01, lat + i, lon + i, 0); printf("%.5f %.5f\n", lat[i], lon[i]); } @endcode **********************************************************************/ void geod_position(const struct geod_geodesicline* l, double s12, double* plat2, double* plon2, double* pazi2); /** * The general direct geodesic problem. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lat1 latitude of point 1 (degrees). * @param[in] lon1 longitude of point 1 (degrees). * @param[in] azi1 azimuth at point 1 (degrees). * @param[in] flags bitor'ed combination of geod_flags(); \e flags & * GEOD_ARCMODE determines the meaning of \e s12_a12 and \e flags & * GEOD_LONG_NOWRAP prevents the value of \e lon2 being wrapped into * the range [−180°, 180°). * @param[in] s12_a12 if \e flags & GEOD_ARCMODE is 0, this is the distance * between point 1 and point 2 (meters); otherwise it is the arc length * between point 1 and point 2 (degrees); it can be negative. * @param[out] plat2 pointer to the latitude of point 2 (degrees). * @param[out] plon2 pointer to the longitude of point 2 (degrees). * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * @param[out] ps12 pointer to the distance between point 1 and point 2 * (meters). * @param[out] pm12 pointer to the reduced length of geodesic (meters). * @param[out] pM12 pointer to the geodesic scale of point 2 relative to * point 1 (dimensionless). * @param[out] pM21 pointer to the geodesic scale of point 1 relative to * point 2 (dimensionless). * @param[out] pS12 pointer to the area under the geodesic * (meters2). * @return \e a12 arc length of between point 1 and point 2 (degrees). * * \e g must have been initialized with a call to geod_init(). \e lat1 * should be in the range [−90°, 90°]; \e lon1 and \e azi1 * should be in the range [−540°, 540°). The function * value \e a12 equals \e s12_a12 if \e flags & GEOD_ARCMODE. Any of the * "return" arguments \e plat2, etc., may be replaced by 0, if you do not * need some quantities computed. * * With \e flags & GEOD_LONG_NOWRAP bit set, the quantity \e lon2 − * \e lon1 indicates how many times the geodesic wrapped around the * ellipsoid. Because \e lon2 might be outside the normal allowed range * for longitudes, [−540°, 540°), be sure to normalize it, * e.g., with fmod(\e lon2, 360.0) before using it in subsequent * calculations **********************************************************************/ double geod_gendirect(const struct geod_geodesic* g, double lat1, double lon1, double azi1, unsigned flags, double s12_a12, double* plat2, double* plon2, double* pazi2, double* ps12, double* pm12, double* pM12, double* pM21, double* pS12); /** * The general inverse geodesic calculation. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lat1 latitude of point 1 (degrees). * @param[in] lon1 longitude of point 1 (degrees). * @param[in] lat2 latitude of point 2 (degrees). * @param[in] lon2 longitude of point 2 (degrees). * @param[out] ps12 pointer to the distance between point 1 and point 2 * (meters). * @param[out] pazi1 pointer to the azimuth at point 1 (degrees). * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * @param[out] pm12 pointer to the reduced length of geodesic (meters). * @param[out] pM12 pointer to the geodesic scale of point 2 relative to * point 1 (dimensionless). * @param[out] pM21 pointer to the geodesic scale of point 1 relative to * point 2 (dimensionless). * @param[out] pS12 pointer to the area under the geodesic * (meters2). * @return \e a12 arc length of between point 1 and point 2 (degrees). * * \e g must have been initialized with a call to geod_init(). \e lat1 * and \e lat2 should be in the range [−90°, 90°]; \e lon1 and * \e lon2 should be in the range [−540°, 540°). Any of the * "return" arguments \e ps12, etc., may be replaced by 0, if you do not need * some quantities computed. **********************************************************************/ double geod_geninverse(const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, double* ps12, double* pazi1, double* pazi2, double* pm12, double* pM12, double* pM21, double* pS12); /** * The general position function. * * @param[in] l a pointer to the geod_geodesicline object specifying the * geodesic line. * @param[in] flags bitor'ed combination of geod_flags(); \e flags & * GEOD_ARCMODE determines the meaning of \e s12_a12 and \e flags & * GEOD_LONG_NOWRAP prevents the value of \e lon2 being wrapped into * the range [−180°, 180°); if \e flags & GEOD_ARCMODE is * 0, then \e l must have been initialized with \e caps |= * GEOD_DISTANCE_IN. * @param[in] s12_a12 if \e flags & GEOD_ARCMODE is 0, this is the * distance between point 1 and point 2 (meters); otherwise it is the * arc length between point 1 and point 2 (degrees); it can be * negative. * @param[out] plat2 pointer to the latitude of point 2 (degrees). * @param[out] plon2 pointer to the longitude of point 2 (degrees); requires * that \e l was initialized with \e caps |= GEOD_LONGITUDE. * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * @param[out] ps12 pointer to the distance between point 1 and point 2 * (meters); requires that \e l was initialized with \e caps |= * GEOD_DISTANCE. * @param[out] pm12 pointer to the reduced length of geodesic (meters); * requires that \e l was initialized with \e caps |= GEOD_REDUCEDLENGTH. * @param[out] pM12 pointer to the geodesic scale of point 2 relative to * point 1 (dimensionless); requires that \e l was initialized with \e caps * |= GEOD_GEODESICSCALE. * @param[out] pM21 pointer to the geodesic scale of point 1 relative to * point 2 (dimensionless); requires that \e l was initialized with \e caps * |= GEOD_GEODESICSCALE. * @param[out] pS12 pointer to the area under the geodesic * (meters2); requires that \e l was initialized with \e caps |= * GEOD_AREA. * @return \e a12 arc length of between point 1 and point 2 (degrees). * * \e l must have been initialized with a call to geod_lineinit() with \e * caps |= GEOD_DISTANCE_IN. The value \e azi2 returned is in the range * [−180°, 180°). Any of the "return" arguments \e plat2, * etc., may be replaced by 0, if you do not need some quantities * computed. Requesting a value which \e l is not capable of computing * is not an error; the corresponding argument will not be altered. * * With \e flags & GEOD_LONG_NOWRAP bit set, the quantity \e lon2 − * \e lon1 indicates how many times the geodesic wrapped around the * ellipsoid. Because \e lon2 might be outside the normal allowed range * for longitudes, [−540°, 540°), be sure to normalize it, * e.g., with fmod(\e lon2, 360.0) before using it in subsequent * calculations * * Example, compute way points between JFK and Singapore Changi Airport * using geod_genposition(). In this example, the points are evenly space in * arc length (and so only approximately equally space in distance). This is * faster than using geod_position() would be appropriate if drawing the path * on a map. @code struct geod_geodesic g; struct geod_geodesicline l; double a12, azi1, lat[101], lon[101]; int i; geod_init(&g, 6378137, 1/298.257223563); a12 = geod_geninverse(&g, 40.64, -73.78, 1.36, 103.99, 0, &azi1, 0, 0, 0, 0, 0); geod_lineinit(&l, &g, 40.64, -73.78, azi1, GEOD_LATITUDE | GEOD_LONGITUDE); for (i = 0; i < 101; ++i) { geod_genposition(&l, 1, i * a12 * 0.01, lat + i, lon + i, 0, 0, 0, 0, 0, 0); printf("%.5f %.5f\n", lat[i], lon[i]); } @endcode **********************************************************************/ double geod_genposition(const struct geod_geodesicline* l, unsigned flags, double s12_a12, double* plat2, double* plon2, double* pazi2, double* ps12, double* pm12, double* pM12, double* pM21, double* pS12); /** * Initialize a geod_polygon object. * * @param[out] p a pointer to the object to be initialized. * @param[in] polylinep non-zero if a polyline instead of a polygon. * * If \e polylinep is zero, then the sequence of vertices and edges added by * geod_polygon_addpoint() and geod_polygon_addedge() define a polygon and * the perimeter and area are returned by geod_polygon_compute(). If \e * polylinep is non-zero, then the vertices and edges define a polyline and * only the perimeter is returned by geod_polygon_compute(). * * The area and perimeter are accumulated at two times the standard floating * point precision to guard against the loss of accuracy with many-sided * polygons. At any point you can ask for the perimeter and area so far. * * An example of the use of this function is given in the documentation for * geod_polygon_compute(). **********************************************************************/ void geod_polygon_init(struct geod_polygon* p, int polylinep); /** * Add a point to the polygon or polyline. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in,out] p a pointer to the geod_polygon object specifying the * polygon. * @param[in] lat the latitude of the point (degrees). * @param[in] lon the longitude of the point (degrees). * * \e g and \e p must have been initialized with calls to geod_init() and * geod_polygon_init(), respectively. The same \e g must be used for all the * points and edges in a polygon. \e lat should be in the range * [−90°, 90°] and \e lon should be in the range * [−540°, 540°). * * An example of the use of this function is given in the documentation for * geod_polygon_compute(). **********************************************************************/ void geod_polygon_addpoint(const struct geod_geodesic* g, struct geod_polygon* p, double lat, double lon); /** * Add an edge to the polygon or polyline. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in,out] p a pointer to the geod_polygon object specifying the * polygon. * @param[in] azi azimuth at current point (degrees). * @param[in] s distance from current point to next point (meters). * * \e g and \e p must have been initialized with calls to geod_init() and * geod_polygon_init(), respectively. The same \e g must be used for all the * points and edges in a polygon. \e azi should be in the range * [−540°, 540°). This does nothing if no points have been * added yet. The \e lat and \e lon fields of \e p give the location of * the new vertex. **********************************************************************/ void geod_polygon_addedge(const struct geod_geodesic* g, struct geod_polygon* p, double azi, double s); /** * Return the results for a polygon. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] p a pointer to the geod_polygon object specifying the polygon. * @param[in] reverse if non-zero then clockwise (instead of * counter-clockwise) traversal counts as a positive area. * @param[in] sign if non-zero then return a signed result for the area if * the polygon is traversed in the "wrong" direction instead of returning * the area for the rest of the earth. * @param[out] pA pointer to the area of the polygon (meters2); * only set if \e polyline is non-zero in the call to geod_polygon_init(). * @param[out] pP pointer to the perimeter of the polygon or length of the * polyline (meters). * @return the number of points. * * The area and perimeter are accumulated at two times the standard floating * point precision to guard against the loss of accuracy with many-sided * polygons. Only simple polygons (which are not self-intersecting) are * allowed. There's no need to "close" the polygon by repeating the first * vertex. Set \e pA or \e pP to zero, if you do not want the corresponding * quantity returned. * * Example, compute the perimeter and area of the geodesic triangle with * vertices (0°N,0°E), (0°N,90°E), (90°N,0°E). @code double A, P; int n; struct geod_geodesic g; struct geod_polygon p; geod_init(&g, 6378137, 1/298.257223563); geod_polygon_init(&p, 0); geod_polygon_addpoint(&g, &p, 0, 0); geod_polygon_addpoint(&g, &p, 0, 90); geod_polygon_addpoint(&g, &p, 90, 0); n = geod_polygon_compute(&g, &p, 0, 1, &A, &P); printf("%d %.8f %.3f\n", n, P, A); @endcode **********************************************************************/ unsigned geod_polygon_compute(const struct geod_geodesic* g, const struct geod_polygon* p, int reverse, int sign, double* pA, double* pP); /** * Return the results assuming a tentative final test point is added; * however, the data for the test point is not saved. This lets you report a * running result for the perimeter and area as the user moves the mouse * cursor. Ordinary floating point arithmetic is used to accumulate the data * for the test point; thus the area and perimeter returned are less accurate * than if geod_polygon_addpoint() and geod_polygon_compute() are used. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] p a pointer to the geod_polygon object specifying the polygon. * @param[in] lat the latitude of the test point (degrees). * @param[in] lon the longitude of the test point (degrees). * @param[in] reverse if non-zero then clockwise (instead of * counter-clockwise) traversal counts as a positive area. * @param[in] sign if non-zero then return a signed result for the area if * the polygon is traversed in the "wrong" direction instead of returning * the area for the rest of the earth. * @param[out] pA pointer to the area of the polygon (meters2); * only set if \e polyline is non-zero in the call to geod_polygon_init(). * @param[out] pP pointer to the perimeter of the polygon or length of the * polyline (meters). * @return the number of points. * * \e lat should be in the range [−90°, 90°] and \e * lon should be in the range [−540°, 540°). **********************************************************************/ unsigned geod_polygon_testpoint(const struct geod_geodesic* g, const struct geod_polygon* p, double lat, double lon, int reverse, int sign, double* pA, double* pP); /** * Return the results assuming a tentative final test point is added via an * azimuth and distance; however, the data for the test point is not saved. * This lets you report a running result for the perimeter and area as the * user moves the mouse cursor. Ordinary floating point arithmetic is used * to accumulate the data for the test point; thus the area and perimeter * returned are less accurate than if geod_polygon_addedge() and * geod_polygon_compute() are used. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] p a pointer to the geod_polygon object specifying the polygon. * @param[in] azi azimuth at current point (degrees). * @param[in] s distance from current point to final test point (meters). * @param[in] reverse if non-zero then clockwise (instead of * counter-clockwise) traversal counts as a positive area. * @param[in] sign if non-zero then return a signed result for the area if * the polygon is traversed in the "wrong" direction instead of returning * the area for the rest of the earth. * @param[out] pA pointer to the area of the polygon (meters2); * only set if \e polyline is non-zero in the call to geod_polygon_init(). * @param[out] pP pointer to the perimeter of the polygon or length of the * polyline (meters). * @return the number of points. * * \e azi should be in the range [−540°, 540°). **********************************************************************/ unsigned geod_polygon_testedge(const struct geod_geodesic* g, const struct geod_polygon* p, double azi, double s, int reverse, int sign, double* pA, double* pP); /** * A simple interface for computing the area of a geodesic polygon. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lats an array of latitudes of the polygon vertices (degrees). * @param[in] lons an array of longitudes of the polygon vertices (degrees). * @param[in] n the number of vertices. * @param[out] pA pointer to the area of the polygon (meters2). * @param[out] pP pointer to the perimeter of the polygon (meters). * * \e lats should be in the range [−90°, 90°]; \e lons should * be in the range [−540°, 540°). * * Only simple polygons (which are not self-intersecting) are allowed. * There's no need to "close" the polygon by repeating the first vertex. The * area returned is signed with counter-clockwise traversal being treated as * positive. * * Example, compute the area of Antarctica: @code double lats[] = {-72.9, -71.9, -74.9, -74.3, -77.5, -77.4, -71.7, -65.9, -65.7, -66.6, -66.9, -69.8, -70.0, -71.0, -77.3, -77.9, -74.7}, lons[] = {-74, -102, -102, -131, -163, 163, 172, 140, 113, 88, 59, 25, -4, -14, -33, -46, -61}; struct geod_geodesic g; double A, P; geod_init(&g, 6378137, 1/298.257223563); geod_polygonarea(&g, lats, lons, (sizeof lats) / (sizeof lats[0]), &A, &P); printf("%.0f %.2f\n", A, P); @endcode **********************************************************************/ void geod_polygonarea(const struct geod_geodesic* g, double lats[], double lons[], int n, double* pA, double* pP); /** * mask values for the \e caps argument to geod_lineinit(). **********************************************************************/ enum geod_mask { GEOD_NONE = 0U, /**< Calculate nothing */ GEOD_LATITUDE = 1U<<7 | 0U, /**< Calculate latitude */ GEOD_LONGITUDE = 1U<<8 | 1U<<3, /**< Calculate longitude */ GEOD_AZIMUTH = 1U<<9 | 0U, /**< Calculate azimuth */ GEOD_DISTANCE = 1U<<10 | 1U<<0, /**< Calculate distance */ GEOD_DISTANCE_IN = 1U<<11 | 1U<<0 | 1U<<1, /**< Allow distance as input */ GEOD_REDUCEDLENGTH= 1U<<12 | 1U<<0 | 1U<<2, /**< Calculate reduced length */ GEOD_GEODESICSCALE= 1U<<13 | 1U<<0 | 1U<<2, /**< Calculate geodesic scale */ GEOD_AREA = 1U<<14 | 1U<<4, /**< Calculate reduced length */ GEOD_ALL = 0x7F80U| 0x1FU /**< Calculate everything */ }; /** * flag values for the \e flags argument to geod_gendirect() and * geod_genposition() **********************************************************************/ enum geod_flags { GEOD_NOFLAGS = 0U, /**< No flags */ GEOD_ARCMODE = 1U<<0, /**< Position given in terms of arc distance */ GEOD_LONG_NOWRAP = 1U<<15 /**< Don't wrap longitude */ }; #if defined(__cplusplus) } #endif #endif raster/src/xyCell.cpp0000644000176200001440000001070514160021141014276 0ustar liggesusers#include using namespace Rcpp; //IntegerVector doCellFromXY( // integer can fail in R when .Machine$integer.max < ncell // [[Rcpp::export(name = ".doCellFromXY")]] NumericVector doCellFromXY( int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericVector x, NumericVector y) { size_t len = x.size(); double yres_inv = nrows / (ymax - ymin); double xres_inv = ncols / (xmax - xmin); //IntegerVector result(len); NumericVector result(len); for (size_t i = 0; i < len; i++) { // cannot use trunc here because trunc(-0.1) == 0 double row = floor((ymax - y[i]) * yres_inv); // points in between rows go to the row below // except for the last row, when they must go up if (y[i] == ymin) { row = nrows-1 ; } double col = floor((x[i] - xmin) * xres_inv); // as for rows above. Go right, except for last column if (x[i] == xmax) { col = ncols-1 ; } if (row < 0 || row >= nrows || col < 0 || col >= ncols) { result[i] = NA_REAL; } else { // result[i] = static_cast(row) * ncols + static_cast(col) + 1; result[i] = row * ncols + col + 1 ; } } return result; } // [[Rcpp::export(name = ".doXYFromCell")]] NumericMatrix doXYFromCell( unsigned ncols, unsigned nrows, double xmin, double xmax, double ymin, double ymax, NumericVector cell // IntegerVector cell ) { size_t len = cell.size(); double yres = (ymax - ymin) / nrows; double xres = (xmax - xmin) / ncols; NumericMatrix result(len, 2); for (size_t i = 0; i < len; i++) { // double in stead of int double c = cell[i] - 1; double row = floor(c / ncols); double col = c - row * ncols; result(i,0) = (col + 0.5) * xres + xmin; result(i,1) = ymax - (row + 0.5) * yres; } return result; } double oneBasedRowColToCellNum(int ncols, int row, int col) { return (row-1) * ncols + col; } // [[Rcpp::export(name = ".doFourCellsFromXY")]] NumericMatrix doFourCellsFromXY( int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericMatrix xy, bool duplicates, bool isGlobalLonLat ) { size_t len = xy.nrow(); double yres_inv = nrows / (ymax - ymin); double xres_inv = ncols / (xmax - xmin); NumericMatrix result(len, 4); for (size_t i = 0; i < len; i++) { // 1-based row and col. The 0.5 is because rows/cells are addressed by their // centers, not by their bottom/left edges. double row = (ymax - xy(i,1)) * yres_inv + 0.5; double col = (xy(i,0) - xmin) * xres_inv + 0.5; double roundRow = round(row); double roundCol = round(col); // Check for out-of-bounds. if (roundRow < 1 || roundRow > nrows || roundCol < 1 || roundCol > ncols) { result(i,0) = NA_REAL; result(i,1) = NA_REAL; result(i,2) = NA_REAL; result(i,3) = NA_REAL; continue; } // roundRow and roundCol are now the nearest row/col to x/y. // That gives us one corner. We will find the other corner by starting // at roundRow/roundCol and moving in the direction of row/col, stopping // at the next integral values. // >0 if row is greater than the nearest round row, 0 if equal double vertDir = row - roundRow; // >0 if col is greater than the nearest round col, 0 if equal double horizDir = col - roundCol; // If duplicates are not allowed, make sure vertDir and horizDir // are not 0 if (!duplicates) { if (vertDir == 0) vertDir = 1; if (horizDir == 0) horizDir = 1; } // roundRow and roundCol will be one corner; posRow and posCol will be // the other corner. Start out by moving left/right or up/down relative // to roundRow/roundCol. double posRow = roundRow + (vertDir > 0 ? 1 : vertDir < 0 ? -1 : 0); double posCol = roundCol + (horizDir > 0 ? 1 : horizDir < 0 ? -1 : 0); // Now, some fixups in case posCol/posRow go off the edge of the raster. if (isGlobalLonLat) { if (posCol < 1) { posCol = ncols; } else if (posCol > ncols) { posCol = 1; } } else { if (posCol < 1) { posCol = 2; } else if (posCol > ncols) { posCol = ncols - 1; } } if (posRow < 1) { posRow = 2; } else if (posRow > nrows) { posRow = nrows - 1; } // Fixups done--just store the results. result(i,0) = oneBasedRowColToCellNum(ncols, roundRow, roundCol); result(i,1) = oneBasedRowColToCellNum(ncols, posRow, roundCol); result(i,2) = oneBasedRowColToCellNum(ncols, posRow, posCol); result(i,3) = oneBasedRowColToCellNum(ncols, roundRow, posCol); } return result; } raster/src/raster_aggregate.cpp0000644000176200001440000000245614160021141016350 0ustar liggesusers#include #include "aggregate.h" Rcpp::NumericMatrix std2rcp( std::vector > x) { int nr = x.size(), nc = x[0].size() ; Rcpp::NumericMatrix m( nr, nc ) ; for( int i=0; i > rcp2std( Rcpp::NumericMatrix x) { size_t nr = x.nrow(), nc = x.ncol(); std::vector< std::vector > m(nr, std::vector(nc)); for( size_t i=0; i > x = rcp2std(d); std::vector y = Rcpp::as >(dims); y = get_dims(y); x = get_aggregates(x, y); Rcpp::NumericMatrix z = std2rcp(x); return(z); } // [[Rcpp::export(name = ".aggregate_fun")]] Rcpp::NumericMatrix aggregate_fun(Rcpp::NumericMatrix d, Rcpp::NumericVector dims, bool narm, int fun) { std::vector > x = rcp2std(d); std::vector y = Rcpp::as >(dims); y = get_dims(y); x = aggregate(x, y, narm, fun); Rcpp::NumericMatrix z = std2rcp(x); return(z); } raster/src/RcppExports.cpp0000644000176200001440000005543414160021141015337 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include using namespace Rcpp; // doBilinear NumericVector doBilinear(NumericMatrix xy, NumericMatrix x, NumericMatrix y, NumericMatrix v); RcppExport SEXP _raster_doBilinear(SEXP xySEXP, SEXP xSEXP, SEXP ySEXP, SEXP vSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type xy(xySEXP); Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type y(ySEXP); Rcpp::traits::input_parameter< NumericMatrix >::type v(vSEXP); rcpp_result_gen = Rcpp::wrap(doBilinear(xy, x, y, v)); return rcpp_result_gen; END_RCPP } // broom std::vector broom(std::vector d, std::vector f, std::vector dm, std::vector dist, bool down); RcppExport SEXP _raster_broom(SEXP dSEXP, SEXP fSEXP, SEXP dmSEXP, SEXP distSEXP, SEXP downSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type f(fSEXP); Rcpp::traits::input_parameter< std::vector >::type dm(dmSEXP); Rcpp::traits::input_parameter< std::vector >::type dist(distSEXP); Rcpp::traits::input_parameter< bool >::type down(downSEXP); rcpp_result_gen = Rcpp::wrap(broom(d, f, dm, dist, down)); return rcpp_result_gen; END_RCPP } // doCellFromRowCol NumericVector doCellFromRowCol(IntegerVector nrow, IntegerVector ncol, IntegerVector rownr, IntegerVector colnr); RcppExport SEXP _raster_doCellFromRowCol(SEXP nrowSEXP, SEXP ncolSEXP, SEXP rownrSEXP, SEXP colnrSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< IntegerVector >::type nrow(nrowSEXP); Rcpp::traits::input_parameter< IntegerVector >::type ncol(ncolSEXP); Rcpp::traits::input_parameter< IntegerVector >::type rownr(rownrSEXP); Rcpp::traits::input_parameter< IntegerVector >::type colnr(colnrSEXP); rcpp_result_gen = Rcpp::wrap(doCellFromRowCol(nrow, ncol, rownr, colnr)); return rcpp_result_gen; END_RCPP } // do_clamp Rcpp::NumericVector do_clamp(std::vector d, std::vector r, bool usevals); RcppExport SEXP _raster_do_clamp(SEXP dSEXP, SEXP rSEXP, SEXP usevalsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type r(rSEXP); Rcpp::traits::input_parameter< bool >::type usevals(usevalsSEXP); rcpp_result_gen = Rcpp::wrap(do_clamp(d, r, usevals)); return rcpp_result_gen; END_RCPP } // do_edge std::vector do_edge(std::vector d, std::vector dim, bool classes, bool edgetype, unsigned dirs); RcppExport SEXP _raster_do_edge(SEXP dSEXP, SEXP dimSEXP, SEXP classesSEXP, SEXP edgetypeSEXP, SEXP dirsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< bool >::type classes(classesSEXP); Rcpp::traits::input_parameter< bool >::type edgetype(edgetypeSEXP); Rcpp::traits::input_parameter< unsigned >::type dirs(dirsSEXP); rcpp_result_gen = Rcpp::wrap(do_edge(d, dim, classes, edgetype, dirs)); return rcpp_result_gen; END_RCPP } // do_focal_fun std::vector do_focal_fun(std::vector d, Rcpp::NumericMatrix w, std::vector dim, Rcpp::Function fun, bool naonly); RcppExport SEXP _raster_do_focal_fun(SEXP dSEXP, SEXP wSEXP, SEXP dimSEXP, SEXP funSEXP, SEXP naonlySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type w(wSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< Rcpp::Function >::type fun(funSEXP); Rcpp::traits::input_parameter< bool >::type naonly(naonlySEXP); rcpp_result_gen = Rcpp::wrap(do_focal_fun(d, w, dim, fun, naonly)); return rcpp_result_gen; END_RCPP } // do_focal_get std::vector do_focal_get(std::vector d, std::vector dim, std::vector ngb); RcppExport SEXP _raster_do_focal_get(SEXP dSEXP, SEXP dimSEXP, SEXP ngbSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< std::vector >::type ngb(ngbSEXP); rcpp_result_gen = Rcpp::wrap(do_focal_get(d, dim, ngb)); return rcpp_result_gen; END_RCPP } // do_focal_sum std::vector do_focal_sum(std::vector d, Rcpp::NumericMatrix w, std::vector dim, bool narm, bool naonly, bool bemean); RcppExport SEXP _raster_do_focal_sum(SEXP dSEXP, SEXP wSEXP, SEXP dimSEXP, SEXP narmSEXP, SEXP naonlySEXP, SEXP bemeanSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type w(wSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); Rcpp::traits::input_parameter< bool >::type naonly(naonlySEXP); Rcpp::traits::input_parameter< bool >::type bemean(bemeanSEXP); rcpp_result_gen = Rcpp::wrap(do_focal_sum(d, w, dim, narm, naonly, bemean)); return rcpp_result_gen; END_RCPP } // getPolygons NumericMatrix getPolygons(NumericMatrix xyv, NumericVector res, int nodes); RcppExport SEXP _raster_getPolygons(SEXP xyvSEXP, SEXP resSEXP, SEXP nodesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type xyv(xyvSEXP); Rcpp::traits::input_parameter< NumericVector >::type res(resSEXP); Rcpp::traits::input_parameter< int >::type nodes(nodesSEXP); rcpp_result_gen = Rcpp::wrap(getPolygons(xyv, res, nodes)); return rcpp_result_gen; END_RCPP } // layerize Rcpp::NumericVector layerize(std::vector d, std::vector cls, bool falsena); RcppExport SEXP _raster_layerize(SEXP dSEXP, SEXP clsSEXP, SEXP falsenaSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type cls(clsSEXP); Rcpp::traits::input_parameter< bool >::type falsena(falsenaSEXP); rcpp_result_gen = Rcpp::wrap(layerize(d, cls, falsena)); return rcpp_result_gen; END_RCPP } // availableRAM double availableRAM(double ram); RcppExport SEXP _raster_availableRAM(SEXP ramSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< double >::type ram(ramSEXP); rcpp_result_gen = Rcpp::wrap(availableRAM(ram)); return rcpp_result_gen; END_RCPP } // getMode double getMode(NumericVector values, int ties); RcppExport SEXP _raster_getMode(SEXP valuesSEXP, SEXP tiesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type values(valuesSEXP); Rcpp::traits::input_parameter< int >::type ties(tiesSEXP); rcpp_result_gen = Rcpp::wrap(getMode(values, ties)); return rcpp_result_gen; END_RCPP } // doSpmin NumericVector doSpmin(NumericVector x, NumericVector y); RcppExport SEXP _raster_doSpmin(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(doSpmin(x, y)); return rcpp_result_gen; END_RCPP } // doSpmax NumericVector doSpmax(NumericVector x, NumericVector y); RcppExport SEXP _raster_doSpmax(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(doSpmax(x, y)); return rcpp_result_gen; END_RCPP } // ppmin NumericVector ppmin(NumericVector x, NumericVector y, bool narm); RcppExport SEXP _raster_ppmin(SEXP xSEXP, SEXP ySEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(ppmin(x, y, narm)); return rcpp_result_gen; END_RCPP } // ppmax NumericVector ppmax(NumericVector x, NumericVector y, bool narm); RcppExport SEXP _raster_ppmax(SEXP xSEXP, SEXP ySEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(ppmax(x, y, narm)); return rcpp_result_gen; END_RCPP } // doRowMin NumericVector doRowMin(NumericMatrix x, bool narm); RcppExport SEXP _raster_doRowMin(SEXP xSEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(doRowMin(x, narm)); return rcpp_result_gen; END_RCPP } // doRowMax NumericVector doRowMax(NumericMatrix x, bool narm); RcppExport SEXP _raster_doRowMax(SEXP xSEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(doRowMax(x, narm)); return rcpp_result_gen; END_RCPP } // aggregate_get Rcpp::NumericMatrix aggregate_get(Rcpp::NumericMatrix d, Rcpp::NumericVector dims); RcppExport SEXP _raster_aggregate_get(SEXP dSEXP, SEXP dimsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericVector >::type dims(dimsSEXP); rcpp_result_gen = Rcpp::wrap(aggregate_get(d, dims)); return rcpp_result_gen; END_RCPP } // aggregate_fun Rcpp::NumericMatrix aggregate_fun(Rcpp::NumericMatrix d, Rcpp::NumericVector dims, bool narm, int fun); RcppExport SEXP _raster_aggregate_fun(SEXP dSEXP, SEXP dimsSEXP, SEXP narmSEXP, SEXP funSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericVector >::type dims(dimsSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); Rcpp::traits::input_parameter< int >::type fun(funSEXP); rcpp_result_gen = Rcpp::wrap(aggregate_fun(d, dims, narm, fun)); return rcpp_result_gen; END_RCPP } // get_area_polygon Rcpp::NumericVector get_area_polygon(Rcpp::NumericMatrix d, bool lonlat); RcppExport SEXP _raster_get_area_polygon(SEXP dSEXP, SEXP lonlatSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); rcpp_result_gen = Rcpp::wrap(get_area_polygon(d, lonlat)); return rcpp_result_gen; END_RCPP } // point_distance Rcpp::NumericVector point_distance(Rcpp::NumericMatrix p1, Rcpp::NumericMatrix p2, bool lonlat, double a, double f); RcppExport SEXP _raster_point_distance(SEXP p1SEXP, SEXP p2SEXP, SEXP lonlatSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p1(p1SEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p2(p2SEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(point_distance(p1, p2, lonlat, a, f)); return rcpp_result_gen; END_RCPP } // distanceToNearestPoint Rcpp::NumericVector distanceToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, double a, double f); RcppExport SEXP _raster_distanceToNearestPoint(SEXP dSEXP, SEXP pSEXP, SEXP lonlatSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p(pSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(distanceToNearestPoint(d, p, lonlat, a, f)); return rcpp_result_gen; END_RCPP } // directionToNearestPoint Rcpp::NumericVector directionToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, bool degrees, bool from, double a, double f); RcppExport SEXP _raster_directionToNearestPoint(SEXP dSEXP, SEXP pSEXP, SEXP lonlatSEXP, SEXP degreesSEXP, SEXP fromSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p(pSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< bool >::type degrees(degreesSEXP); Rcpp::traits::input_parameter< bool >::type from(fromSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(directionToNearestPoint(d, p, lonlat, degrees, from, a, f)); return rcpp_result_gen; END_RCPP } // dest_point Rcpp::NumericMatrix dest_point(Rcpp::NumericMatrix xybd, bool lonlat, double a, double f); RcppExport SEXP _raster_dest_point(SEXP xybdSEXP, SEXP lonlatSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type xybd(xybdSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(dest_point(xybd, lonlat, a, f)); return rcpp_result_gen; END_RCPP } // reclassify Rcpp::NumericVector reclassify(Rcpp::NumericVector d, Rcpp::NumericMatrix rcl, bool dolowest, bool doright, bool doleftright, bool NAonly, double NAval); RcppExport SEXP _raster_reclassify(SEXP dSEXP, SEXP rclSEXP, SEXP dolowestSEXP, SEXP dorightSEXP, SEXP doleftrightSEXP, SEXP NAonlySEXP, SEXP NAvalSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type rcl(rclSEXP); Rcpp::traits::input_parameter< bool >::type dolowest(dolowestSEXP); Rcpp::traits::input_parameter< bool >::type doright(dorightSEXP); Rcpp::traits::input_parameter< bool >::type doleftright(doleftrightSEXP); Rcpp::traits::input_parameter< bool >::type NAonly(NAonlySEXP); Rcpp::traits::input_parameter< double >::type NAval(NAvalSEXP); rcpp_result_gen = Rcpp::wrap(reclassify(d, rcl, dolowest, doright, doleftright, NAonly, NAval)); return rcpp_result_gen; END_RCPP } // do_terrains std::vector do_terrains(std::vector d, std::vector dim, std::vector res, int unit, std::vector option, bool geo, std::vector gy); RcppExport SEXP _raster_do_terrains(SEXP dSEXP, SEXP dimSEXP, SEXP resSEXP, SEXP unitSEXP, SEXP optionSEXP, SEXP geoSEXP, SEXP gySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< std::vector >::type res(resSEXP); Rcpp::traits::input_parameter< int >::type unit(unitSEXP); Rcpp::traits::input_parameter< std::vector >::type option(optionSEXP); Rcpp::traits::input_parameter< bool >::type geo(geoSEXP); Rcpp::traits::input_parameter< std::vector >::type gy(gySEXP); rcpp_result_gen = Rcpp::wrap(do_terrains(d, dim, res, unit, option, geo, gy)); return rcpp_result_gen; END_RCPP } // doCellFromXY NumericVector doCellFromXY(int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericVector x, NumericVector y); RcppExport SEXP _raster_doCellFromXY(SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP xminSEXP, SEXP xmaxSEXP, SEXP yminSEXP, SEXP ymaxSEXP, SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< int >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< int >::type nrows(nrowsSEXP); Rcpp::traits::input_parameter< double >::type xmin(xminSEXP); Rcpp::traits::input_parameter< double >::type xmax(xmaxSEXP); Rcpp::traits::input_parameter< double >::type ymin(yminSEXP); Rcpp::traits::input_parameter< double >::type ymax(ymaxSEXP); Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(doCellFromXY(ncols, nrows, xmin, xmax, ymin, ymax, x, y)); return rcpp_result_gen; END_RCPP } // doXYFromCell NumericMatrix doXYFromCell(unsigned ncols, unsigned nrows, double xmin, double xmax, double ymin, double ymax, NumericVector cell); RcppExport SEXP _raster_doXYFromCell(SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP xminSEXP, SEXP xmaxSEXP, SEXP yminSEXP, SEXP ymaxSEXP, SEXP cellSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< unsigned >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< unsigned >::type nrows(nrowsSEXP); Rcpp::traits::input_parameter< double >::type xmin(xminSEXP); Rcpp::traits::input_parameter< double >::type xmax(xmaxSEXP); Rcpp::traits::input_parameter< double >::type ymin(yminSEXP); Rcpp::traits::input_parameter< double >::type ymax(ymaxSEXP); Rcpp::traits::input_parameter< NumericVector >::type cell(cellSEXP); rcpp_result_gen = Rcpp::wrap(doXYFromCell(ncols, nrows, xmin, xmax, ymin, ymax, cell)); return rcpp_result_gen; END_RCPP } // doFourCellsFromXY NumericMatrix doFourCellsFromXY(int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericMatrix xy, bool duplicates, bool isGlobalLonLat); RcppExport SEXP _raster_doFourCellsFromXY(SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP xminSEXP, SEXP xmaxSEXP, SEXP yminSEXP, SEXP ymaxSEXP, SEXP xySEXP, SEXP duplicatesSEXP, SEXP isGlobalLonLatSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< int >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< int >::type nrows(nrowsSEXP); Rcpp::traits::input_parameter< double >::type xmin(xminSEXP); Rcpp::traits::input_parameter< double >::type xmax(xmaxSEXP); Rcpp::traits::input_parameter< double >::type ymin(yminSEXP); Rcpp::traits::input_parameter< double >::type ymax(ymaxSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type xy(xySEXP); Rcpp::traits::input_parameter< bool >::type duplicates(duplicatesSEXP); Rcpp::traits::input_parameter< bool >::type isGlobalLonLat(isGlobalLonLatSEXP); rcpp_result_gen = Rcpp::wrap(doFourCellsFromXY(ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat)); return rcpp_result_gen; END_RCPP } RcppExport SEXP _rcpp_module_boot_spmod(); static const R_CallMethodDef CallEntries[] = { {"_raster_doBilinear", (DL_FUNC) &_raster_doBilinear, 4}, {"_raster_broom", (DL_FUNC) &_raster_broom, 5}, {"_raster_doCellFromRowCol", (DL_FUNC) &_raster_doCellFromRowCol, 4}, {"_raster_do_clamp", (DL_FUNC) &_raster_do_clamp, 3}, {"_raster_do_edge", (DL_FUNC) &_raster_do_edge, 5}, {"_raster_do_focal_fun", (DL_FUNC) &_raster_do_focal_fun, 5}, {"_raster_do_focal_get", (DL_FUNC) &_raster_do_focal_get, 3}, {"_raster_do_focal_sum", (DL_FUNC) &_raster_do_focal_sum, 6}, {"_raster_getPolygons", (DL_FUNC) &_raster_getPolygons, 3}, {"_raster_layerize", (DL_FUNC) &_raster_layerize, 3}, {"_raster_availableRAM", (DL_FUNC) &_raster_availableRAM, 1}, {"_raster_getMode", (DL_FUNC) &_raster_getMode, 2}, {"_raster_doSpmin", (DL_FUNC) &_raster_doSpmin, 2}, {"_raster_doSpmax", (DL_FUNC) &_raster_doSpmax, 2}, {"_raster_ppmin", (DL_FUNC) &_raster_ppmin, 3}, {"_raster_ppmax", (DL_FUNC) &_raster_ppmax, 3}, {"_raster_doRowMin", (DL_FUNC) &_raster_doRowMin, 2}, {"_raster_doRowMax", (DL_FUNC) &_raster_doRowMax, 2}, {"_raster_aggregate_get", (DL_FUNC) &_raster_aggregate_get, 2}, {"_raster_aggregate_fun", (DL_FUNC) &_raster_aggregate_fun, 4}, {"_raster_get_area_polygon", (DL_FUNC) &_raster_get_area_polygon, 2}, {"_raster_point_distance", (DL_FUNC) &_raster_point_distance, 5}, {"_raster_distanceToNearestPoint", (DL_FUNC) &_raster_distanceToNearestPoint, 5}, {"_raster_directionToNearestPoint", (DL_FUNC) &_raster_directionToNearestPoint, 7}, {"_raster_dest_point", (DL_FUNC) &_raster_dest_point, 4}, {"_raster_reclassify", (DL_FUNC) &_raster_reclassify, 7}, {"_raster_do_terrains", (DL_FUNC) &_raster_do_terrains, 7}, {"_raster_doCellFromXY", (DL_FUNC) &_raster_doCellFromXY, 8}, {"_raster_doXYFromCell", (DL_FUNC) &_raster_doXYFromCell, 7}, {"_raster_doFourCellsFromXY", (DL_FUNC) &_raster_doFourCellsFromXY, 9}, {"_rcpp_module_boot_spmod", (DL_FUNC) &_rcpp_module_boot_spmod, 0}, {NULL, NULL, 0} }; RcppExport void R_init_raster(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } raster/src/geodesic.c0000644000176200001440000016750314160021141014271 0ustar liggesusers/** * \file geodesic.c * \brief Implementation of the geodesic routines in C * * For the full documentation see geodesic.h. **********************************************************************/ /** @cond SKIP */ /* * This is a C implementation of the geodesic algorithms described in * * C. F. F. Karney, * Algorithms for geodesics, * J. Geodesy 87, 43--55 (2013); * https://dx.doi.org/10.1007/s00190-012-0578-z * Addenda: http://geographiclib.sf.net/geod-addenda.html * * See the comments in geodesic.h for documentation. * * Copyright (c) Charles Karney (2012-2014) and licensed * under the MIT/X11 License. For more information, see * http://geographiclib.sourceforge.net/ */ #include "geodesic.h" #include #define GEOGRAPHICLIB_GEODESIC_ORDER 6 #define nC1 GEOGRAPHICLIB_GEODESIC_ORDER #define nC1p GEOGRAPHICLIB_GEODESIC_ORDER #define nC2 GEOGRAPHICLIB_GEODESIC_ORDER #define nA3 GEOGRAPHICLIB_GEODESIC_ORDER #define nA3x nA3 #define nC3 GEOGRAPHICLIB_GEODESIC_ORDER #define nC3x ((nC3 * (nC3 - 1)) / 2) #define nC4 GEOGRAPHICLIB_GEODESIC_ORDER #define nC4x ((nC4 * (nC4 + 1)) / 2) typedef double real; typedef int boolx; static unsigned init = 0; static const int FALSE = 0; static const int TRUE = 1; static unsigned digits, maxit1, maxit2; static real epsilon, realmin, pi, degree, NaN, tiny, tol0, tol1, tol2, tolb, xthresh; static void Init() { if (!init) { #if defined(__DBL_MANT_DIG__) digits = __DBL_MANT_DIG__; #else digits = 53; #endif #if defined(__DBL_EPSILON__) epsilon = __DBL_EPSILON__; #else epsilon = pow(0.5, digits - 1); #endif #if defined(__DBL_MIN__) realmin = __DBL_MIN__; #else realmin = pow(0.5, 1022); #endif #if defined(M_PI) pi = M_PI; #else pi = atan2(0.0, -1.0); #endif maxit1 = 20; maxit2 = maxit1 + digits + 10; tiny = sqrt(realmin); tol0 = epsilon; /* Increase multiplier in defn of tol1 from 100 to 200 to fix inverse case * 52.784459512564 0 -52.784459512563990912 179.634407464943777557 * which otherwise failed for Visual Studio 10 (Release and Debug) */ tol1 = 200 * tol0; tol2 = sqrt(tol0); /* Check on bisection interval */ tolb = tol0 * tol2; xthresh = 1000 * tol2; degree = pi/180; NaN = sqrt(-1.0); init = 1; } } enum captype { CAP_NONE = 0U, CAP_C1 = 1U<<0, CAP_C1p = 1U<<1, CAP_C2 = 1U<<2, CAP_C3 = 1U<<3, CAP_C4 = 1U<<4, CAP_ALL = 0x1FU, OUT_ALL = 0x7F80U }; static real sq(real x) { return x * x; } static real log1px(real x) { volatile real y = 1 + x, z = y - 1; /* Here's the explanation for this magic: y = 1 + z, exactly, and z * approx x, thus log(y)/z (which is nearly constant near z = 0) returns * a good approximation to the true log(1 + x)/x. The multiplication x * * (log(y)/z) introduces little additional error. */ return z == 0 ? x : x * log(y) / z; } static real atanhx(real x) { real y = fabs(x); /* Enforce odd parity */ y = log1px(2 * y/(1 - y))/2; return x < 0 ? -y : y; } static real hypotx(real x, real y) { return sqrt(x * x + y * y); } static real cbrtx(real x) { real y = pow(fabs(x), 1/(real)(3)); /* Return the real cube root */ return x < 0 ? -y : y; } static real sumx(real u, real v, real* t) { volatile real s = u + v; volatile real up = s - v; volatile real vpp = s - up; up -= u; vpp -= v; *t = -(up + vpp); /* error-free sum: * u + v = s + t * = round(u + v) + t */ return s; } static real minx(real x, real y) { return x < y ? x : y; } static real maxx(real x, real y) { return x > y ? x : y; } static void swapx(real* x, real* y) { real t = *x; *x = *y; *y = t; } static void SinCosNorm(real* sinx, real* cosx) { real r = hypotx(*sinx, *cosx); *sinx /= r; *cosx /= r; } static real AngNormalize(real x) { return x >= 180 ? x - 360 : (x < -180 ? x + 360 : x); } static real AngNormalize2(real x) { return AngNormalize(fmod(x, (real)(360))); } static real AngDiff(real x, real y) { real t, d = sumx(-x, y, &t); if ((d - (real)(180)) + t > (real)(0)) /* y - x > 180 */ d -= (real)(360); /* exact */ else if ((d + (real)(180)) + t <= (real)(0)) /* y - x <= -180 */ d += (real)(360); /* exact */ return d + t; } static real AngRound(real x) { const real z = 1/(real)(16); volatile real y = fabs(x); /* The compiler mustn't "simplify" z - (z - y) to y */ y = y < z ? z - (z - y) : y; return x < 0 ? -y : y; } static void A3coeff(struct geod_geodesic* g); static void C3coeff(struct geod_geodesic* g); static void C4coeff(struct geod_geodesic* g); static real SinCosSeries(boolx sinp, real sinx, real cosx, const real c[], int n); static void Lengths(const struct geod_geodesic* g, real eps, real sig12, real ssig1, real csig1, real dn1, real ssig2, real csig2, real dn2, real cbet1, real cbet2, real* ps12b, real* pm12b, real* pm0, boolx scalep, real* pM12, real* pM21, /* Scratch areas of the right size */ real C1a[], real C2a[]); static real Astroid(real x, real y); static real InverseStart(const struct geod_geodesic* g, real sbet1, real cbet1, real dn1, real sbet2, real cbet2, real dn2, real lam12, real* psalp1, real* pcalp1, /* Only updated if return val >= 0 */ real* psalp2, real* pcalp2, /* Only updated for short lines */ real* pdnm, /* Scratch areas of the right size */ real C1a[], real C2a[]); static real Lambda12(const struct geod_geodesic* g, real sbet1, real cbet1, real dn1, real sbet2, real cbet2, real dn2, real salp1, real calp1, real* psalp2, real* pcalp2, real* psig12, real* pssig1, real* pcsig1, real* pssig2, real* pcsig2, real* peps, real* pdomg12, boolx diffp, real* pdlam12, /* Scratch areas of the right size */ real C1a[], real C2a[], real C3a[]); static real A3f(const struct geod_geodesic* g, real eps); static void C3f(const struct geod_geodesic* g, real eps, real c[]); static void C4f(const struct geod_geodesic* g, real eps, real c[]); static real A1m1f(real eps); static void C1f(real eps, real c[]); static void C1pf(real eps, real c[]); static real A2m1f(real eps); static void C2f(real eps, real c[]); static int transit(real lon1, real lon2); static int transitdirect(real lon1, real lon2); static void accini(real s[]); static void acccopy(const real s[], real t[]); static void accadd(real s[], real y); static real accsum(const real s[], real y); static void accneg(real s[]); void geod_init(struct geod_geodesic* g, real a, real f) { if (!init) Init(); g->a = a; g->f = f <= 1 ? f : 1/f; g->f1 = 1 - g->f; g->e2 = g->f * (2 - g->f); g->ep2 = g->e2 / sq(g->f1); /* e2 / (1 - e2) */ g->n = g->f / ( 2 - g->f); g->b = g->a * g->f1; g->c2 = (sq(g->a) + sq(g->b) * (g->e2 == 0 ? 1 : (g->e2 > 0 ? atanhx(sqrt(g->e2)) : atan(sqrt(-g->e2))) / sqrt(fabs(g->e2))))/2; /* authalic radius squared */ /* The sig12 threshold for "really short". Using the auxiliary sphere * solution with dnm computed at (bet1 + bet2) / 2, the relative error in the * azimuth consistency check is sig12^2 * abs(f) * min(1, 1-f/2) / 2. (Error * measured for 1/100 < b/a < 100 and abs(f) >= 1/1000. For a given f and * sig12, the max error occurs for lines near the pole. If the old rule for * computing dnm = (dn1 + dn2)/2 is used, then the error increases by a * factor of 2.) Setting this equal to epsilon gives sig12 = etol2. Here * 0.1 is a safety factor (error decreased by 100) and max(0.001, abs(f)) * stops etol2 getting too large in the nearly spherical case. */ g->etol2 = 0.1 * tol2 / sqrt( maxx((real)(0.001), fabs(g->f)) * minx((real)(1), 1 - g->f/2) / 2 ); A3coeff(g); C3coeff(g); C4coeff(g); } void geod_lineinit(struct geod_geodesicline* l, const struct geod_geodesic* g, real lat1, real lon1, real azi1, unsigned caps) { real alp1, cbet1, sbet1, phi, eps; l->a = g->a; l->f = g->f; l->b = g->b; l->c2 = g->c2; l->f1 = g->f1; /* If caps is 0 assume the standard direct calculation */ l->caps = (caps ? caps : GEOD_DISTANCE_IN | GEOD_LONGITUDE) | GEOD_LATITUDE | GEOD_AZIMUTH; /* Always allow latitude and azimuth */ l->lat1 = lat1; l->lon1 = lon1; /* Guard against underflow in salp0 */ l->azi1 = AngRound(AngNormalize(azi1)); /* alp1 is in [0, pi] */ alp1 = l->azi1 * degree; /* Enforce sin(pi) == 0 and cos(pi/2) == 0. Better to face the ensuing * problems directly than to skirt them. */ l->salp1 = l->azi1 == -180 ? 0 : sin(alp1); l->calp1 = fabs(l->azi1) == 90 ? 0 : cos(alp1); phi = lat1 * degree; /* Ensure cbet1 = +epsilon at poles */ sbet1 = l->f1 * sin(phi); cbet1 = fabs(lat1) == 90 ? tiny : cos(phi); SinCosNorm(&sbet1, &cbet1); l->dn1 = sqrt(1 + g->ep2 * sq(sbet1)); /* Evaluate alp0 from sin(alp1) * cos(bet1) = sin(alp0), */ l->salp0 = l->salp1 * cbet1; /* alp0 in [0, pi/2 - |bet1|] */ /* Alt: calp0 = hypot(sbet1, calp1 * cbet1). The following * is slightly better (consider the case salp1 = 0). */ l->calp0 = hypotx(l->calp1, l->salp1 * sbet1); /* Evaluate sig with tan(bet1) = tan(sig1) * cos(alp1). * sig = 0 is nearest northward crossing of equator. * With bet1 = 0, alp1 = pi/2, we have sig1 = 0 (equatorial line). * With bet1 = pi/2, alp1 = -pi, sig1 = pi/2 * With bet1 = -pi/2, alp1 = 0 , sig1 = -pi/2 * Evaluate omg1 with tan(omg1) = sin(alp0) * tan(sig1). * With alp0 in (0, pi/2], quadrants for sig and omg coincide. * No atan2(0,0) ambiguity at poles since cbet1 = +epsilon. * With alp0 = 0, omg1 = 0 for alp1 = 0, omg1 = pi for alp1 = pi. */ l->ssig1 = sbet1; l->somg1 = l->salp0 * sbet1; l->csig1 = l->comg1 = sbet1 != 0 || l->calp1 != 0 ? cbet1 * l->calp1 : 1; SinCosNorm(&l->ssig1, &l->csig1); /* sig1 in (-pi, pi] */ /* SinCosNorm(somg1, comg1); -- don't need to normalize! */ l->k2 = sq(l->calp0) * g->ep2; eps = l->k2 / (2 * (1 + sqrt(1 + l->k2)) + l->k2); if (l->caps & CAP_C1) { real s, c; l->A1m1 = A1m1f(eps); C1f(eps, l->C1a); l->B11 = SinCosSeries(TRUE, l->ssig1, l->csig1, l->C1a, nC1); s = sin(l->B11); c = cos(l->B11); /* tau1 = sig1 + B11 */ l->stau1 = l->ssig1 * c + l->csig1 * s; l->ctau1 = l->csig1 * c - l->ssig1 * s; /* Not necessary because C1pa reverts C1a * B11 = -SinCosSeries(TRUE, stau1, ctau1, C1pa, nC1p); */ } if (l->caps & CAP_C1p) C1pf(eps, l->C1pa); if (l->caps & CAP_C2) { l->A2m1 = A2m1f(eps); C2f(eps, l->C2a); l->B21 = SinCosSeries(TRUE, l->ssig1, l->csig1, l->C2a, nC2); } if (l->caps & CAP_C3) { C3f(g, eps, l->C3a); l->A3c = -l->f * l->salp0 * A3f(g, eps); l->B31 = SinCosSeries(TRUE, l->ssig1, l->csig1, l->C3a, nC3-1); } if (l->caps & CAP_C4) { C4f(g, eps, l->C4a); /* Multiplier = a^2 * e^2 * cos(alpha0) * sin(alpha0) */ l->A4 = sq(l->a) * l->calp0 * l->salp0 * g->e2; l->B41 = SinCosSeries(FALSE, l->ssig1, l->csig1, l->C4a, nC4); } } real geod_genposition(const struct geod_geodesicline* l, unsigned flags, real s12_a12, real* plat2, real* plon2, real* pazi2, real* ps12, real* pm12, real* pM12, real* pM21, real* pS12) { real lat2 = 0, lon2 = 0, azi2 = 0, s12 = 0, m12 = 0, M12 = 0, M21 = 0, S12 = 0; /* Avoid warning about uninitialized B12. */ real sig12, ssig12, csig12, B12 = 0, AB1 = 0; real omg12, lam12, lon12; real ssig2, csig2, sbet2, cbet2, somg2, comg2, salp2, calp2, dn2; unsigned outmask = (plat2 ? GEOD_LATITUDE : 0U) | (plon2 ? GEOD_LONGITUDE : 0U) | (pazi2 ? GEOD_AZIMUTH : 0U) | (ps12 ? GEOD_DISTANCE : 0U) | (pm12 ? GEOD_REDUCEDLENGTH : 0U) | (pM12 || pM21 ? GEOD_GEODESICSCALE : 0U) | (pS12 ? GEOD_AREA : 0U); outmask &= l->caps & OUT_ALL; if (!( TRUE /*Init()*/ && (flags & GEOD_ARCMODE || (l->caps & GEOD_DISTANCE_IN & OUT_ALL)) )) /* Uninitialized or impossible distance calculation requested */ return NaN; if (flags & GEOD_ARCMODE) { real s12a; /* Interpret s12_a12 as spherical arc length */ sig12 = s12_a12 * degree; s12a = fabs(s12_a12); s12a -= 180 * floor(s12a / 180); ssig12 = s12a == 0 ? 0 : sin(sig12); csig12 = s12a == 90 ? 0 : cos(sig12); } else { /* Interpret s12_a12 as distance */ real tau12 = s12_a12 / (l->b * (1 + l->A1m1)), s = sin(tau12), c = cos(tau12); /* tau2 = tau1 + tau12 */ B12 = - SinCosSeries(TRUE, l->stau1 * c + l->ctau1 * s, l->ctau1 * c - l->stau1 * s, l->C1pa, nC1p); sig12 = tau12 - (B12 - l->B11); ssig12 = sin(sig12); csig12 = cos(sig12); if (fabs(l->f) > 0.01) { /* Reverted distance series is inaccurate for |f| > 1/100, so correct * sig12 with 1 Newton iteration. The following table shows the * approximate maximum error for a = WGS_a() and various f relative to * GeodesicExact. * erri = the error in the inverse solution (nm) * errd = the error in the direct solution (series only) (nm) * errda = the error in the direct solution (series + 1 Newton) (nm) * * f erri errd errda * -1/5 12e6 1.2e9 69e6 * -1/10 123e3 12e6 765e3 * -1/20 1110 108e3 7155 * -1/50 18.63 200.9 27.12 * -1/100 18.63 23.78 23.37 * -1/150 18.63 21.05 20.26 * 1/150 22.35 24.73 25.83 * 1/100 22.35 25.03 25.31 * 1/50 29.80 231.9 30.44 * 1/20 5376 146e3 10e3 * 1/10 829e3 22e6 1.5e6 * 1/5 157e6 3.8e9 280e6 */ real ssig2 = l->ssig1 * csig12 + l->csig1 * ssig12, csig2 = l->csig1 * csig12 - l->ssig1 * ssig12, serr; B12 = SinCosSeries(TRUE, ssig2, csig2, l->C1a, nC1); serr = (1 + l->A1m1) * (sig12 + (B12 - l->B11)) - s12_a12 / l->b; sig12 = sig12 - serr / sqrt(1 + l->k2 * sq(ssig2)); ssig12 = sin(sig12); csig12 = cos(sig12); /* Update B12 below */ } } /* sig2 = sig1 + sig12 */ ssig2 = l->ssig1 * csig12 + l->csig1 * ssig12; csig2 = l->csig1 * csig12 - l->ssig1 * ssig12; dn2 = sqrt(1 + l->k2 * sq(ssig2)); if (outmask & (GEOD_DISTANCE | GEOD_REDUCEDLENGTH | GEOD_GEODESICSCALE)) { if (flags & GEOD_ARCMODE || fabs(l->f) > 0.01) B12 = SinCosSeries(TRUE, ssig2, csig2, l->C1a, nC1); AB1 = (1 + l->A1m1) * (B12 - l->B11); } /* sin(bet2) = cos(alp0) * sin(sig2) */ sbet2 = l->calp0 * ssig2; /* Alt: cbet2 = hypot(csig2, salp0 * ssig2); */ cbet2 = hypotx(l->salp0, l->calp0 * csig2); if (cbet2 == 0) /* I.e., salp0 = 0, csig2 = 0. Break the degeneracy in this case */ cbet2 = csig2 = tiny; /* tan(alp0) = cos(sig2)*tan(alp2) */ salp2 = l->salp0; calp2 = l->calp0 * csig2; /* No need to normalize */ if (outmask & GEOD_DISTANCE) s12 = flags & GEOD_ARCMODE ? l->b * ((1 + l->A1m1) * sig12 + AB1) : s12_a12; if (outmask & GEOD_LONGITUDE) { /* tan(omg2) = sin(alp0) * tan(sig2) */ somg2 = l->salp0 * ssig2; comg2 = csig2; /* No need to normalize */ /* omg12 = omg2 - omg1 */ omg12 = flags & GEOD_LONG_NOWRAP ? sig12 - (atan2(ssig2, csig2) - atan2(l->ssig1, l->csig1)) + (atan2(somg2, comg2) - atan2(l->somg1, l->comg1)) : atan2(somg2 * l->comg1 - comg2 * l->somg1, comg2 * l->comg1 + somg2 * l->somg1); lam12 = omg12 + l->A3c * ( sig12 + (SinCosSeries(TRUE, ssig2, csig2, l->C3a, nC3-1) - l->B31)); lon12 = lam12 / degree; /* Use AngNormalize2 because longitude might have wrapped multiple * times. */ lon2 = flags & GEOD_LONG_NOWRAP ? l->lon1 + lon12 : AngNormalize(AngNormalize(l->lon1) + AngNormalize2(lon12)); } if (outmask & GEOD_LATITUDE) lat2 = atan2(sbet2, l->f1 * cbet2) / degree; if (outmask & GEOD_AZIMUTH) /* minus signs give range [-180, 180). 0- converts -0 to +0. */ azi2 = 0 - atan2(-salp2, calp2) / degree; if (outmask & (GEOD_REDUCEDLENGTH | GEOD_GEODESICSCALE)) { real B22 = SinCosSeries(TRUE, ssig2, csig2, l->C2a, nC2), AB2 = (1 + l->A2m1) * (B22 - l->B21), J12 = (l->A1m1 - l->A2m1) * sig12 + (AB1 - AB2); if (outmask & GEOD_REDUCEDLENGTH) /* Add parens around (csig1 * ssig2) and (ssig1 * csig2) to ensure * accurate cancellation in the case of coincident points. */ m12 = l->b * ((dn2 * (l->csig1 * ssig2) - l->dn1 * (l->ssig1 * csig2)) - l->csig1 * csig2 * J12); if (outmask & GEOD_GEODESICSCALE) { real t = l->k2 * (ssig2 - l->ssig1) * (ssig2 + l->ssig1) / (l->dn1 + dn2); M12 = csig12 + (t * ssig2 - csig2 * J12) * l->ssig1 / l->dn1; M21 = csig12 - (t * l->ssig1 - l->csig1 * J12) * ssig2 / dn2; } } if (outmask & GEOD_AREA) { real B42 = SinCosSeries(FALSE, ssig2, csig2, l->C4a, nC4); real salp12, calp12; if (l->calp0 == 0 || l->salp0 == 0) { /* alp12 = alp2 - alp1, used in atan2 so no need to normalized */ salp12 = salp2 * l->calp1 - calp2 * l->salp1; calp12 = calp2 * l->calp1 + salp2 * l->salp1; /* The right thing appears to happen if alp1 = +/-180 and alp2 = 0, viz * salp12 = -0 and alp12 = -180. However this depends on the sign being * attached to 0 correctly. The following ensures the correct * behavior. */ if (salp12 == 0 && calp12 < 0) { salp12 = tiny * l->calp1; calp12 = -1; } } else { /* tan(alp) = tan(alp0) * sec(sig) * tan(alp2-alp1) = (tan(alp2) -tan(alp1)) / (tan(alp2)*tan(alp1)+1) * = calp0 * salp0 * (csig1-csig2) / (salp0^2 + calp0^2 * csig1*csig2) * If csig12 > 0, write * csig1 - csig2 = ssig12 * (csig1 * ssig12 / (1 + csig12) + ssig1) * else * csig1 - csig2 = csig1 * (1 - csig12) + ssig12 * ssig1 * No need to normalize */ salp12 = l->calp0 * l->salp0 * (csig12 <= 0 ? l->csig1 * (1 - csig12) + ssig12 * l->ssig1 : ssig12 * (l->csig1 * ssig12 / (1 + csig12) + l->ssig1)); calp12 = sq(l->salp0) + sq(l->calp0) * l->csig1 * csig2; } S12 = l->c2 * atan2(salp12, calp12) + l->A4 * (B42 - l->B41); } if (outmask & GEOD_LATITUDE) *plat2 = lat2; if (outmask & GEOD_LONGITUDE) *plon2 = lon2; if (outmask & GEOD_AZIMUTH) *pazi2 = azi2; if (outmask & GEOD_DISTANCE) *ps12 = s12; if (outmask & GEOD_REDUCEDLENGTH) *pm12 = m12; if (outmask & GEOD_GEODESICSCALE) { if (pM12) *pM12 = M12; if (pM21) *pM21 = M21; } if (outmask & GEOD_AREA) *pS12 = S12; return flags & GEOD_ARCMODE ? s12_a12 : sig12 / degree; } void geod_position(const struct geod_geodesicline* l, real s12, real* plat2, real* plon2, real* pazi2) { geod_genposition(l, FALSE, s12, plat2, plon2, pazi2, 0, 0, 0, 0, 0); } real geod_gendirect(const struct geod_geodesic* g, real lat1, real lon1, real azi1, unsigned flags, real s12_a12, real* plat2, real* plon2, real* pazi2, real* ps12, real* pm12, real* pM12, real* pM21, real* pS12) { struct geod_geodesicline l; unsigned outmask = (plat2 ? GEOD_LATITUDE : 0U) | (plon2 ? GEOD_LONGITUDE : 0U) | (pazi2 ? GEOD_AZIMUTH : 0U) | (ps12 ? GEOD_DISTANCE : 0U) | (pm12 ? GEOD_REDUCEDLENGTH : 0U) | (pM12 || pM21 ? GEOD_GEODESICSCALE : 0U) | (pS12 ? GEOD_AREA : 0U); geod_lineinit(&l, g, lat1, lon1, azi1, /* Automatically supply GEOD_DISTANCE_IN if necessary */ outmask | (flags & GEOD_ARCMODE ? GEOD_NONE : GEOD_DISTANCE_IN)); return geod_genposition(&l, flags, s12_a12, plat2, plon2, pazi2, ps12, pm12, pM12, pM21, pS12); } void geod_direct(const struct geod_geodesic* g, real lat1, real lon1, real azi1, real s12, real* plat2, real* plon2, real* pazi2) { geod_gendirect(g, lat1, lon1, azi1, GEOD_NOFLAGS, s12, plat2, plon2, pazi2, 0, 0, 0, 0, 0); } real geod_geninverse(const struct geod_geodesic* g, real lat1, real lon1, real lat2, real lon2, real* ps12, real* pazi1, real* pazi2, real* pm12, real* pM12, real* pM21, real* pS12) { real s12 = 0, azi1 = 0, azi2 = 0, m12 = 0, M12 = 0, M21 = 0, S12 = 0; real lon12; int latsign, lonsign, swapp; real phi, sbet1, cbet1, sbet2, cbet2, s12x = 0, m12x = 0; real dn1, dn2, lam12, slam12, clam12; real a12 = 0, sig12, calp1 = 0, salp1 = 0, calp2 = 0, salp2 = 0; /* index zero elements of these arrays are unused */ real C1a[nC1 + 1], C2a[nC2 + 1], C3a[nC3]; boolx meridian; real omg12 = 0; unsigned outmask = (ps12 ? GEOD_DISTANCE : 0U) | (pazi1 || pazi2 ? GEOD_AZIMUTH : 0U) | (pm12 ? GEOD_REDUCEDLENGTH : 0U) | (pM12 || pM21 ? GEOD_GEODESICSCALE : 0U) | (pS12 ? GEOD_AREA : 0U); outmask &= OUT_ALL; /* Compute longitude difference (AngDiff does this carefully). Result is * in [-180, 180] but -180 is only for west-going geodesics. 180 is for * east-going and meridional geodesics. */ lon12 = AngDiff(AngNormalize(lon1), AngNormalize(lon2)); /* If very close to being on the same half-meridian, then make it so. */ lon12 = AngRound(lon12); /* Make longitude difference positive. */ lonsign = lon12 >= 0 ? 1 : -1; lon12 *= lonsign; /* If really close to the equator, treat as on equator. */ lat1 = AngRound(lat1); lat2 = AngRound(lat2); /* Swap points so that point with higher (abs) latitude is point 1 */ swapp = fabs(lat1) >= fabs(lat2) ? 1 : -1; if (swapp < 0) { lonsign *= -1; swapx(&lat1, &lat2); } /* Make lat1 <= 0 */ latsign = lat1 < 0 ? 1 : -1; lat1 *= latsign; lat2 *= latsign; /* Now we have * * 0 <= lon12 <= 180 * -90 <= lat1 <= 0 * lat1 <= lat2 <= -lat1 * * longsign, swapp, latsign register the transformation to bring the * coordinates to this canonical form. In all cases, 1 means no change was * made. We make these transformations so that there are few cases to * check, e.g., on verifying quadrants in atan2. In addition, this * enforces some symmetries in the results returned. */ phi = lat1 * degree; /* Ensure cbet1 = +epsilon at poles */ sbet1 = g->f1 * sin(phi); cbet1 = lat1 == -90 ? tiny : cos(phi); SinCosNorm(&sbet1, &cbet1); phi = lat2 * degree; /* Ensure cbet2 = +epsilon at poles */ sbet2 = g->f1 * sin(phi); cbet2 = fabs(lat2) == 90 ? tiny : cos(phi); SinCosNorm(&sbet2, &cbet2); /* If cbet1 < -sbet1, then cbet2 - cbet1 is a sensitive measure of the * |bet1| - |bet2|. Alternatively (cbet1 >= -sbet1), abs(sbet2) + sbet1 is * a better measure. This logic is used in assigning calp2 in Lambda12. * Sometimes these quantities vanish and in that case we force bet2 = +/- * bet1 exactly. An example where is is necessary is the inverse problem * 48.522876735459 0 -48.52287673545898293 179.599720456223079643 * which failed with Visual Studio 10 (Release and Debug) */ if (cbet1 < -sbet1) { if (cbet2 == cbet1) sbet2 = sbet2 < 0 ? sbet1 : -sbet1; } else { if (fabs(sbet2) == -sbet1) cbet2 = cbet1; } dn1 = sqrt(1 + g->ep2 * sq(sbet1)); dn2 = sqrt(1 + g->ep2 * sq(sbet2)); lam12 = lon12 * degree; slam12 = lon12 == 180 ? 0 : sin(lam12); clam12 = cos(lam12); /* lon12 == 90 isn't interesting */ meridian = lat1 == -90 || slam12 == 0; if (meridian) { /* Endpoints are on a single full meridian, so the geodesic might lie on * a meridian. */ real ssig1, csig1, ssig2, csig2; calp1 = clam12; salp1 = slam12; /* Head to the target longitude */ calp2 = 1; salp2 = 0; /* At the target we're heading north */ /* tan(bet) = tan(sig) * cos(alp) */ ssig1 = sbet1; csig1 = calp1 * cbet1; ssig2 = sbet2; csig2 = calp2 * cbet2; /* sig12 = sig2 - sig1 */ sig12 = atan2(maxx(csig1 * ssig2 - ssig1 * csig2, (real)(0)), csig1 * csig2 + ssig1 * ssig2); { real dummy; Lengths(g, g->n, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2, cbet1, cbet2, &s12x, &m12x, &dummy, (outmask & GEOD_GEODESICSCALE) != 0U, &M12, &M21, C1a, C2a); } /* Add the check for sig12 since zero length geodesics might yield m12 < * 0. Test case was * * echo 20.001 0 20.001 0 | GeodSolve -i * * In fact, we will have sig12 > pi/2 for meridional geodesic which is * not a shortest path. */ if (sig12 < 1 || m12x >= 0) { m12x *= g->b; s12x *= g->b; a12 = sig12 / degree; } else /* m12 < 0, i.e., prolate and too close to anti-podal */ meridian = FALSE; } if (!meridian && sbet1 == 0 && /* and sbet2 == 0 */ /* Mimic the way Lambda12 works with calp1 = 0 */ (g->f <= 0 || lam12 <= pi - g->f * pi)) { /* Geodesic runs along equator */ calp1 = calp2 = 0; salp1 = salp2 = 1; s12x = g->a * lam12; sig12 = omg12 = lam12 / g->f1; m12x = g->b * sin(sig12); if (outmask & GEOD_GEODESICSCALE) M12 = M21 = cos(sig12); a12 = lon12 / g->f1; } else if (!meridian) { /* Now point1 and point2 belong within a hemisphere bounded by a * meridian and geodesic is neither meridional or equatorial. */ /* Figure a starting point for Newton's method */ real dnm = 0; sig12 = InverseStart(g, sbet1, cbet1, dn1, sbet2, cbet2, dn2, lam12, &salp1, &calp1, &salp2, &calp2, &dnm, C1a, C2a); if (sig12 >= 0) { /* Short lines (InverseStart sets salp2, calp2, dnm) */ s12x = sig12 * g->b * dnm; m12x = sq(dnm) * g->b * sin(sig12 / dnm); if (outmask & GEOD_GEODESICSCALE) M12 = M21 = cos(sig12 / dnm); a12 = sig12 / degree; omg12 = lam12 / (g->f1 * dnm); } else { /* Newton's method. This is a straightforward solution of f(alp1) = * lambda12(alp1) - lam12 = 0 with one wrinkle. f(alp) has exactly one * root in the interval (0, pi) and its derivative is positive at the * root. Thus f(alp) is positive for alp > alp1 and negative for alp < * alp1. During the course of the iteration, a range (alp1a, alp1b) is * maintained which brackets the root and with each evaluation of * f(alp) the range is shrunk, if possible. Newton's method is * restarted whenever the derivative of f is negative (because the new * value of alp1 is then further from the solution) or if the new * estimate of alp1 lies outside (0,pi); in this case, the new starting * guess is taken to be (alp1a + alp1b) / 2. */ real ssig1 = 0, csig1 = 0, ssig2 = 0, csig2 = 0, eps = 0; unsigned numit = 0; /* Bracketing range */ real salp1a = tiny, calp1a = 1, salp1b = tiny, calp1b = -1; boolx tripn, tripb; for (tripn = FALSE, tripb = FALSE; numit < maxit2; ++numit) { /* the WGS84 test set: mean = 1.47, sd = 1.25, max = 16 * WGS84 and random input: mean = 2.85, sd = 0.60 */ real dv = 0, v = (Lambda12(g, sbet1, cbet1, dn1, sbet2, cbet2, dn2, salp1, calp1, &salp2, &calp2, &sig12, &ssig1, &csig1, &ssig2, &csig2, &eps, &omg12, numit < maxit1, &dv, C1a, C2a, C3a) - lam12); /* 2 * tol0 is approximately 1 ulp for a number in [0, pi]. */ /* Reversed test to allow escape with NaNs */ if (tripb || !(fabs(v) >= (tripn ? 8 : 2) * tol0)) break; /* Update bracketing values */ if (v > 0 && (numit > maxit1 || calp1/salp1 > calp1b/salp1b)) { salp1b = salp1; calp1b = calp1; } else if (v < 0 && (numit > maxit1 || calp1/salp1 < calp1a/salp1a)) { salp1a = salp1; calp1a = calp1; } if (numit < maxit1 && dv > 0) { real dalp1 = -v/dv; real sdalp1 = sin(dalp1), cdalp1 = cos(dalp1), nsalp1 = salp1 * cdalp1 + calp1 * sdalp1; if (nsalp1 > 0 && fabs(dalp1) < pi) { calp1 = calp1 * cdalp1 - salp1 * sdalp1; salp1 = nsalp1; SinCosNorm(&salp1, &calp1); /* In some regimes we don't get quadratic convergence because * slope -> 0. So use convergence conditions based on epsilon * instead of sqrt(epsilon). */ tripn = fabs(v) <= 16 * tol0; continue; } } /* Either dv was not postive or updated value was outside legal * range. Use the midpoint of the bracket as the next estimate. * This mechanism is not needed for the WGS84 ellipsoid, but it does * catch problems with more eccentric ellipsoids. Its efficacy is * such for the WGS84 test set with the starting guess set to alp1 = * 90deg: * the WGS84 test set: mean = 5.21, sd = 3.93, max = 24 * WGS84 and random input: mean = 4.74, sd = 0.99 */ salp1 = (salp1a + salp1b)/2; calp1 = (calp1a + calp1b)/2; SinCosNorm(&salp1, &calp1); tripn = FALSE; tripb = (fabs(salp1a - salp1) + (calp1a - calp1) < tolb || fabs(salp1 - salp1b) + (calp1 - calp1b) < tolb); } { real dummy; Lengths(g, eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2, cbet1, cbet2, &s12x, &m12x, &dummy, (outmask & GEOD_GEODESICSCALE) != 0U, &M12, &M21, C1a, C2a); } m12x *= g->b; s12x *= g->b; a12 = sig12 / degree; omg12 = lam12 - omg12; } } if (outmask & GEOD_DISTANCE) s12 = 0 + s12x; /* Convert -0 to 0 */ if (outmask & GEOD_REDUCEDLENGTH) m12 = 0 + m12x; /* Convert -0 to 0 */ if (outmask & GEOD_AREA) { real /* From Lambda12: sin(alp1) * cos(bet1) = sin(alp0) */ salp0 = salp1 * cbet1, calp0 = hypotx(calp1, salp1 * sbet1); /* calp0 > 0 */ real alp12; if (calp0 != 0 && salp0 != 0) { real /* From Lambda12: tan(bet) = tan(sig) * cos(alp) */ ssig1 = sbet1, csig1 = calp1 * cbet1, ssig2 = sbet2, csig2 = calp2 * cbet2, k2 = sq(calp0) * g->ep2, eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2), /* Multiplier = a^2 * e^2 * cos(alpha0) * sin(alpha0). */ A4 = sq(g->a) * calp0 * salp0 * g->e2; real C4a[nC4]; real B41, B42; SinCosNorm(&ssig1, &csig1); SinCosNorm(&ssig2, &csig2); C4f(g, eps, C4a); B41 = SinCosSeries(FALSE, ssig1, csig1, C4a, nC4); B42 = SinCosSeries(FALSE, ssig2, csig2, C4a, nC4); S12 = A4 * (B42 - B41); } else /* Avoid problems with indeterminate sig1, sig2 on equator */ S12 = 0; if (!meridian && omg12 < (real)(0.75) * pi && /* Long difference too big */ sbet2 - sbet1 < (real)(1.75)) { /* Lat difference too big */ /* Use tan(Gamma/2) = tan(omg12/2) * * (tan(bet1/2)+tan(bet2/2))/(1+tan(bet1/2)*tan(bet2/2)) * with tan(x/2) = sin(x)/(1+cos(x)) */ real somg12 = sin(omg12), domg12 = 1 + cos(omg12), dbet1 = 1 + cbet1, dbet2 = 1 + cbet2; alp12 = 2 * atan2( somg12 * ( sbet1 * dbet2 + sbet2 * dbet1 ), domg12 * ( sbet1 * sbet2 + dbet1 * dbet2 ) ); } else { /* alp12 = alp2 - alp1, used in atan2 so no need to normalize */ real salp12 = salp2 * calp1 - calp2 * salp1, calp12 = calp2 * calp1 + salp2 * salp1; /* The right thing appears to happen if alp1 = +/-180 and alp2 = 0, viz * salp12 = -0 and alp12 = -180. However this depends on the sign * being attached to 0 correctly. The following ensures the correct * behavior. */ if (salp12 == 0 && calp12 < 0) { salp12 = tiny * calp1; calp12 = -1; } alp12 = atan2(salp12, calp12); } S12 += g->c2 * alp12; S12 *= swapp * lonsign * latsign; /* Convert -0 to 0 */ S12 += 0; } /* Convert calp, salp to azimuth accounting for lonsign, swapp, latsign. */ if (swapp < 0) { swapx(&salp1, &salp2); swapx(&calp1, &calp2); if (outmask & GEOD_GEODESICSCALE) swapx(&M12, &M21); } salp1 *= swapp * lonsign; calp1 *= swapp * latsign; salp2 *= swapp * lonsign; calp2 *= swapp * latsign; if (outmask & GEOD_AZIMUTH) { /* minus signs give range [-180, 180). 0- converts -0 to +0. */ azi1 = 0 - atan2(-salp1, calp1) / degree; azi2 = 0 - atan2(-salp2, calp2) / degree; } if (outmask & GEOD_DISTANCE) *ps12 = s12; if (outmask & GEOD_AZIMUTH) { if (pazi1) *pazi1 = azi1; if (pazi2) *pazi2 = azi2; } if (outmask & GEOD_REDUCEDLENGTH) *pm12 = m12; if (outmask & GEOD_GEODESICSCALE) { if (pM12) *pM12 = M12; if (pM21) *pM21 = M21; } if (outmask & GEOD_AREA) *pS12 = S12; /* Returned value in [0, 180] */ return a12; } void geod_inverse(const struct geod_geodesic* g, real lat1, real lon1, real lat2, real lon2, real* ps12, real* pazi1, real* pazi2) { geod_geninverse(g, lat1, lon1, lat2, lon2, ps12, pazi1, pazi2, 0, 0, 0, 0); } real SinCosSeries(boolx sinp, real sinx, real cosx, const real c[], int n) { /* Evaluate * y = sinp ? sum(c[i] * sin( 2*i * x), i, 1, n) : * sum(c[i] * cos((2*i+1) * x), i, 0, n-1) * using Clenshaw summation. N.B. c[0] is unused for sin series * Approx operation count = (n + 5) mult and (2 * n + 2) add */ real ar, y0, y1; c += (n + sinp); /* Point to one beyond last element */ ar = 2 * (cosx - sinx) * (cosx + sinx); /* 2 * cos(2 * x) */ y0 = n & 1 ? *--c : 0; y1 = 0; /* accumulators for sum */ /* Now n is even */ n /= 2; while (n--) { /* Unroll loop x 2, so accumulators return to their original role */ y1 = ar * y0 - y1 + *--c; y0 = ar * y1 - y0 + *--c; } return sinp ? 2 * sinx * cosx * y0 /* sin(2 * x) * y0 */ : cosx * (y0 - y1); /* cos(x) * (y0 - y1) */ } void Lengths(const struct geod_geodesic* g, real eps, real sig12, real ssig1, real csig1, real dn1, real ssig2, real csig2, real dn2, real cbet1, real cbet2, real* ps12b, real* pm12b, real* pm0, boolx scalep, real* pM12, real* pM21, /* Scratch areas of the right size */ real C1a[], real C2a[]) { real s12b = 0, m12b = 0, m0 = 0, M12 = 0, M21 = 0; real A1m1, AB1, A2m1, AB2, J12; /* Return m12b = (reduced length)/b; also calculate s12b = distance/b, * and m0 = coefficient of secular term in expression for reduced length. */ C1f(eps, C1a); C2f(eps, C2a); A1m1 = A1m1f(eps); AB1 = (1 + A1m1) * (SinCosSeries(TRUE, ssig2, csig2, C1a, nC1) - SinCosSeries(TRUE, ssig1, csig1, C1a, nC1)); A2m1 = A2m1f(eps); AB2 = (1 + A2m1) * (SinCosSeries(TRUE, ssig2, csig2, C2a, nC2) - SinCosSeries(TRUE, ssig1, csig1, C2a, nC2)); m0 = A1m1 - A2m1; J12 = m0 * sig12 + (AB1 - AB2); /* Missing a factor of b. * Add parens around (csig1 * ssig2) and (ssig1 * csig2) to ensure accurate * cancellation in the case of coincident points. */ m12b = dn2 * (csig1 * ssig2) - dn1 * (ssig1 * csig2) - csig1 * csig2 * J12; /* Missing a factor of b */ s12b = (1 + A1m1) * sig12 + AB1; if (scalep) { real csig12 = csig1 * csig2 + ssig1 * ssig2; real t = g->ep2 * (cbet1 - cbet2) * (cbet1 + cbet2) / (dn1 + dn2); M12 = csig12 + (t * ssig2 - csig2 * J12) * ssig1 / dn1; M21 = csig12 - (t * ssig1 - csig1 * J12) * ssig2 / dn2; } *ps12b = s12b; *pm12b = m12b; *pm0 = m0; if (scalep) { *pM12 = M12; *pM21 = M21; } } real Astroid(real x, real y) { /* Solve k^4+2*k^3-(x^2+y^2-1)*k^2-2*y^2*k-y^2 = 0 for positive root k. * This solution is adapted from Geocentric::Reverse. */ real k; real p = sq(x), q = sq(y), r = (p + q - 1) / 6; if ( !(q == 0 && r <= 0) ) { real /* Avoid possible division by zero when r = 0 by multiplying equations * for s and t by r^3 and r, resp. */ S = p * q / 4, /* S = r^3 * s */ r2 = sq(r), r3 = r * r2, /* The discrimant of the quadratic equation for T3. This is zero on * the evolute curve p^(1/3)+q^(1/3) = 1 */ disc = S * (S + 2 * r3); real u = r; real v, uv, w; if (disc >= 0) { real T3 = S + r3, T; /* Pick the sign on the sqrt to maximize abs(T3). This minimizes loss * of precision due to cancellation. The result is unchanged because * of the way the T is used in definition of u. */ T3 += T3 < 0 ? -sqrt(disc) : sqrt(disc); /* T3 = (r * t)^3 */ /* N.B. cbrtx always returns the real root. cbrtx(-8) = -2. */ T = cbrtx(T3); /* T = r * t */ /* T can be zero; but then r2 / T -> 0. */ u += T + (T != 0 ? r2 / T : 0); } else { /* T is complex, but the way u is defined the result is real. */ real ang = atan2(sqrt(-disc), -(S + r3)); /* There are three possible cube roots. We choose the root which * avoids cancellation. Note that disc < 0 implies that r < 0. */ u += 2 * r * cos(ang / 3); } v = sqrt(sq(u) + q); /* guaranteed positive */ /* Avoid loss of accuracy when u < 0. */ uv = u < 0 ? q / (v - u) : u + v; /* u+v, guaranteed positive */ w = (uv - q) / (2 * v); /* positive? */ /* Rearrange expression for k to avoid loss of accuracy due to * subtraction. Division by 0 not possible because uv > 0, w >= 0. */ k = uv / (sqrt(uv + sq(w)) + w); /* guaranteed positive */ } else { /* q == 0 && r <= 0 */ /* y = 0 with |x| <= 1. Handle this case directly. * for y small, positive root is k = abs(y)/sqrt(1-x^2) */ k = 0; } return k; } real InverseStart(const struct geod_geodesic* g, real sbet1, real cbet1, real dn1, real sbet2, real cbet2, real dn2, real lam12, real* psalp1, real* pcalp1, /* Only updated if return val >= 0 */ real* psalp2, real* pcalp2, /* Only updated for short lines */ real* pdnm, /* Scratch areas of the right size */ real C1a[], real C2a[]) { real salp1 = 0, calp1 = 0, salp2 = 0, calp2 = 0, dnm = 0; /* Return a starting point for Newton's method in salp1 and calp1 (function * value is -1). If Newton's method doesn't need to be used, return also * salp2 and calp2 and function value is sig12. */ real sig12 = -1, /* Return value */ /* bet12 = bet2 - bet1 in [0, pi); bet12a = bet2 + bet1 in (-pi, 0] */ sbet12 = sbet2 * cbet1 - cbet2 * sbet1, cbet12 = cbet2 * cbet1 + sbet2 * sbet1; #if defined(__GNUC__) && __GNUC__ == 4 && \ (__GNUC_MINOR__ < 6 || defined(__MINGW32__)) /* Volatile declaration needed to fix inverse cases * 88.202499451857 0 -88.202499451857 179.981022032992859592 * 89.262080389218 0 -89.262080389218 179.992207982775375662 * 89.333123580033 0 -89.333123580032997687 179.99295812360148422 * which otherwise fail with g++ 4.4.4 x86 -O3 (Linux) * and g++ 4.4.0 (mingw) and g++ 4.6.1 (tdm mingw). */ real sbet12a; { volatile real xx1 = sbet2 * cbet1; volatile real xx2 = cbet2 * sbet1; sbet12a = xx1 + xx2; } #else real sbet12a = sbet2 * cbet1 + cbet2 * sbet1; #endif boolx shortline = cbet12 >= 0 && sbet12 < (real)(0.5) && cbet2 * lam12 < (real)(0.5); real omg12 = lam12, somg12, comg12, ssig12, csig12; if (shortline) { real sbetm2 = sq(sbet1 + sbet2); /* sin((bet1+bet2)/2)^2 * = (sbet1 + sbet2)^2 / ((sbet1 + sbet2)^2 + (cbet1 + cbet2)^2) */ sbetm2 /= sbetm2 + sq(cbet1 + cbet2); dnm = sqrt(1 + g->ep2 * sbetm2); omg12 /= g->f1 * dnm; } somg12 = sin(omg12); comg12 = cos(omg12); salp1 = cbet2 * somg12; calp1 = comg12 >= 0 ? sbet12 + cbet2 * sbet1 * sq(somg12) / (1 + comg12) : sbet12a - cbet2 * sbet1 * sq(somg12) / (1 - comg12); ssig12 = hypotx(salp1, calp1); csig12 = sbet1 * sbet2 + cbet1 * cbet2 * comg12; if (shortline && ssig12 < g->etol2) { /* really short lines */ salp2 = cbet1 * somg12; calp2 = sbet12 - cbet1 * sbet2 * (comg12 >= 0 ? sq(somg12) / (1 + comg12) : 1 - comg12); SinCosNorm(&salp2, &calp2); /* Set return value */ sig12 = atan2(ssig12, csig12); } else if (fabs(g->n) > (real)(0.1) || /* No astroid calc if too eccentric */ csig12 >= 0 || ssig12 >= 6 * fabs(g->n) * pi * sq(cbet1)) { /* Nothing to do, zeroth order spherical approximation is OK */ } else { /* Scale lam12 and bet2 to x, y coordinate system where antipodal point * is at origin and singular point is at y = 0, x = -1. */ real y, lamscale, betscale; /* Volatile declaration needed to fix inverse case * 56.320923501171 0 -56.320923501171 179.664747671772880215 * which otherwise fails with g++ 4.4.4 x86 -O3 */ volatile real x; if (g->f >= 0) { /* In fact f == 0 does not get here */ /* x = dlong, y = dlat */ { real k2 = sq(sbet1) * g->ep2, eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2); lamscale = g->f * cbet1 * A3f(g, eps) * pi; } betscale = lamscale * cbet1; x = (lam12 - pi) / lamscale; y = sbet12a / betscale; } else { /* f < 0 */ /* x = dlat, y = dlong */ real cbet12a = cbet2 * cbet1 - sbet2 * sbet1, bet12a = atan2(sbet12a, cbet12a); real m12b, m0, dummy; /* In the case of lon12 = 180, this repeats a calculation made in * Inverse. */ Lengths(g, g->n, pi + bet12a, sbet1, -cbet1, dn1, sbet2, cbet2, dn2, cbet1, cbet2, &dummy, &m12b, &m0, FALSE, &dummy, &dummy, C1a, C2a); x = -1 + m12b / (cbet1 * cbet2 * m0 * pi); betscale = x < -(real)(0.01) ? sbet12a / x : -g->f * sq(cbet1) * pi; lamscale = betscale / cbet1; y = (lam12 - pi) / lamscale; } if (y > -tol1 && x > -1 - xthresh) { /* strip near cut */ if (g->f >= 0) { salp1 = minx((real)(1), -(real)(x)); calp1 = - sqrt(1 - sq(salp1)); } else { calp1 = maxx((real)(x > -tol1 ? 0 : -1), (real)(x)); salp1 = sqrt(1 - sq(calp1)); } } else { /* Estimate alp1, by solving the astroid problem. * * Could estimate alpha1 = theta + pi/2, directly, i.e., * calp1 = y/k; salp1 = -x/(1+k); for f >= 0 * calp1 = x/(1+k); salp1 = -y/k; for f < 0 (need to check) * * However, it's better to estimate omg12 from astroid and use * spherical formula to compute alp1. This reduces the mean number of * Newton iterations for astroid cases from 2.24 (min 0, max 6) to 2.12 * (min 0 max 5). The changes in the number of iterations are as * follows: * * change percent * 1 5 * 0 78 * -1 16 * -2 0.6 * -3 0.04 * -4 0.002 * * The histogram of iterations is (m = number of iterations estimating * alp1 directly, n = number of iterations estimating via omg12, total * number of trials = 148605): * * iter m n * 0 148 186 * 1 13046 13845 * 2 93315 102225 * 3 36189 32341 * 4 5396 7 * 5 455 1 * 6 56 0 * * Because omg12 is near pi, estimate work with omg12a = pi - omg12 */ real k = Astroid(x, y); real omg12a = lamscale * ( g->f >= 0 ? -x * k/(1 + k) : -y * (1 + k)/k ); somg12 = sin(omg12a); comg12 = -cos(omg12a); /* Update spherical estimate of alp1 using omg12 instead of lam12 */ salp1 = cbet2 * somg12; calp1 = sbet12a - cbet2 * sbet1 * sq(somg12) / (1 - comg12); } } /* Sanity check on starting guess. Backwards check allows NaN through. */ if (!(salp1 <= 0)) SinCosNorm(&salp1, &calp1); else { salp1 = 1; calp1 = 0; } *psalp1 = salp1; *pcalp1 = calp1; if (shortline) *pdnm = dnm; if (sig12 >= 0) { *psalp2 = salp2; *pcalp2 = calp2; } return sig12; } real Lambda12(const struct geod_geodesic* g, real sbet1, real cbet1, real dn1, real sbet2, real cbet2, real dn2, real salp1, real calp1, real* psalp2, real* pcalp2, real* psig12, real* pssig1, real* pcsig1, real* pssig2, real* pcsig2, real* peps, real* pdomg12, boolx diffp, real* pdlam12, /* Scratch areas of the right size */ real C1a[], real C2a[], real C3a[]) { real salp2 = 0, calp2 = 0, sig12 = 0, ssig1 = 0, csig1 = 0, ssig2 = 0, csig2 = 0, eps = 0, domg12 = 0, dlam12 = 0; real salp0, calp0; real somg1, comg1, somg2, comg2, omg12, lam12; real B312, h0, k2; if (sbet1 == 0 && calp1 == 0) /* Break degeneracy of equatorial line. This case has already been * handled. */ calp1 = -tiny; /* sin(alp1) * cos(bet1) = sin(alp0) */ salp0 = salp1 * cbet1; calp0 = hypotx(calp1, salp1 * sbet1); /* calp0 > 0 */ /* tan(bet1) = tan(sig1) * cos(alp1) * tan(omg1) = sin(alp0) * tan(sig1) = tan(omg1)=tan(alp1)*sin(bet1) */ ssig1 = sbet1; somg1 = salp0 * sbet1; csig1 = comg1 = calp1 * cbet1; SinCosNorm(&ssig1, &csig1); /* SinCosNorm(&somg1, &comg1); -- don't need to normalize! */ /* Enforce symmetries in the case abs(bet2) = -bet1. Need to be careful * about this case, since this can yield singularities in the Newton * iteration. * sin(alp2) * cos(bet2) = sin(alp0) */ salp2 = cbet2 != cbet1 ? salp0 / cbet2 : salp1; /* calp2 = sqrt(1 - sq(salp2)) * = sqrt(sq(calp0) - sq(sbet2)) / cbet2 * and subst for calp0 and rearrange to give (choose positive sqrt * to give alp2 in [0, pi/2]). */ calp2 = cbet2 != cbet1 || fabs(sbet2) != -sbet1 ? sqrt(sq(calp1 * cbet1) + (cbet1 < -sbet1 ? (cbet2 - cbet1) * (cbet1 + cbet2) : (sbet1 - sbet2) * (sbet1 + sbet2))) / cbet2 : fabs(calp1); /* tan(bet2) = tan(sig2) * cos(alp2) * tan(omg2) = sin(alp0) * tan(sig2). */ ssig2 = sbet2; somg2 = salp0 * sbet2; csig2 = comg2 = calp2 * cbet2; SinCosNorm(&ssig2, &csig2); /* SinCosNorm(&somg2, &comg2); -- don't need to normalize! */ /* sig12 = sig2 - sig1, limit to [0, pi] */ sig12 = atan2(maxx(csig1 * ssig2 - ssig1 * csig2, (real)(0)), csig1 * csig2 + ssig1 * ssig2); /* omg12 = omg2 - omg1, limit to [0, pi] */ omg12 = atan2(maxx(comg1 * somg2 - somg1 * comg2, (real)(0)), comg1 * comg2 + somg1 * somg2); k2 = sq(calp0) * g->ep2; eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2); C3f(g, eps, C3a); B312 = (SinCosSeries(TRUE, ssig2, csig2, C3a, nC3-1) - SinCosSeries(TRUE, ssig1, csig1, C3a, nC3-1)); h0 = -g->f * A3f(g, eps); domg12 = salp0 * h0 * (sig12 + B312); lam12 = omg12 + domg12; if (diffp) { if (calp2 == 0) dlam12 = - 2 * g->f1 * dn1 / sbet1; else { real dummy; Lengths(g, eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2, cbet1, cbet2, &dummy, &dlam12, &dummy, FALSE, &dummy, &dummy, C1a, C2a); dlam12 *= g->f1 / (calp2 * cbet2); } } *psalp2 = salp2; *pcalp2 = calp2; *psig12 = sig12; *pssig1 = ssig1; *pcsig1 = csig1; *pssig2 = ssig2; *pcsig2 = csig2; *peps = eps; *pdomg12 = domg12; if (diffp) *pdlam12 = dlam12; return lam12; } real A3f(const struct geod_geodesic* g, real eps) { /* Evaluate sum(A3x[k] * eps^k, k, 0, nA3x-1) by Horner's method */ real v = 0; int i; for (i = nA3x; i; ) v = eps * v + g->A3x[--i]; return v; } void C3f(const struct geod_geodesic* g, real eps, real c[]) { /* Evaluate C3 coeffs by Horner's method * Elements c[1] thru c[nC3 - 1] are set */ int i, j, k; real mult = 1; for (j = nC3x, k = nC3 - 1; k; ) { real t = 0; for (i = nC3 - k; i; --i) t = eps * t + g->C3x[--j]; c[k--] = t; } for (k = 1; k < nC3; ) { mult *= eps; c[k++] *= mult; } } void C4f(const struct geod_geodesic* g, real eps, real c[]) { /* Evaluate C4 coeffs by Horner's method * Elements c[0] thru c[nC4 - 1] are set */ int i, j, k; real mult = 1; for (j = nC4x, k = nC4; k; ) { real t = 0; for (i = nC4 - k + 1; i; --i) t = eps * t + g->C4x[--j]; c[--k] = t; } for (k = 1; k < nC4; ) { mult *= eps; c[k++] *= mult; } } /* Generated by Maxima on 2010-09-04 10:26:17-04:00 */ /* The scale factor A1-1 = mean value of (d/dsigma)I1 - 1 */ real A1m1f(real eps) { real eps2 = sq(eps), t = eps2*(eps2*(eps2+4)+64)/256; return (t + eps) / (1 - eps); } /* The coefficients C1[l] in the Fourier expansion of B1 */ void C1f(real eps, real c[]) { real eps2 = sq(eps), d = eps; c[1] = d*((6-eps2)*eps2-16)/32; d *= eps; c[2] = d*((64-9*eps2)*eps2-128)/2048; d *= eps; c[3] = d*(9*eps2-16)/768; d *= eps; c[4] = d*(3*eps2-5)/512; d *= eps; c[5] = -7*d/1280; d *= eps; c[6] = -7*d/2048; } /* The coefficients C1p[l] in the Fourier expansion of B1p */ void C1pf(real eps, real c[]) { real eps2 = sq(eps), d = eps; c[1] = d*(eps2*(205*eps2-432)+768)/1536; d *= eps; c[2] = d*(eps2*(4005*eps2-4736)+3840)/12288; d *= eps; c[3] = d*(116-225*eps2)/384; d *= eps; c[4] = d*(2695-7173*eps2)/7680; d *= eps; c[5] = 3467*d/7680; d *= eps; c[6] = 38081*d/61440; } /* The scale factor A2-1 = mean value of (d/dsigma)I2 - 1 */ real A2m1f(real eps) { real eps2 = sq(eps), t = eps2*(eps2*(25*eps2+36)+64)/256; return t * (1 - eps) - eps; } /* The coefficients C2[l] in the Fourier expansion of B2 */ void C2f(real eps, real c[]) { real eps2 = sq(eps), d = eps; c[1] = d*(eps2*(eps2+2)+16)/32; d *= eps; c[2] = d*(eps2*(35*eps2+64)+384)/2048; d *= eps; c[3] = d*(15*eps2+80)/768; d *= eps; c[4] = d*(7*eps2+35)/512; d *= eps; c[5] = 63*d/1280; d *= eps; c[6] = 77*d/2048; } /* The scale factor A3 = mean value of (d/dsigma)I3 */ void A3coeff(struct geod_geodesic* g) { g->A3x[0] = 1; g->A3x[1] = (g->n-1)/2; g->A3x[2] = (g->n*(3*g->n-1)-2)/8; g->A3x[3] = ((-g->n-3)*g->n-1)/16; g->A3x[4] = (-2*g->n-3)/64; g->A3x[5] = -3/(real)(128); } /* The coefficients C3[l] in the Fourier expansion of B3 */ void C3coeff(struct geod_geodesic* g) { g->C3x[0] = (1-g->n)/4; g->C3x[1] = (1-g->n*g->n)/8; g->C3x[2] = ((3-g->n)*g->n+3)/64; g->C3x[3] = (2*g->n+5)/128; g->C3x[4] = 3/(real)(128); g->C3x[5] = ((g->n-3)*g->n+2)/32; g->C3x[6] = ((-3*g->n-2)*g->n+3)/64; g->C3x[7] = (g->n+3)/128; g->C3x[8] = 5/(real)(256); g->C3x[9] = (g->n*(5*g->n-9)+5)/192; g->C3x[10] = (9-10*g->n)/384; g->C3x[11] = 7/(real)(512); g->C3x[12] = (7-14*g->n)/512; g->C3x[13] = 7/(real)(512); g->C3x[14] = 21/(real)(2560); } /* Generated by Maxima on 2012-10-19 08:02:34-04:00 */ /* The coefficients C4[l] in the Fourier expansion of I4 */ void C4coeff(struct geod_geodesic* g) { g->C4x[0] = (g->n*(g->n*(g->n*(g->n*(100*g->n+208)+572)+3432)-12012)+30030)/ 45045; g->C4x[1] = (g->n*(g->n*(g->n*(64*g->n+624)-4576)+6864)-3003)/15015; g->C4x[2] = (g->n*((14144-10656*g->n)*g->n-4576)-858)/45045; g->C4x[3] = ((-224*g->n-4784)*g->n+1573)/45045; g->C4x[4] = (1088*g->n+156)/45045; g->C4x[5] = 97/(real)(15015); g->C4x[6] = (g->n*(g->n*((-64*g->n-624)*g->n+4576)-6864)+3003)/135135; g->C4x[7] = (g->n*(g->n*(5952*g->n-11648)+9152)-2574)/135135; g->C4x[8] = (g->n*(5792*g->n+1040)-1287)/135135; g->C4x[9] = (468-2944*g->n)/135135; g->C4x[10] = 1/(real)(9009); g->C4x[11] = (g->n*((4160-1440*g->n)*g->n-4576)+1716)/225225; g->C4x[12] = ((4992-8448*g->n)*g->n-1144)/225225; g->C4x[13] = (1856*g->n-936)/225225; g->C4x[14] = 8/(real)(10725); g->C4x[15] = (g->n*(3584*g->n-3328)+1144)/315315; g->C4x[16] = (1024*g->n-208)/105105; g->C4x[17] = -136/(real)(63063); g->C4x[18] = (832-2560*g->n)/405405; g->C4x[19] = -128/(real)(135135); g->C4x[20] = 128/(real)(99099); } int transit(real lon1, real lon2) { real lon12; /* Return 1 or -1 if crossing prime meridian in east or west direction. * Otherwise return zero. */ /* Compute lon12 the same way as Geodesic::Inverse. */ lon1 = AngNormalize(lon1); lon2 = AngNormalize(lon2); lon12 = AngDiff(lon1, lon2); return lon1 < 0 && lon2 >= 0 && lon12 > 0 ? 1 : (lon2 < 0 && lon1 >= 0 && lon12 < 0 ? -1 : 0); } int transitdirect(real lon1, real lon2) { lon1 = fmod(lon1, (real)(720)); lon2 = fmod(lon2, (real)(720)); return ( ((lon2 >= 0 && lon2 < 360) || lon2 < -360 ? 0 : 1) - ((lon1 >= 0 && lon1 < 360) || lon1 < -360 ? 0 : 1) ); } void accini(real s[]) { /* Initialize an accumulator; this is an array with two elements. */ s[0] = s[1] = 0; } void acccopy(const real s[], real t[]) { /* Copy an accumulator; t = s. */ t[0] = s[0]; t[1] = s[1]; } void accadd(real s[], real y) { /* Add y to an accumulator. */ real u, z = sumx(y, s[1], &u); s[0] = sumx(z, s[0], &s[1]); if (s[0] == 0) s[0] = u; else s[1] = s[1] + u; } real accsum(const real s[], real y) { /* Return accumulator + y (but don't add to accumulator). */ real t[2]; acccopy(s, t); accadd(t, y); return t[0]; } void accneg(real s[]) { /* Negate an accumulator. */ s[0] = -s[0]; s[1] = -s[1]; } void geod_polygon_init(struct geod_polygon* p, boolx polylinep) { p->lat0 = p->lon0 = p->lat = p->lon = NaN; p->polyline = (polylinep != 0); accini(p->P); accini(p->A); p->num = p->crossings = 0; } void geod_polygon_addpoint(const struct geod_geodesic* g, struct geod_polygon* p, real lat, real lon) { lon = AngNormalize(lon); if (p->num == 0) { p->lat0 = p->lat = lat; p->lon0 = p->lon = lon; } else { real s12, S12; geod_geninverse(g, p->lat, p->lon, lat, lon, &s12, 0, 0, 0, 0, 0, p->polyline ? 0 : &S12); accadd(p->P, s12); if (!p->polyline) { accadd(p->A, S12); p->crossings += transit(p->lon, lon); } p->lat = lat; p->lon = lon; } ++p->num; } void geod_polygon_addedge(const struct geod_geodesic* g, struct geod_polygon* p, real azi, real s) { if (p->num) { /* Do nothing is num is zero */ real lat, lon, S12; geod_gendirect(g, p->lat, p->lon, azi, GEOD_LONG_NOWRAP, s, &lat, &lon, 0, 0, 0, 0, 0, p->polyline ? 0 : &S12); accadd(p->P, s); if (!p->polyline) { accadd(p->A, S12); p->crossings += transitdirect(p->lon, lon); } p->lat = lat; p->lon = lon; ++p->num; } } unsigned geod_polygon_compute(const struct geod_geodesic* g, const struct geod_polygon* p, boolx reverse, boolx sign, real* pA, real* pP) { real s12, S12, t[2], area0; int crossings; if (p->num < 2) { if (pP) *pP = 0; if (!p->polyline && pA) *pA = 0; return p->num; } if (p->polyline) { if (pP) *pP = p->P[0]; return p->num; } geod_geninverse(g, p->lat, p->lon, p->lat0, p->lon0, &s12, 0, 0, 0, 0, 0, &S12); if (pP) *pP = accsum(p->P, s12); acccopy(p->A, t); accadd(t, S12); crossings = p->crossings + transit(p->lon, p->lon0); area0 = 4 * pi * g->c2; if (crossings & 1) accadd(t, (t[0] < 0 ? 1 : -1) * area0/2); /* area is with the clockwise sense. If !reverse convert to * counter-clockwise convention. */ if (!reverse) accneg(t); /* If sign put area in (-area0/2, area0/2], else put area in [0, area0) */ if (sign) { if (t[0] > area0/2) accadd(t, -area0); else if (t[0] <= -area0/2) accadd(t, +area0); } else { if (t[0] >= area0) accadd(t, -area0); else if (t[0] < 0) accadd(t, +area0); } if (pA) *pA = 0 + t[0]; return p->num; } unsigned geod_polygon_testpoint(const struct geod_geodesic* g, const struct geod_polygon* p, real lat, real lon, boolx reverse, boolx sign, real* pA, real* pP) { real perimeter, tempsum, area0; int crossings, i; unsigned num = p->num + 1; if (num == 1) { if (pP) *pP = 0; if (!p->polyline && pA) *pA = 0; return num; } perimeter = p->P[0]; tempsum = p->polyline ? 0 : p->A[0]; crossings = p->crossings; for (i = 0; i < (p->polyline ? 1 : 2); ++i) { real s12, S12; geod_geninverse(g, i == 0 ? p->lat : lat, i == 0 ? p->lon : lon, i != 0 ? p->lat0 : lat, i != 0 ? p->lon0 : lon, &s12, 0, 0, 0, 0, 0, p->polyline ? 0 : &S12); perimeter += s12; if (!p->polyline) { tempsum += S12; crossings += transit(i == 0 ? p->lon : lon, i != 0 ? p->lon0 : lon); } } if (pP) *pP = perimeter; if (p->polyline) return num; area0 = 4 * pi * g->c2; if (crossings & 1) tempsum += (tempsum < 0 ? 1 : -1) * area0/2; /* area is with the clockwise sense. If !reverse convert to * counter-clockwise convention. */ if (!reverse) tempsum *= -1; /* If sign put area in (-area0/2, area0/2], else put area in [0, area0) */ if (sign) { if (tempsum > area0/2) tempsum -= area0; else if (tempsum <= -area0/2) tempsum += area0; } else { if (tempsum >= area0) tempsum -= area0; else if (tempsum < 0) tempsum += area0; } if (pA) *pA = 0 + tempsum; return num; } unsigned geod_polygon_testedge(const struct geod_geodesic* g, const struct geod_polygon* p, real azi, real s, boolx reverse, boolx sign, real* pA, real* pP) { real perimeter, tempsum, area0; int crossings; unsigned num = p->num + 1; if (num == 1) { /* we don't have a starting point! */ if (pP) *pP = NaN; if (!p->polyline && pA) *pA = NaN; return 0; } perimeter = p->P[0] + s; if (p->polyline) { if (pP) *pP = perimeter; return num; } tempsum = p->A[0]; crossings = p->crossings; { real lat, lon, s12, S12; geod_gendirect(g, p->lat, p->lon, azi, GEOD_LONG_NOWRAP, s, &lat, &lon, 0, 0, 0, 0, 0, &S12); tempsum += S12; crossings += transitdirect(p->lon, lon); geod_geninverse(g, lat, lon, p->lat0, p->lon0, &s12, 0, 0, 0, 0, 0, &S12); perimeter += s12; tempsum += S12; crossings += transit(lon, p->lon0); } area0 = 4 * pi * g->c2; if (crossings & 1) tempsum += (tempsum < 0 ? 1 : -1) * area0/2; /* area is with the clockwise sense. If !reverse convert to * counter-clockwise convention. */ if (!reverse) tempsum *= -1; /* If sign put area in (-area0/2, area0/2], else put area in [0, area0) */ if (sign) { if (tempsum > area0/2) tempsum -= area0; else if (tempsum <= -area0/2) tempsum += area0; } else { if (tempsum >= area0) tempsum -= area0; else if (tempsum < 0) tempsum += area0; } if (pP) *pP = perimeter; if (pA) *pA = 0 + tempsum; return num; } void geod_polygonarea(const struct geod_geodesic* g, real lats[], real lons[], int n, real* pA, real* pP) { int i; struct geod_polygon p; geod_polygon_init(&p, FALSE); for (i = 0; i < n; ++i) geod_polygon_addpoint(g, &p, lats[i], lons[i]); geod_polygon_compute(g, &p, FALSE, TRUE, pA, pP); } /** @endcond */ raster/NEWS0000644000176200001440000016605114160021141012250 0ustar liggesusers --- 5-October-2021, version 3.5-1 raster now imports terra (instead of the other way around) such that the two packages can be used together; and to allow replacing rgdal and rgeos functionality with functions from terra. --- 17-July-2020, version 3.3-13 overhaul of crs to be ready for PROJ6 several bug fixes (see https://github.com/rspatial/raster/issues?q=is%3Aissue+) --- 18-April-2020, version 3.1-5 improvements: new arguments "smin", "smax" and "samplesize" to "stretch"; and bug fixes. See https://github.com/rspatial/raster/issues/70 layer names in GTiff files are now read from file. Requested by Kyle Taylor https://github.com/rspatial/raster/issues/88 bug fixes: parallel version of extract with polygons and "fun" messed up the order of the values (reported by Jacory). https://github.com/rspatial/raster/issues/79 raster::predict bug when using factors (reported by vvirkki). https://github.com/rspatial/raster/issues/73 distanceFromPoints with large files: https://github.com/rspatial/raster/issues/103 colortable lost when cropping RasterBrick: https://github.com/rspatial/raster/issues/105 Error in stack() when providing both bands and varname: https://github.com/rspatial/raster/issues/97 rasterize and multi-polygon containing hole: https://github.com/rspatial/raster/issues/93 Upside down raster: https://github.com/rspatial/raster/issues/95 (a warning is given, not really fixed yet) Extract to data.frame bug: https://stackoverflow.com/questions/61174280/r-rasterextract-fails-to-create-data-frame --- 24-September-2019, version 3.0-7 Bug fixes: predict with character label factor variables returned NA only https://github.com/rspatial/raster/issues/68 cellFromPolygons now ignores possible incompatible (integer) user-specified default datatype (reported by John Baums, https://github.com/rspatial/raster/issues/69) --- 22-August-2019, version: 3.0-2 Bug fixes: calc failed when writing to disk if the supplied function returned multiple layers as a vector. Reported by Antoine Stevens reclassify bug reported by Jacub Nowasad. https://github.com/rspatial/raster/issues/62 extract failed for sf objects with a Z dimension. https://github.com/rspatial/raster/issues/64 More generics and namespace exports for compatability with "terra" --- 10-July-2019, version: 2.9-22 New (hidden) function ".ifel", that is, ifelse for Raster objects (this is the R implementation of the arcpy "Con" method) New (hidden) function ".ifel", that is, ifelse for Raster objects (this is the R implementation of the arcpy "Con" method) Lots of namespace export additions for compatability with "terra" Old .Call code replaced with Rcpp based code Bug fixes: netcdf writing for multi-layer objects was no working. Reported by Philipp Buehler https://github.com/rspatial/raster/issues/53 better handling of factor variables in raster::predict --- 14-May-2019, version: 2.9-5 new argument "margins" to plotRGB to allow plotting whitespace around images. The crs is now written to ncdf files, using proj4=" " reclassify now keeps the layer names (suggested by Matthieu Stigler) modal of a single layer now returns that layer with a warning instead of throwing an error (suggested by Ben Tupper) Bug fixes: writing very large Raster objects that were entirely in memory could fail with a "long vectors not supported yet". https://github.com/rspatial/raster/issues/33 When creating a RasterLayer from an ascii file using the native driver and the file specifies xllcenter. Problem reported by Ram: https://stackoverflow.com/questions/54373701/error-in-if-xn-xx-missing-value-where-true-false-needed Error coercing raster with one non-NA value to SpatialPixelsDataFrame (ickf.se) https://gis.stackexchange.com/questions/314472/error-coercing-raster-with-one-non-na-value-to-spatialpixelsdataframe/ mask with sf object ignored other arguments (Jakub Nowasad) improved handling of factors in "predict". Fixed a bug with gbm models (dismo) reported by Jane Elith. Also removes factor levels that are not in model for GLM (predictions become NA). show(Spatial*) could have the order of the min max values wrong on linux due to prepended spaces by as.matrix in apply(x, 2, range). Reported by Barry Rowlingson. Fixed bug in rasterFromXYZ (if multiple layers and writing to disk) reported by Mike Nosal https://github.com/rspatial/raster/issues/49 --- 29-Jan-2019, version: 2.8-19 higher precision extract with weights for small polygons. See https://stackoverflow.com/questions/53854910/issue-with-estimating-weighted-mean-from-raster-for-a-polygon-shape-in-r/ fixed error with rasterize when counting overlapping polygons with holes, reported by Boris Leroy. See: https://gis.stackexchange.com/questions/307770/inconsistencies-in-r-rasterize-polygons-packages-raster-and-sf fixed sf to sp coercion problem for degenerate Spatial*DataFrame with zero variables. Problem reported by Jakub Nowasad https://github.com/rspatial/raster/issues/29 fixed SRTM download in getData (new URL) and uppercase issue reported by tatianic https://github.com/rspatial/raster/issues/34 raster::isLonLat("+init=epsg:4326") now returns TRUE. Suggested by Mike Sumner https://github.com/rspatial/raster/issues/32 faster rasterization of polygons (introduced in previous versions, but, by mistake, was not used in most cases) faster handling of GMT ncdf files by Mike Sumner new argument "na.last" to "unique" suggsted by Marco Sciaini. https://github.com/rspatial/raster/issues/23 crosstab for small objects returned a data.frame instead of a table with long=FALSE. Reported by Jakub Nowosad Refined matching CF crs descriptions (in climate ncdf files) with proj, with suggestions from Paul Newell Improvement to raster::predict suggested by Roeland Kindt --- 2-Nov-2018, version: 2.8-4 Improved estimation of available RAM with contributions by Lorenzo Busetto. RAM available is now computed on windows, linux and mac. No more that 60% of available RAM is used (if the estimated RAM needed is not too low). Not more than raster:::.maxmemory() is used; but it should now be safe to set this to Inf. If canProcessInMemory() returns FALSE, chunksize is set 25% of available RAM, or raster:::.chunksize(), whichever is lower. (set options via rasterOptions()) testthat unit tests introduced by Mike Sumner and Jakub Nowosad as.character() for Raster objects to create the R code to re-create the Raster skeleton in examples. Reading point values via GDAL has become slower in 2.7-15, reverted to previous function. Thanks to Andrew Brown and Dylan Beaudette for identifying the problem. Bare negate with a Raster* (e.g. -r) now works. https://github.com/rspatial/raster/issues/21 Bug fixes: fixed the link for GADM countries download. Bug reported by Loic Dutrieux fixed corner-case bug in alignExtent (for a small extent, touching a grid cell), affecting crop; reported by Judith Mourant and Paul Fenimore fixed problem with subs reported by Andy Craig https://github.com/rspatial/raster/issues/17 Previous version had a maxmemory value that was too high (reported by Lorenzo Busetto) --- 16-Oct-2018, version: 2.7-15 faster extraction for points via GDAL (reverted to previous code in version 2.8-4) Bug fixes: buffer did not work with values in memory. Bug reported and solution proposed by Carlos Alberto Arnillas extract with point and smaller single cell buffer failed when an aggregation function was provided. Reported by Lucas https://stackoverflow.com/questions/52335522/r-why-does-raster-extract-give-dim-error/52338639#52338639 --- 11-Nov-2017, version: 2.6-6 New: new extent objects created from a vector of coordinates are now checked for being valid. Suggested by Mike Sumner buffer for lon/lat points erase for SpatialLines with Polygons kernelDensity function (hidden) output from freq is always ordered (whether computed from disk or from in memory values). Requested by Benjamin Leutner Bug fixes: as.data.frame from file based rasters ingored na.rm=TRUE (unless xy=TRUE). Reported by Jean-Gabriel Elie getValuesBlock with lyrs argument. Reported by Antoine Stevens In approxNA with large files NAs were ignored and the NArule was ignored. Reported by Pablo Timoner isValid(raster()) failed. Reported by dww on http://stackoverflow.com/questions/37869271/how-to-dput-a-raster/37871930 zapply passes on ... arguments to stackApply res() for rotated rasters was wrong https://gis.stackexchange.com/questions/259321/opening-rotated-raster-in-r (fix suggested by Spacedman) cover with RasterStackBrick objects could not write to file (reported by L. Wasser https://stackoverflow.com/questions/44295842/r-raster-cover-function-error-with-landsat-stacks Raster Attribute Tables with labels with a colon it could not be written because the colon was used as delimiter in the grd file. https://stackoverflow.com/questions/46832976/why-is-crop-sometimes-introducing-nas-on-a-categorical-raster An error was thrown if "rasterToPoints" returned no points, and "spatial=TRUE". Instead an empty SpatialPointsDataFrame is now returned (reported and suggested by Arnaud Mosnier) Another error when rasterToPoints was used on a single-pixel multi-layer raster object (reported by Daniele Baisero) rasterize polygons bugged in some cases if a polygon node was exactly in the center of a cell. Reported by Marco Sciaini https://gis.stackexchange.com/questions/252210/rasterize-a-spatialpolygonsdataframe-error-in-if-x2a-rxmn bug in projectRaster related to dateline: https://stackoverflow.com/questions/47047623/projectraster-raster-projection-of-bathymetry-data-noaa-nc-in-the-pacific raster::pring of a SpatialPointsDataFrame showed an error message if the data.frame had zero columns (reported by Bart Branstauber) Really bad bug: for Raster 'r', 'r < 50' was not equivalent to '50 > r' (the latter being wrong!). Reported by Jonathan Proctor Error in the correction for the standard deviation with asSample=FALSE. Reported and fix provided by Benjamin Leutner raster::colSums gave false results when !canProcessInMemory(x). Reported and fix provided by Peter Kullberg zonal( ,stat='sd') did not work. Reported by Matt Biber --- 31-May-2016, version: 2.5-8 new functions for Raster objects: as.integer, as.list new functions whiches.min and whiches.max (to get all layers that are which.min/max) added 'forcefun' argument to overlay atan2 now available for all Raster objects several minor fixes --- 19-December-2015, version: 2.5-2 Bug fixes: The order of the layers returned by stackApply was only as expected of the indices were sorted from 1 to n. Reported by Mark Payne rasterize(..., getCover=TRUE) again did not work properly. Reported by Pascal Title as.vector gave trouble on different version (R-devel vs. R-current). Work around implemented. --- 10-December-2015, version: 2.4-30 package ncdf is now obsolete and no longer supported (use ncdf4 instead) Major bug fixes: Extraction of values with xy or cellnumber from a ncdf file where 'level' is the fourth variable (and time third, in stead of the other way around) did not work correctly. Reported by John Gross rasterize(..., getCover=TRUE) did not work properly. Reported by Sam Tomlinso Minor bug fixes: in rasterFromXYZ (by Gareth Davies) in crop (by Florian Detsch) in stack (http://stackoverflow.com/questions/32564932/r-import-two-or-more-selected-bands-from-an-image-stack) in sampleStratified (by Antoine Stevens) --- 8-September-2015, version: 2.4-20 Andrei Mirt send a bug fix for corLocal namespace now captures all functions from other packages .nchar to replace nchar to avoid R version problem Sebastian Bock reported a bug in raster:::.circular.weight various minor fixes --- 2-July-2015, version: 2.4-15 Improved geodesic algorithm (GeograhicLib by C.F.F. Karney) for pointDistance and other lon/lat distance computations, and to compute the area of an ellipsoidal polygon significant speed improvement for bilinear resample / projection (by Joe Cheng) new functions colSums and rowSums fixed colnames for extract(s, points, df = TRUE, cellnumbers = TRUE). Reported by Loic Dutrieux fixes to avoid errors thrown by current PROJ.4 (crs must have ellipsoid or datum) bug fix: writeRaster did not write names of in memory RasterLayers. Reported by Toph Allen temp files were not removed. Fixed by Samuel Bosch image failed for a raster with a single row. Patched by Daniel Schlaepfer --- 11-April-2015, version: 2.3-40 Category names are now written to file via rgdal or native format color tables are now written to file via rgdal or native format bug fixes: Creating a brick from RasterLayers with a filename argument did not deal with 'overwrite=TRUE'. Reported by Tom Philippi boxplot with two raster wasn't going right (reported by Stefan Schlaffer) native format can now write/read POSIXct z-values (patch provided by Stefan Schlaffer) error in rasterize/mask with SpatialPolygons that go outside the raster --- 12-March-2015, version: 2.3-33 bug fix in extract(Raster, SpatialPolygons, na.rm=TRUE); na.rm=T was ignored in some cases. (reported by Lewis Hagedorn) bug fix in union(SpatialPolygons,missing) added extraction of layer names for .img files from gdal metadata new unit option ('tangent') to compute slopes (terrain function) transparency (in plot) can now be set using another RasterLayer --- 25-January-2015, version: 2.3-24 removed several checks for 'minor' R version that were no longer necessary and wrong since major version 3 (reported by Edzer Pebesma) normalizeWeights argument to extract with polygon. Default is TRUE such that weights add up to 1. Setting it to FALSE allows to get the same numbers as in earlier versions (in response to query by Nick Bond) bug fixes: overlay did not check if rasters have the same structure if only two objects were used. Reported by Loc Dutrieux 'freq' on large files with NA values produced an error (reported by Nick Bond) --- 10-October-2014, version: 2.3-10 new function: localFun bug fixes: - in 'freq', useNA='always' did not return counts for NA values for large raster files. - rasterize with polygons did not accept a non-character function anymore. Reported by Sarah Lehnen. - invalid polygons errors are now handled by union/erase/intersect. - fixed plotting bug due to a change in sampleRegular. - sampleRegular ignored xy=TRUE when size >= ncell(x). Reported by Oscar Perpian Lamigueiro. - in 'freq', useNA='always' did not return counts for NA values for large raster files. - extend failed in some cases (when only extending rows). Reported by Anja Klisch - plotRGB failed in some cases. Reported by Mike Sumner --- 5-September-2014, version: 2.3-0 Improvement of ENVI hdr file (WKT projection) suggested by Loc Dutrieux expanded corLocal to RasterStackBrick union function for single SpatialPolygons* object removeTmpFiles now also removes sub-folders. Code modified by Matteo Mattiuzzi expanded functionality: aggregate can now aggregate in space and 'time' (layers). specifying an invalid band number when creating a RasterLayer now leads to an error instead of a warning. In the case of ncdf files there was no warning (reported by Sahar Mokhtari) removed obsolete function edges (use boundaries instead). obsolete function edge still available this version. bug fixes: - in plotRGB with stretching (in some cases the image became black). (Reported by Agus Lobo) - as.data.frame(xy=TRUE, na.rm=TRUE) now works. Reported by Helen Sofaer - RasterLayer with single column RAT tables gave an error on show(). Reported by Nevil Amos - aspect computation for plotting lon/lat rasters failed in some cases (Reported by Francisco Quevedo) - datum/ellipsoid and true scale latitude was incorrect for South NSIDC (Reported by Neal Young) - extracting values failed for very large rasters (cell numbers > 2*10^9 because as.integer() returns NA). Problem reported by Samantha Franks and by Alexander Herr - subset failed for bricks derived from 4D NetCDF files. Reported by Mark Payne --- 6-March-2014, version: 2.2-31 new functions 'meta<-' and 'meta' to set and get metadata to a Raster object. Metadata is saved to file for native format files only. new argument updatevalue to mask new function animate new function corLocal new convenience function origin<- new function RGB to create Red-Green-Blue(-alpha) files. new intersect method for SpatialPoints with ANY(-thing from which an Extent can be extracted) newly exported function compareCRS bug fix in boundaries function with large files reported by Adrien Bayeux bug fix in writing multiple layers to a ncdf file if the z-value cannot be converted to numeric. Reported by Aseem Sharma bug fix in extract with lines and along=TRUE (reported by Robin Edwards) bug fix in extract with polygons, in some combinations the column names setting was incorrect and led to an error. (Reported by David Walter) bug fix in rasterize/polygons (and affected extract with polygons). It did not consider nested polygons with holes. (Reported by Bart Kranstauber) bug fix in disaggregate chunk size computation (reported by Benjamin Leutner) bug fixes in writing IDRISI files (reported by Paulo Cardoso) bug fix: factors were not set correctly for a Raster* derived from a Spatial* object leading to an error when sampleRegular(asRaster=T) was used (reported by Tomislav Hengl) --- 20-January-2014, version: 2.2-12 bug fix in rasterize with small polygons (reverted to previous version) (reported by Roger Bivand) bug fix in extract/points/RasterBrick when all points are outside the raster (reported by Jonathan Greenberg) bug fix in linking to SAGA files (reported by Chuck Bulmer) bug fix in scale with large files (and underlying problem in cellStats) (reported by Oscar Perpian Lamigueiro). improved chunk size computation in disaggregate as suggested by Benjamin Leutner improved writing of min and max value stats when these are truncated because of the data type (suggested by Philip Heilman) resample now first aggregates input data if it is being resampled to much larger grid cells projectRaster now allows re-projecting to the same CRS as the input data (an alternative to resample) --- 1-January-2014, version: 2.2-5 bug fix that prevented using certain file formats that do not provide a proj4 string bug fix in trim. It failed when only the last row had values. Reported by Daniel Schlaepfer bug fix in sampleRandom. 'ext' argument was ignored for large Raster objects. Reported by Ned Horning added 'export' argument to cluserR added 'NArule' argument to approxNA and fixed bug when there was only one layer without an NA value (reported by Josh Perlman) improved rasterTmpFile to avoid creating duplicate names in case of parallel processes that call set.seed (suggested by Daniel Schlaepfer) added several functions to manipulate Spatial* objects (aggregate, bind, intersect, erase, union, symdif) that were previously in sptools (on R-Forge) 'edges' renamed to 'boundaries' to avoid name overlap with igraph::edges. edges (and edge! see previous change below) is still available for now (with a warning) for backwards compatibility --- 16-November-2013, version: 2.1-65 added support to read NSIDC sea ice concentration binary files (southern and northern hemisphere) http://nsidc.org/data/polar_stereo/ps_grids.html and http://nsidc.org/data/nsidc-0051.html https://stat.ethz.ch/pipermail/r-sig-geo/2011-October/013067.html bug fix in stack with with input file name vector and quick=TRUE bug fix: mask with maskvalue that is not NA ignored "inverse=TRUE" new function "validNames" (to avoid the need for using raster:::.goodNames by another package) new function "flowPath" fixed wrong axes labels with plot( ,gridded=TRUE). Reported by Agustin Lobo 'edge' renamed to 'edges' to avoid name overlap with igraph::edge. edge is still available for now (with a warning) for backwards compatibility --- 8-July-2013, version: 2.1-45 bug fix in focal with pad=TRUE (introduced in previous version) bug fix in terrain/roughness (problem reported by Michael Sumner) rotate failed with a single-layer RasterBrick (reported by Michael Sumner) --- 2-July-2013, version: 2.1-41 changes in namespace (disaggregate) to keep compatibility with 'sp' bug fix in aggregate with expand=FALSE, reported by Koen Hufkens focal sometimes returns NaN where a NA would be easier to interpret (and use in subsequent calls to focal( , NAonly=T). Trying to return NA now in such cases (reported by Marcia Macedo). --- 14-June-2013, version: 2.1-37 new argument 'values' to 'trim' to allow trimming for other values that NA new functions (for Raster objects) which.min and which.max layers can now be referred to with a $ (as in lists and data.frames) coercion methods to Extent and RasterLayer from GridTopology contributed by Michael Sumner bug fixes in crosstab and in zonal, reported by Josh Perlman bug fix in terrain. flowdir was not computed when used together with other options (bug and fix reported by Etienne Racine) changed default datatype to FLT8S (from FLT4S) to avoid generalization of large integers NA value in native arc ascii files now only the flag value (it was any value <= the flag value) bug fix in assigning colnames when extracting values from RasterBrick --- 11-April-2013, version: 2.1-25 removed bugs from 'f8' in the writing functions vignette (reported by J. R. Matchett) fixed bug that occured when creating stack from ascii files if rgdal was not installed fixed support for big.matrix to store raster data (because currently the bigmemory package is not available on windows) aggregate now allows aggregation to be 1 in one dimension fixed bug in density and hist with RasterStack objects (reported by Carsten Neumann) added option 'along' to extract with lines added option 'factors' to predict function to be able to specify factor levels. added option 'sp' to extract to return an Spatial object --- 10-March-2013, version: 2.1-10 replacement with multi-layer object now works as expected (problem reported by Julian Zeidler) replacing a logical value in a RasterLayer previously changed the data type to numeric improved setExtent (bug report by Kathi Borgmann) adjacency is now obsolete (use adjacent instead) rasterOptions now (optionally) saved in a file in the start-up working directory fixed colnames in extract/polygons (cellnumbers=TRUE & df=TRUE). Reported by Florian de Boissieu bug with Math methods that occured when using mapply fixed thanks to Martin Morgan Then results of terrain(flowdir) were the mirror image of what the help says. The code has been fixed to match the help file. Reported by Daniel Schlaepfer. Bug fixes in dealing with RATs (reported by Dylan Beaudette) and rasterize/points (reported by Steven Mosher) Support for "GMT" netcdf files (suggested by Michael Sumner) Option 'ncdf=TRUE' in raster function for files with non-standard (or no) ncdf file extension (suggested by Tom Roche). --- 21-December-2012, version: 2.0-41 fixed bugs in extend: added rows did in some cases get values from row above, and using a 'datatype' arugment led to an error. Both reported by Oliver Soong fixed bug, introduced in previous version, in aggregate with expand=FALSE (reported by Mark Payne) fixed bug in summary that occurred when some layers had NA values and others not (reported by Agustin Lobo) getValuesBlock now has a row=1 default value. docs suggested that the default was all rows (but there was no default). Inconsistency reported by Oliver Soong blockSize made safer for resample with cluster (thanks to Stefan Schlaffer) 'timer' (in progressbar) works again (thanks to Stefan Schlaffer) subsetting a brick to a single layer now returns a RasterLayer (unless drop=FALSE), which is consistent with the behavior or a RasterStack (suggested by Jon Olav Skoien) Fixed error occurring when creating a RasterStack from several ncdf files using a 'varname' argument (Problem reported by Greg). --- 7-November-2012, version 2.0-31 new function 'select' for selecting spatial subsets by drawing on plot (map) new function 'barplot' for RasterLayer objects new function 'scale' for Raster* objects (suggested by Agustin Lobo) new functions to coerce to and from big.matrix objects: as(x, 'big.matrix') and raster(x) or brick(x) new implementation of aggregate that is _much_ faster with fun= min, max, mean or sum raster now uses 'igraph' instead of 'igraph0' (functions gridDistance and clump) renamed function 'compare' to 'compareRaster' (to avoid name hiding by the igraph package) renamed function 'expand' to 'extend' (to avoid name hiding by the Matrix package) functions setOptions, showOptions, saveOptions, and clearOptions have been replaced by new function "rasterOptions" incorporated function 'count' into 'freq' (via the 'value' argument) and 'count' now gives a warning and will be removed in the future (to avoid name hiding of count by the plyr package which is used by rgeos) new argument 'alignOnly' to projectRaster new option 'setStatistics=FALSE' for writing to some GDAL files (geoTiff in particular) to suppress writing band statistics (min, max, mean, sd). This is currently not documented. When TRUE, all statistics are written when all the values are in memory, but only min and max are written in other cases, leading to problems in QGIS (reported by Agustin Lobo) Added argument "gridded=TRUE" for plot(RasterLayer, RasterLayer), to show counts for intervals (suggested by Agustin Lobo) Added stat='sd' option to zonal (suggested by Christian Levers) improvement to rasterize with polygons. Polygons that cross a cell vertically and through the center are now inside (they were at the right side of a polygon, but not at the left side of a polygon). Reported by Jon Olav Skoien Fixed bug when cropping brick from ncdf file to a single cell (reported by Kapo Coulibaly) Fixed bug in sampleRandom with "rowcol=TRUE" (reported by Agustin Lobo) Fixed bug with RAT tables in native format (reported by Joseph Steward) Fixed corner case bug with extract/polygons df=TRUE (reported by Jon Olav Skoien) Added big.matrix as a "driver" (file format). This is experimental (and not documented). raster now attempts to interpret the CRS from netcdf files added support for the 360 day calendar in netcdf files --- 1-September-2012, version 2.0-12 fixed bug in summary reported by Agustin Lobo fixed bug in terrain/flowdir reported by Marie Morfin zlim (argument to plot) did not function properly when used to extend the values range (reported by Bart) writeRaster now honours the value of the NAvalue argument when writing a ncdf file (requested by Thiago Veloso) added support for the ncdf4 library fixed many spelling mistakes in the documentation reported by Phil Heilman function fourCellsFromXY is now visible. method 'freq' implemented for 'RasterStackBrick' new function 'layerize' function 'reclassify' replaces identical 'reclass' (still available but with deprecation warning) to avoid hiding by xts::reclass added arguments to writeRaster to allow for writing layers to individual files --- 27-June-2012, version 2.0-08 bug fixes (both introduced in version 2.0-04): multilayer files of the 'raster' format have a corrupt header file (reported by Jonathan Greenberg) subset with a RasterBrick fails because of an error when accessing the z slot (reported by Matt Fischer) crop with a RasterStack failed new option 'tmptime' to set after how many hours temp files may be deleted. Suggested by Shannon Albeke --- 17-June-2012, version 2.0-04 More support for factors and (related) Raster Attribute Tables (functions ratify, deratify) z-values are saved to file (native format only) Old slot @zvalue removed (in favor of slot @z) New function 'names' to (eventually) replace 'layerNames', for compatibility with sp. New function 'proj4string' (equivalent to 'projection') for compatibility with sp. New function 'sampleStratified' Improved speed for creating a RasterStack from a list of RasterLayer objects (thanks to report by Jonathan Kennel), and for rasterToPoints setValues(brick, values) now also works if the existing values (on disk) cannot be all loaded into memory (suggested by Jonathan Greenberg). bug fixes: rasterize with polygons ignores the 'field' argument (bug introduced in previous version) log failed when writing to disk (reported by Jochen Albrecht) sampleRegular failed in some cases for a RasterStack (affecting spplot). Reported by Matthew Landis) --- 1-May-2012, version 1.9-82 New features, improvements: New function weighted.mean New function layerStats to compute the correlation, covariance and weighted covariance matrix across layers (by Jonathan Greenberg) crosstab can now also process multi-layer objects, suggested by Neil Best Improved speed of getValuesBlock for RasterBrick using suggestion by Stefan Schlaffer print method for Spatial* objects similar to that for Raster* objects bug fixes: 'overlay' ignored the writeRaster arguments. Reported by Oliver Soong The 'buffer' argument in extract (with points) was lost in the previous version. It has been restored. In extract with polygons failed with "getCover=TRUE". Reported by Ariel Ortiz-Bobea 'predict' now also works when using a single predictor raster layer. Reported by Ben Weinstein 'crop' now accepts a 'datatype' argument. Reported by Jonathan Greenberg --- 5-April-2012, version 1.9-82 New function 'getValuesFocal' to get focal values (a cell and its neighborhood) Added .tmpdir function, provided by Shaun Walbridge, to make the name of the folder used to store temporary files user-specific to avoid collisions on multi-user platforms such as cluster computers. Improved support for accessing subdatasets (in gdal provided raster data). Non-standard names like "subdatset:filename" should now work (previously some were normalized to (invalid) path names). There is also an argument "sub" in raster(). Bug fixes: disaggregate sometimes failed for large files, patched by Jim Regetz. It was not possible to make a RasterStack from a single-layer RasterBrick (reported by Julian Zeidler). The 'slope' returned by 'terrain' was not correct when used together with 'tri', 'tpi', or 'roughness', and when you use unit = 'degrees' (reported by Forrest Stevens) predict / randomForest failed with more than one factor variable, reported by Xiong Xiong Fixed bug when writing to EHdr files, reported by Elena It is now assured that the filename returned by rasterTmpFile() does not exist (avoiding "overwrite" problems, reported by Diann Prosser). --- 27-February-2012, version 1.9-70 Removed function 'polygonFromExtent' (in favor of as(x, 'SpatialPolygons') ) In 'compare', the name of argument 'prj' was changed to 'crs' Fixed bug in srtm download limits. Reported by Stefan Schlaffer Fixed bug that made init fail for large rasters. Reported by Oscar Perpian Lamigueiro. removed bug in calc (some functions produced an error) reported by Alfredo Alessandrini sampleRandom did not always return the randomly selected numbers in random order. Reported by Etienne Racine. cover did not check if input rasters were overlapping. This could lead to wrong results. Reported by Thiago Veloso --- 6-February-2012, version 1.9-67 Bug fix in terrain('slope') for lon/lat rasters that were processed on disk. Latitude of the first chunk of rows was used for all rows. Reported by Bart Kranstauber Bug fixed that occured when using getData and a root working like "c:\". Reported by Uwe Ligges. A few changes to scalebar() --- 17-January-2012, version 1.9-64 Bug fix in projectRaster for small rasters (< 50 rows or columns). Rported by Klaus Jacobi Bug fix in plot with breaks argument (legend did not always match). Reported by Jane Elith Setting layer names to a RasterStack now also changes the layer names of the component RasterLayer objects --- 15-January-2012, version 1.9-63 All the recent new functions that operate on vectors (polygons mostly) have been removed and placed in the new 'geovec' package (on R-Forge). Fixed problem with .commonDataType, that affeced the datatype selection for crop (and some other functions). Problem report by Jon Olav Skoien. Fixed problem with focal() that, with a large filter, crashed R because of out of bound array indices in C. Problem reported by Jrme Gulat expand method implemented for Extent objects. Code provided by Etienne B. Racine Also implemented generic functions 'intersect' and 'union' for Extent objects (to replace intersectExtent and unionExtent) Legend sometimes was not entirely right when using a few breaks only (reported by Barry Rowlingson) mask now keeps layer names (suggested by Jane Elith) --- 21-December-2011, version 1.9-58 approxNA failed for large objects, reported and fixes suggested by Stefan Schlaffer Bug fixes in extract with RasterBrick (thanks to reports by Colin Rundel and Laurent Fernandez Soldevila) --- 13-December-2011, version 1.9-56 functions min, max, mean (with a RasterStackBrick object) ignored the na.rm argument. Bug reported by Maximilian Reinwand bug occurred when creating a RasterStack from a named list of Raster objects. Reported by Laurent Fernandez Fixed problem in getData: file.rename failed on some systems if the temp folder is on a different device. Reported by Edzer Pebesma --- 12-December-2011, version 1.9-55 bug fix aggregate with multi-layer objects, reported by Colin Rundel. improvements to merge (Raster,Raster) function and merge docs. bug with progressbar fixed in terrain (reported by Pascal Fust) --- 2-December-2011, version 1.9-52 writeValues methods now only available with a vector (RasterLayer) or matrix (RasterStack) argument. To avoid perhaps unexpected coercion (column-wise coercion to vector); problem pointed out by Kristina Helle. new argument 'snap' in alignExtent and crop (suggested by Matteo Mattiuzzi) approxNA can now interpolated over non-equal distance (suggested by Tobias Schmidt) bug fix for 'edge', reported by Steve Mosher. bug fix for 'expand' with mutlti-layer objects and block-wise processing, reported by Jonathan Greenberg bug fix in 'interpolate' reported by David Stephens --- 25-November-2011, version 1.9-47 Improvements to new polygon manipulation functions. Bug fixes with reclass(include.lowest=TRUE) if the reclass value was a Real (like NA) it was coerced to an integer, reported by Steve Mosher. --- 17-November-2011, version 1.9-44 fixed bug with cell values reading with BIL driver (reported by sonal singhal) fixed serious bug with a stack from different bands from the same file. .cellValues returned values for the first band only (introduced in 1.9-41?). Reported by Matteo Mattiuzzi & Benjamin Mack addition: crop method for Spatial* objects addition: aggregate (dissolve) method for SpatialPolygons* addition: merge (join) method for Spatial*DataFrame & data.frame; and for SpatialPolygons & SpatialPolygons addition: raster algebra for SpatialPolygons: + (same as function merge), - (difference), * (= function crop) --- 9-November-2011, version 1.9-41 beginCluster now has 'exclude' option (suggested by Julian Zeidler) Bug fix, as(x, 'SpatialPixels') returned SpatialPoints. reported by Clment Calange. redesigned function edge for better speed. Arguments have changed. and to deal with a bug reported by Paul Galpern improved speed of disaggregate and expand for large files (processing by block of rows rather than by row) simplified pbCreate new function for using clusters with raster functions: clusterR new .detectCores function (taken from the new (R 2.14-0) parallel package) new function approxNA to approximate NA values by cell, across layers (emerged from discussions with Jan Verbesselt). added generic functions %in% and match for Raster objects (suggested by Paul Galpern) re-implemented merge and mosaic for higher speed (by block rather than by row). re-implemented mean, min and max for higher speed blockSize now tries to respect the gdal reported block size for (hopefully) faster reading (re-implemented rasterFromGDAL to accomodate this) fixed bug with reclass right=TRUE and include.lowest=TRUE (latter argument was sometimes ignored) rasterToPolygons now has a 'dissolve' argument (requiring rgeos) --- 26-October-2011, version 1.9-33 Bug fix. When indexing with a single cell and a multi-layer object, only the value for the first layer was returned. Reported by Jan Verbesselt Fixed bug with reading multi-level (4 dimensions) ncdf files, reported by John Gross --- 24-October-2011, version 1.9-32 Expanded function KML to create time-series from multi-layer objects (suggested by Tony Fischbach) Bug fixed in sampleRegular for files with gain/offset (that were applied twice). Reported by Ned Hornig. 'offset' argument for raster(x, offset=6) when 'x' is an ascii file that has more header lines than the standard 6 lines. --- 19-October-2011, version 1.9-29 Bug fix in projectRaster with circumpolar datasets. Reported by Anthony Fischbach sampleRegular has new argument, useGDAL=FALSE. If FALSE, GDAL is not used to assure that the cells extracted are always the same, irrespective of the data source (gdal driver or not). Problem reported by Ned Hornig reclass now has option 'right=NA' (apart from right=TRUE or right=FALSE) to allow intervals to be closed at the left and right side. It is now also possible to provide a two column relassification matrix ("is-becomes") (suggestions by Agustin Lobo). --- 12-October-2011, version 1.9-27 Functions re-implemented using C routines for better speed: focal (a combination of old functions focal, focalNA and focalFilter), distance, direction, reclass and slopeAspect. reclass has changed a bit. Intervals are more rigorously defined (see arguments 'right' and 'include.lowest'), as in 'cut' slopeAspect is replaced by 'terrain' to do slope, aspect and other elevation derived terrain characteristics. Fixed subset bug reported by Julian Zeidler. https://r-forge.r-project.org/tracker/?func=detail&atid=1189&aid=1610&group_id=294 New function "log" defined seperately from the Math generics to allow for additional argument "base=x". Suggested by Oscar Perpian Lamigueiro. mask now works for the a RasterStack/Brick and Spatial* objects. Bug reported by Robert Buitenwerf --- 23-September-2011, version 1.9-19 option "useRaster" to plot. To use 'image' rather than 'rasterImage', because rasterImage not working on some platforms (windows server); in R versions above 2.13.0. The default is FALSE because 'image' is not working well in R 2.13.1 (it draws white lines over the image); but this was fixed in 2.13.1-patched and above. Bug fix: new plot argument 'addfun' interfered with old argument 'add' such that 'add=T' did not work (reported by Achilleas Psomas) Big speed gain (~50 times) for 'calc' with a RasterLayer. calc used apply(x, 1, fun) (which is more natural for RasterStackBrick objects), where it simply could use fun(x). This can now be tested using (currently undocumented) arguments forcefun=TRUE or forceapply=TRUE --- 15-September-2011, version 1.9-13 Removed backwards compatibility issue (x <- normalizePath(x) instead of x <- normalizePath(x, winslash = "/", FALSE), when creating raster from file). Reported by Julian Zeidler. --- 14-September-2011, version 1.9-12 removed backwards compatability issue (for Linux) from vignette (\SweaveOpts{resolution=100}). Reported by Mathieu Basille bug fix in sub (such that it can use field name in stead of colnumber). Reported by Alfredo Alessandrini --- 11-September-2011, version 1.9-11 new arguments to plot: fun (to transform values, e.g. log) and addfun to add e.g. points or polygons to each map in a RasterStack new argument to mask: inverse=FALSE to do mask areas that _are_ NA (rather than are _not_ NA) in the mask layerNames are now preserved when writing to (.grd) files. Bug reported by Steven Mosher. Bug fix: pairs did not show the correlation coefficient where there were NA values (reported by Jane Elith) Improved handling of multifile ncdf files & varname argument, suggested by Matt Fischer. cluster support for raster::predict function (run beginCluster() before using predict); but so far this seems to slow things down! Much improved speed of the extract function for Raster objects with many layers. Low speed was a problem reported by Jan Verbesselt http://r-sig-geo.2731867.n2.nabble.com/extracting-time-series-data-from-a-raster-brick-of-AVHRR-satellite-data-td6622055.html#a6629299 and by Nathan Amboy. Bug fix with subset of a RasterBrick from disk. Reported by Stefan Schlaffer. https://r-forge.r-project.org/tracker/?func=detail&atid=1189&aid=1520&group_id=294 Some improvements to setValues with a RasterBrick based on suggestions by Julian Zeidler https://r-forge.r-project.org/tracker/?func=detail&atid=1189&aid=1504&group_id=294 Fixed some problems (reported by Carsten Neumann) with plot that were introduced when replacing 'image' with 'rasterImage' --- 30-July-2011, version 1.9-5 Patches by Pierre Roudier to improve coercion from Raster* to Spatial* objects. new function as.data.frame for Raster* objects Removed generic function 'Median' Added generic index/replace function for Raster* and matrix. --- 19-July-2011, version 1.9-1 MAJOR bug fix in arith. If x is a Raster* object, a-x returned x-a, and a/x returned x/a. Reported by Steven Mosher. plot now uses rasterImage instead of image Replacement functions implemented for RasterStack/Brick objects (e.g., x[x<1] <- NA ) removed '$size' from list returned by 'blockSize' function (because size can be different for last block). Use $nrows[i] instead. bug fix in flip(x, 'y') for x is RasterStackBrick when writing to disk removed gplot and plot3D functions. These are now in the rasterVis package added linear and histogram stretch options to plotRGB; based on Josh Gray's code in http://spatiallyexplicit.wordpress.com/2011/06/07/crop-circles/ added a scalebar function, partly based on a function by Josh Gray --- 3-July-2011, version 1.8-39 Bug fix, cover failed with RasterBricks (reported by Steven Mosher) Quicker subset with RasterBricks (suggested by Christian Kamenik) --- 18-June-2011, version 1.8-38 Bug fix in gridDistance. Function crashed with large files and many rows with NA (reported by Corn Vreugdenhil) Bug fix in ascii file writing. In some cases NA was written as -Inf, which was not understood by gdal. gdal returned both -Inf and 0 values as NA. reprted by Enric Batllori Presas (problem probably introduced in version 1.8-16). --- 15-June-2011, version 1.8-35 new helper functions spplot for plotting Raster* objects with spplot (sp package) new helper functions gplot for plotting Raster* objects with ggplot (ggplot2 package), based on an example by Paul Hiemstra (later moved to RasterVis) new slot 'z' in Raster* objects to (somewhat) formalize management of time series. Is to replace the 'zvalue' slot new function zApply (by Oscar Perpian Lamigueiro); a stackApply for time series using the z slot. implemented generic function 'coordinates' for Raster* objects --- 3-June-2011, version 1.8-31 Added functions to coerce to RasterLayer/Brick from gre objects (geoR package), as suggested by Agustin Lobo; using generic functions as(), raster(), brick() Plot and other related functions now use the argument "ext" in stead of "extent" to avoid confusion with extent() renamed the 'ext' function to 'extension' sampleRegular of gdal files now uses rgdal for quicker sub-sampling (leading to faster plotting) Further improvements to predict. --- 25-May-2011, version 1.8-27 Arith functions now work with logical arguments (including NA). Problem reported by Agustin Lobo restored "..." argument in predict (got lost while improving it in version 1.8-22) --- 24-May-2011, version 1.8-25 (More) safer handling of the new 'rotated' slot in BasicRaster such that older raster objects do not fail. extract with polygons now can also return a value for very small polygons ("small=TRUE"). Requested by Somewhat faster rasterToPolygons multi-core (cluster) versions of extract with polygons and extract with lines --- 12-May-2011, version 1.8-22 Minor bug fix for predict when using a mgcv gam model & filename & na.rm=FALSE, file writing failed (reported by Tim Hring) Safer handling of the new 'rotated' slot in BasicRaster such that older raster objects do not fail. --- 9-May-2011, version 1.8-20 A warning is given when a rotated image is used (suggested by Agustin Lobo) New function 'rectify' to unrotate rasters Very limited initial support for rotated rasters (typically sat images). Many of the existing functions will work with these images, but results can be wrong. Should work OK for simple raster algebra etc. but probably not when joining data spatially. Although basic extract with coordinates should work OK now. Changes to calc and overlay to allow for more complex functions Changes to stackSelect to allow (optionally recycled) layer selection with a multi-layer object Faster setvalues with an array and 'brick' and 'setValues' (code changes provided by Justin McGrath) Fixed a problem with a few functions set warnings to -1 and did not reset it (reported by Justin McGrath) New option in 'hdr' to write ESRI .prj files. New global option "tolerance" that is used to assess whether Raster* objects have the same origin/resolution Improvements to hillShade thanks to Oscar Perpin Lamigueiro default NA value for reading files via gdal is now -Inf such that values are not inadvertedly classified as NA (thanks to bug report by Agustin Lobo) when using e.g. INT2U datatype. further adjustments needed for writing. focal now correct for global lon/lat data (first & last columns touch) focalFilter now using the correct "padding" for global lon/lat data (first & last columns touch) Added new functions Geary, Moran (global) and MoranLocal New option to focalFilter: "pad" to better deal with edge effects --- 11-Apr-2011, version 1.8-12 Major bug fix in focalFilter. In previous versoins results were wrong for filters larger than 3x3 ! Thanks to Nick Hamm & Andy Wilson for reporting Bug fix in cellStats with 'sd' and large files (reported by John Donoghue) --- 26-Mar-2011, version 1.8-9 Major bug fix in gridDistance with some large rasters that cannot be processed in memory (reported by Kevin Ummel) Bug fix in crop with RasterStack introduced in version 1.7-48 to keep the colortable when doing crop (reported by Kevin Ummel) Fixed error in asFactor added "alpha" (transparancy) argument to plot new function 'hillshade' new cellvalues argument to extract with lines --- 14-Mar-2011, version 1.8-3 new function 'slopeAspect' that computes slope and/or aspect non-exported classes prefixed with a '.' (to pass check in R 2.13.0) Fixed error that occured in extract (.polygonValues) when a polygon smaller than the cell size and weights=T (reported by Xin Lin) new function 'stackSelect' to select cell values from a single layer of a stack, using a RasterLayer to provide the indices. bug fix in cross-tab for large files colortable no longer lost after using 'crop' (reported by Don MacQueen) --- 26-Feb-2011, version 1.7-46 Improvments to projectRaster based on comments by George Riner resample no longer looses layer names (reported by Brian Anacker) A number of buglets fixed. Thanks to Jon Olav Skoien, Kevin Ummel & Matteo Mattiuzzi Changes to reclass such that a function like sum returns an object with the (highest) number of layers of the input objects (suggested by Neil Best) Bug fix in zonal; it did not ignore NA values. (reported by Kevin Ummel) Changes to reclass and calc (suggested by Neil Best) Fixed bug in projectRaster (reported by Bart Kranstauber) that was created with bug fix on 7-Jan-2011 ncdf write now honours the datatype argument. Code changes as suggested by Stefan Schlaffer new functions cellFromLines, cellFromPolygons (suggested by Brian Oney) --- 17-Jan-2011, version 1.7-29 bug fix in update (reported by Matteo Mattiuzzi) calc can now return multiple layers when the input is a RasterLayer (Neil Best) bug fix in extract with buffer for non-long/lat rasters (reported by Richard Plant) Fixed projectRaster for multi-layer objects (bug reported by Alison Mynsberge) bug fix in sampleInt with very large numbers (as.integer set them to NA) --- 5-Jan-2011, version 1.7-23 Bug fix in reading values from Bricks from ncdf files (reported by Martin Brandt) added "cellnumbers" argument for extract with points and buffer set factor levels in predict (bug fix suggested by Isabelle Boulangeat) refinements to overlay allowing for different number of output layers than input layers attempt to speed up stack() --- 21-Dec-2010, version 1.7-18 brick method can now take an array as argument (suggested by Agustin Lobo) fixed as.array (values were not in right order, and added argument 'transpose' 'update' now also works for a RasterBrick implemented the transpose ('t') method for Raster* objects sampleRandom has two new arguments: rowcol to return row and column number, and sp to return a SpatialPointsDataFrame (suggested by Agustin Lobo) When creating a stack from a list, the names of the list elements are used as layernames (suggested by Bart Kranstauber) update can now update netcdf files Native file format can now write in any (row) order. Small bug fix in .polygonValues (thanks to Aman Verma) new function 'update' to change values of a file linked to a RasterLayer object bug fixes in read/write SAGA format (and uses rgdal now for reading, when possible, but not yet for writing). improvements in writing RasterBrick objects to native format files. bug fixes in 'predict' with models that have factor variables. bug fixes in 'predict' for (some) model objects that are not standard (S3) models (suggested by Isabelle Boulangeat). --- 2-Dec-2010, version 1.7-8 bug fix in extract by focal area (thanks to Matteo Mattiuzzi) predict automatic removal (to NA) of factor levels not used to build the model --- 29-Nov-2010, version 1.7-6 New function as.array improved sampleRegular for multi-layer objects Code simplifications for 'raster', 'stack', and 'brick' functions raster no longer has the "values" argument (use setValues) When adding layers to a RasterBrick, a RasterStack will be returned. Fixed calc for regression functions Fixed data handling error causing full memory in extract(points, buffer) (reported by Steve Mosher) Fixed bug in projectRaster when projecting a raster from a regional crs to a global crs that caused the values to duplicate (reported by Bart Kranstauber) crosstab can now return results in 'long' format more complete and flexible recycling in overlay and Arith Added boxplot function for Raster* objects New version of alignExtent (bug reported by Keven Ummel) overlay now allows for RasterStackBrick / RasterLayer combination (bug reported by Keven Ummel) cluster object stored as 'option' --- 17-Nov-2010, version 1.6-22 NAflag honored when writing ascii file. multicore support for resample Bug fix in pairs (David Ramsey) Bug fix in rasterize with lines (Julian Burgos) --- 14-Nov-2010, version 1.6-19 Fixed bug in .stopGDALwrting (reported by Kevin Ummel and Lyndon Estes) Experimental support for multicore in functions projectRaster and distance Started support for multi-core/cluster processing (together with Matteo Mattiuzzi) Fixed bug in aggregate with unequal x and y fact (thanks to Kevin Ummel for reporting) Added drop=FALSE to "[" methods, to return a Raster*. [[ method to extract layers from multi-layer Raster objects Writing cdf files now uses the CF standard 'degrees_east' and 'degrees_north' as variable names in lon/lat data (suggested by Kevin Ummel) fixed bug when using se.fit=TRUE in predict (it did not respond to it). Reported by Eliane Meier. Also changed the above that when se.fit=T, both the prediction AND the s.e. are returned (as a RasterBrick) changed NAvalue argument in writeRaster to NAflag to avoid confusion with NAvalue function fixed backwards compatability by replacing packageVersion('rgdal') to packageDescription('rgdal')$Version --- 5-Nov-2010, version 1.6-15 'unique' now also works for multi-layer objects Using new features in GDAL 0.6-29: set statistics and capture raster attributes Replacing pointsToRater, linesToRaster and polygonsToRaster with single generic function 'rasterize' Introduces support for netcdf files with 4 dimensions (lon, lat, level, time), because of a problem reported by Kevin Ummel --- 30-Oct-2010, version 1.6-10 Improved [ and [<- methods. Removed [[ methods Introduced sub-setting of Raster* objects with Spatial* objects Additional options to linesToRaster (to match polygonsToRaster) as.matrix implemented for Raster* objects (suggested by Michael Sumner) writeRaster now takes optional arguments varname, varunit, longname, xname, yname, zname, zunit, for writing netcdf files (requested by Mario Frasca). Merged 'focalValues' into 'extract' Removed 'getValuesExtent', it was a synonym to 'extract(x=Raster, y=extent)' Temporary files are now only deleted (at startup of raster) if they are at least 24 hrs old Generic function 'cut' implemented for Raster objects (suggested by Steven Mosher) Bug fix in addLayer with RasterBrick (reported by Steven Mosher) Fixed bug in reading values from a 2-dimensional netcdf file (no 'time') (reported by Steven Mosher) Fixed bug in reading cell values from netcdf file that can not be read into memory (reported by Steven Mosher) New generic function 'extract', to replace xyValues, cellValues, lineValues, polygonValues Improvements to rasterFromXYZ (thanks to Thiago Veloso). writeHdr can now write VRT (GDAL virtual raster) header files to accompany .gri files such that these can be viewed in e.g. ArcGIS and QGIS. Adjustments to calc to allow it to return any number of layers from a computation on a multiple layer object --- 11-Oct-2010, version 1.5-16 netcdf files writing in chunks. netcdf create a RasterLayer from a RasterBrick no longer goes to disk (copy parameters in memory) raster() now also takes an "image" (a list with x, y and z) argument and coerces it to a RasterLayer bug fixes in .readRowsAscii (reported by Manuel Spnola), setMinMax filenames in Raster objects from working directory now get the full path appended (no errors when the workdir changes) new functions (under development): morph, morphMerge New function lineValues (extract values from Raster* by lines, like polygonValues) bug fixes: projectRaster now works for RasterStack objects focalFilter now works with a 'filename' argument (bug reported by Bill McCoy) Added argument NAvalue to writeRaster to allow to manually set the NA value (flag) when writing to file. Added a RasterStackBrick version of 'count' Added a RasterStackBrick version of 'flip' --- 20-Sep-2010, version 1.5-8 added functions gain, gain<-, offs, and offs<- to get or set the gain (scale) and offset parameters of a Raster object fixed bug when creating a RasterLayer from a BIL file that has the coordinates in a world file rather than in the hdr file (reported by Steven Mosher) fixed bug when creating a RasterLayer from a SAGA grid file with non-integer resolution (reported by Matthew Landis) reclass can now also process a multi-layer Raster object cover and overlay can now also process mulitple multi-layer Raster objects to return another multi-layer object improved speed of gridDistance (JvE) rasterToPoints can now take a matrix of values and return a brick with layer for each column (suggested by Steven Mosher) writeRaser (internal saveAs function) takes more care as not to overwrite its own source file, even if overwrite=TRUE calc now uses rowSums and rowMeans where appropriate, and automatically detects whether these functions are appropriate (suggested by Matteo Mattiuzzi). This is also implemented in stackApply, and improved (automatic detection) in aggregate. removed functions: 'filename<-', values, copryRasterFile, renameRasterFile, removeRasterFile. bug fix: RasterBricks sometimes had a link to the filename of the object it was created from in a computation. --- 29-Aug-2010, version 1.4-10 Minor bug fixes in ncdf/brick handling Bug fixes in dropLayer for a RasterBrick (reported by Steven Mosher) Added option 'setfileext' (default TRUE) to turn off the automatic setting of the file extension when writing raster files (based on the format). (requested by Jonathan Greenberg) ext(filename) <- 'x' now only removes the old extension if it has less than 5 characters (including the dot). Added arguments to all xyValues methods such that both of the below functions work (before only test1 would work; bug reported by Roman Lustrik) test1 = function(r, xy, ...) { return( xyValues(r, xy, ...) ) } test2 = function(r, xy, buffer, fun) { return( xyValues(r, xy, buffer=buffer, fun=fun) )} bug fixes: writing via gdal did not respond to the 'options' argument (reported by Tom Kurkowski and Jorrel Aunario) cellValues (and getValues) bug in ncdf brick fixed. (reported by Steven Mosher) new function: stackApply applies a function over sets of layers of a RasterStack/Brick 'hasValues' while 'dataContent' has now been removed. improvements: area now takes na.rm=TRUE and weights=TRUE arguments, and returns a Brick if input is Stack/Brick and na.rm=T (suggested by Steven Mosher). as.logical now works for a multi-layer object (suggested by Steven Mosher) Setting the nodata value with NAvalues now also affects reading of values from netcdf files (suggested by Steven Mosher) cellStats now returns values per layer (rather than all combined) (suggested by Steven Mosher) Minor bug fix in rasterToPoints with multi-layer objects (reported by Jon Olav Skoien). Minor bug fixes in crop (reported by Jon Olav Skoien) and in focalNA (reported by Matteo Mattiuzzi) Changes in gridDistance to avoid it (igraph) from crashing when using very complex grids. Added @data@gain and @data@offset slots to Raster* objects and use these when reading values from file v = v * gain + offset (suggestion by Jonathan Greenberg) It is now possible to do Arith (e.g. addition, multiplication) with a RasterStack or Brick using a vector argument of lenght that equals nlayers(object). E.g. you can mutliply a RasterStack with 5 layers with vector c(1,3,5,3,1), where indices are matched to layers. It is also possible to do Arith & Math with mutliple RasterStackBrick objects (as long as nlayers is the same) and with a RasterStack/Brick and a RasterLayer objects. --- 12-Aug-2010, version 1.3-11 Expanded sampleRandom by adding a 'cells' and 'extent' argument; Switched from RNetCDF to ncdf package for netcdf file support Added three slots to class BasicRaster unit='vector' ; to store the unit of the layer(s), e.g. "kg m-2 s-1" zname='character' ; to store the name of the z (layers) variable, e.g. "time" zvalue='vector' ; to store the values of the z variable, e.g. the dates corresponding to each later These slots are now filled for values from netcdf files with "CF" type convention (e.g. cmip), with an attempt to covert "days since" to a Date (coverted to string). Not yet used in writing, or with other formats New clump function, now always using igraph (also for large rasters) & minor bug fix Fixes to subs function (needs more checking) To allow for better behaviour when using objects derived from Raster* objects (perhaps in other packages), replaced code like "if (class(x) == 'RasterLayer')" with "if (inherits(x, 'RasterLayer'))" Bug fix: error when indexing a RasterStack as in s[1] (as reported by Kevin Ummel) --- 27-July-2010, version 1.3-4 Starting this log raster/R/0000755000176200001440000000000014173044242011754 5ustar liggesusersraster/R/rowMinMax.R0000644000176200001440000000054614160021141014012 0ustar liggesusers .rowMin <- function(x, na.rm=TRUE) { # .Call('raster_doRowMin', PACKAGE = 'raster', x, narm=na.rm) .doRowMin(x, narm=na.rm) } .rowMax <- function(x, na.rm=TRUE) { .doRowMax(x, narm=na.rm) } .colMin <- function(x, na.rm=TRUE) { .doRowMin(t(x), narm=na.rm) } .colMax <- function(x, na.rm=TRUE) { .doRowMax(t(x), narm=na.rm) } raster/R/GDALtransient.R0000644000176200001440000000674214160230067014545 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .getGDALtransient <- function(r, filename, options, NAflag, ...) { .GDALnodatavalue <- function(x){ if (x == 'Float32') return(-3.4E38) if (x == 'Float64') return(-1.7E308) if (x == 'Int32') return(-2147483647) if (x == 'Int16') return(-32768) if (x == 'Int8') return(-128) if (x == 'Byte') return(255) if (x == 'UInt16') return(65535) if (x == 'UInt32') return(2147483647) #(4294967295) <- not supported as integer in R stop('cannot find matching nodata value') } nbands <- nlayers(r) ct <- colortable(r) if (length(ct) > 0 ) { hasCT <- TRUE if (is.null(list(...)$datatype)) { datatype <- 'INT1U' } else { datatype <- .datatype(...) } } else { hasCT <- FALSE datatype <- .datatype(...) } isFact <- is.factor(r) if (any(isFact)) { v <- levels(r) } r <- raster(r) overwrite <- .overwrite(...) gdalfiletype <- .filetype(filename=filename, ...) .isSupportedFormat(gdalfiletype) if (filename == "") { stop('provide a filename') } if (file.exists( filename)) { if (!overwrite) { stop("filename exists; use overwrite=TRUE") } else if (!file.remove( filename)) { stop("cannot delete existing file; permission denied.") } } dataformat <- .getGdalDType(datatype, gdalfiletype) if (dataformat != 'Byte') hasCT <- FALSE if (missing(NAflag)) { NAflag <- .GDALnodatavalue(dataformat) } if (gdalfiletype=='GTiff') { bytes <- ncell(r) * dataSize(datatype) * nbands if (bytes > (4 * 1024 * 1024 * 1000) ) { # ~ 4GB options <- c(options, 'BIGTIFF=YES') } options <- c(options, "COMPRESS=LZW") } driver <- methods::new("GDALDriver", gdalfiletype) transient <- try( methods::new("GDALTransientDataset", driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL), silent=TRUE) if ( inherits(transient, "try-error")) { if (dataformat == "Float64") { dataformat <- "Float32" } transient <- methods::new("GDALTransientDataset", driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL) } for (i in 1:nbands) { b <- methods::new("GDALRasterBand", transient, i) rgdal::GDALcall(b, "SetNoDataValue", NAflag) if (hasCT) { rgdal::GDALcall(b, "SetRasterColorTable", ct) } if (isFact[i]) { vv <- v[[i]] if (NCOL(vv) > 1) { rn <- data.frame(IDID=0:max(vv[,1])) rnvv <- merge(rn, vv, by=1, all.x=TRUE) rnvv <- rnvv[order(rnvv[,1]), ] cnms <- as.character(rnvv[,2]) cnms[is.na(cnms)] <- '' rgdal::GDALcall(b, "SetCategoryNames", cnms) } } } if (rotated(r)) { gt <- r@rotation@geotrans } else { #if (flip) { # gt <- c(xmin(r), xres(r), 0, 0, ymax(r), yres(r)) # cat('flipping (this creates an invalid RasterLayer)\n') #} else { gt <- c(xmin(r), xres(r), 0, ymax(r), 0, -yres(r)) #} } rgdal::GDALcall(transient, "SetGeoTransform", gt) if (.useproj6() & !is.na(r@crs)) { if (!is.na(r@crs)) { cmt <- attr(r@crs, "comment") if (is.null(cmt)) { r@crs <- sp::CRS(r@crs@projargs) } } rgdal::GDALcall(transient, "SetProjectWkt", r@crs) } else { prj <- proj4string(r) rgdal::GDALcall(transient, "SetProject", prj) } if (is.null(options)) { options <- '' } return(list(transient, NAflag, options, dataformat)) } raster/R/naValue.R0000644000176200001440000000150514160021141013460 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .naChanged <- function(x) { if (.hasSlot(x@file, 'NAchanged')) { return(x@file@NAchanged) } else { return(TRUE) } } 'NAvalue<-' <- function(x, value) { if (inherits(x, 'RasterStack')) { nl <- nlayers(x) if (length(value) == 1) { value <- rep(value[[1]], nl) } else { v <- vector(length=nl) v[] <- as.vector(value) value <- v } for (i in 1:nl) { x@layers[[i]]@file@nodatavalue <- value[i] x@layers[[i]]@file@NAchanged <- TRUE } } else { x@file@nodatavalue <- value[[1]] x@file@NAchanged <- TRUE } return(x) } NAvalue <- function(x) { if (inherits(x, 'RasterStack')) { sapply(x@layers, function(x) { x@file@nodatavalue }) } else { return(x@file@nodatavalue) } } raster/R/gridDistance2.R0000644000176200001440000000372114160021141014551 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 .gridDistance2 <- function(x, filename='', ...) { # currently only works for planar data! rs <- res(x) xdist <- rs[1] ydist <- rs[2] xydist <- sqrt(xdist^2 + ydist^2) z1 <- z2 <- raster(x) nc <- ncol(z1) filename <- trim(filename) if (canProcessInMemory(z1)) { f <- rep(Inf, nc) z1a <- z2a <- raster(x) x <- getValues(x) a <- as.integer(dim(z1)) b <- c(xdist, ydist, xydist) z1a[] <- .broom(x, f, a, b, TRUE) z2a[] <- .broom(x, f, a, b, FALSE) x <- min(z1a, z2a) if (filename != "") { x <- writeRaster(x, filename, ...) } } else { tr <- blockSize(z1) pb <- pbCreate(tr$n*2, ...) z1 <- writeStart(z1, rasterTmpFile()) i <- 1 v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) f <- rep(Inf, nc) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), TRUE) z1 <- writeValues(z1, z, tr$row[i]) f <- z[(length(z)-nc+1):length(z)] for (i in 2:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), TRUE) z1 <- writeValues(z1, z, tr$row[i]) f <- z[(length(z)-nc+1):length(z)] pbStep(pb, i) } z1 <- writeStop(z1) z2 <- writeStart(z2, rasterTmpFile()) i <- tr$n v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) f <- rep(Inf, nc) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), TRUE) z2 <- writeValues(z2, z, tr$row[i]) f <- z[1:nc] for (i in (tr$n-1):1) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), FALSE) z2 <- writeValues(z2, z, tr$row[i]) f <- z[1:nc] pbStep(pb, i) } z2 <- writeStop(z2) x <- calc(stack(z1, z2), fun=min, filename=filename, ...) file.remove(filename(z1)) file.remove(filename(z2)) } return(x) } raster/R/names.R0000644000176200001440000000317014160021141013170 0ustar liggesusers# Author: Robert J. Hijmans # Date: October 2008 # Version 0.9 # Licence GPL v3 .uniqueNames <- function(x, sep='.') { dups <- unique(x[duplicated(x)]) for (dup in dups) { j <- which(x == dup) x[j] <- paste(x[j], sep, 1:length(j), sep='') } x } .goodNames <- function(ln, prefix='layer') { validNames(ln, prefix) } validNames <- function(x, prefix='layer') { x <- trim(as.character(x)) x[is.na(x)] <- "" if (.standardnames()) { x[x==''] <- prefix x <- make.names(x, unique=FALSE) } .uniqueNames(x) } setMethod('labels', signature(object='Raster'), function(object) { names(object) } ) setMethod('names', signature(x='Raster'), function(x) { if (.hasSlot(x@data, 'names')) { ln <- x@data@names } else { ln <- x@layernames } ln <- ln[1:nlayers(x)] validNames(as.vector(ln)) } ) setMethod('names', signature(x='RasterStack'), function(x) { ln <- sapply(x@layers, function(i) i@data@names) ln <- ln[1:nlayers(x)] validNames(as.vector(ln)) } ) setMethod('names<-', signature(x='Raster'), function(x, value) { nl <- nlayers(x) if (is.null(value)) { value <- rep('', nl) } else if (length(value) != nl) { stop('incorrect number of layer names') } value <- validNames(value) if (inherits(x, 'RasterStack')){ x@layers <- sapply(1:nl, function(i){ r <- x@layers[[i]] r@data@names <- value[i] r }) } else { if (.hasSlot(x@data, 'names')) { x@data@names <- value } else { x@layernames <- value } } return(x) } ) raster/R/localFun.R0000644000176200001440000000227014160021141013630 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 if ( !isGeneric("localFun") ) { setGeneric("localFun", function(x, y, ...) standardGeneric("localFun")) } setMethod('localFun', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ngb=5, fun, filename='', ...) { compareRaster(x,y) out <- raster(x) nc1 <- 1:(ngb*ngb) nc2 <- ((ngb*ngb)+1):(2*(ngb*ngb)) if (canProcessInMemory(x, n=2*ngb)) { vx <- getValuesFocal(x, 1, nrow(x), ngb=ngb) vy <- getValuesFocal(y, 1, nrow(y), ngb=ngb) values(out) <- apply(cbind(vx, vy), 1, function(x, ...) fun(x[nc1], x[nc2], ...)) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='localFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- apply(cbind(vx, vy), 1, function(x, ...) fun(x[nc1], x[nc2], ...)) out <- writeValues(out, v, tr$row[i]) } return(writeStop(out)) } } ) raster/R/ratify.R0000644000176200001440000000655114160021141013371 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric("ratify")) {setGeneric("ratify", function(x, ...) standardGeneric("ratify"))} setMethod("ratify", signature(x="Raster"), function(x, filename="", count=FALSE, ...) { stopifnot(nlayers(x) == 1) if (count) { f <- freq(x, useNA='no') f <- data.frame(f) colnames(f) <- c('ID', 'COUNT') } else { f <- data.frame(ID=unique(x)) } x@data@isfactor <- TRUE x@data@attributes <- list(f) if (filename != '') { x <- writeRaster(x, filename, ...) # only native format stores this, hence re-assign these: x@data@isfactor <- TRUE x@data@attributes <- list(f) } return(x) } ) .unweightRAT <- function(rat, fun='mean') { fun <- .makeTextFun(fun) x <- stats::na.omit(rat) cols <- 3:ncol(x) cls <- sapply(x[,cols,drop=FALSE], class) if (fun %in% c('min', 'max')) { if (any(cls %in% 'factor')) { warning('you cannot use a mean value for a factor') i <- which(cls %in% 'factor') + 2 x[, i] <- NA } x <- aggregate(x[,cols], x[,1,drop=FALSE], fun) x <- data.frame(ID=x[,1], COUNT=NA, x[,cols-1]) } else if (fun == 'mean') { if (any(! cls %in% c('integer', 'numeric'))) { warning('you cannot use a mean value for a variable that is not a number') i <- which(! cls %in% c('integer', 'numeric')) + 2 x[, i] <- NA } v <- aggregate(x[,2] * x[,cols], x[,1,drop=FALSE], sum) w <- aggregate(x[,2], x[,1,drop=FALSE], sum) v[,cols-1] <- v[,cols-1]/w[,2] x <- cbind(ID=v[,1], COUNT=NA, value=v[,cols-1]) } else if (fun == 'largest') { ids <- unique(x[,1]) j <- list() for (i in 1:length(ids)) { v <- subset(x, x[,1]==ids[i]) j[[i]] <- v[which.max(v[,2]), ] } return( do.call(rbind, j) ) } else if (fun == 'smallest') { ids <- unique(x[,1]) j <- list() for (i in 1:length(ids)) { v <- subset(x, x[,1]==ids[i]) j[[i]] <- v[which.min(v[,2]), ] } return( do.call(rbind, j) ) } else { stop('argument "fun" is not valid (should be "mean", "min", "max", "smallest", or "largest"') } colnames(x)[cols] <- colnames(rat)[cols] merge(unique(rat[,1,drop=FALSE]), x, by=1, all.x=TRUE) } deratify <- function(x, att=NULL, layer=1, complete=FALSE, drop=TRUE, fun='mean', filename='', ...) { x <- x[[layer]] rats <- is.factor(x) if (!rats) { warning('This layer is not a factor') return(x) } RAT <- levels(x)[[1]] if (NCOL(RAT) > 2) { if (colnames(RAT)[2] == '_WEIGHT_') { levels(x) <- .unweightRAT(RAT, fun) } } else if (NCOL(RAT) == 1) { if (complete) { x@data@isfactor <- FALSE x@data@attributes <- list() return(x) } else { warning('this layer already has a single factor level (use "complete=TRUE" to remove it)') return(x) } } nms <- colnames(RAT) if (!is.null(att)) { if (is.character(att)) { att <- stats::na.omit(match(att, nms)) if (length(att) == 0) { stop("argument 'att' does not include valid names") } } RAT <- RAT[ , c(1, att), drop=FALSE] } cc <- 2:ncol(RAT) if (drop) { for (i in cc) { options('warn'=-1) suppressWarnings(v <- as.numeric(as.character(RAT[,i]))) if (isTRUE(all(RAT[,i] == v))) { RAT[,i] <- v } } } subs(x, RAT, by=1, which=cc, subsWithNA=TRUE, filename=filename, ...) } raster/R/coverPolygons.R0000644000176200001440000000532014160021141014735 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 setMethod('cover', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ..., identity=FALSE){ valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) yy <- list(y, ...) i <- which(sapply(yy, function(x) inherits(x, 'SpatialPolygons'))) if (length(i)==0) { stop('additional arguments should be of class SpatialPolygons') } else if (length(i) < length(yy)) { warning('additional arguments that are not of class SpatialPolygons are ignored') yy <- yy[i] } if (identity) { x <- .coverIdentity(x, yy) if (inherits(x, "Spatial")) { x@proj4string <- prj } return(x) } for (y in yy) { y@proj4string <- sp::CRS(as.character(NA)) subs <- rgeos::gIntersects(x, y, byid=TRUE) if (!any(subs)) { next } else { int <- crop(y, x) x <- erase(x, int) x <- bind(x, int) } } x@proj4string <- prj x } ) .coverIdentity <- function(x, yy) { for (y in yy) { y@proj4string <- sp::CRS(as.character(NA)) i <- rgeos::gIntersects(x, y) if (!i) { next } x <- sp::spChFIDs(x, as.character(1:length(x))) y <- sp::spChFIDs(y, as.character(1:length(y))) if (.hasSlot(x, 'data')) { xnames <- colnames(x@data) } else { xnames <-NULL } if (.hasSlot(y, 'data')) { ynames <- colnames(y@data) } else { ynames <-NULL } if (is.null(xnames) & !is.null(ynames)) { dat <- y@data[NULL, ,drop=FALSE] dat[1:length(x), ] <- NA x <- sp::SpatialPolygonsDataFrame(x, dat) xnames <- ynames } yinx <- which(ynames %in% xnames) doAtt <- TRUE if (length(yinx) == 0) { doAtt <- FALSE } subs <- rgeos::gIntersects(x, y, byid=TRUE) subsx <- apply(subs, 2, any) subsy <- apply(subs, 1, any) int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_lower_td=TRUE) #if (inherits(int, "SpatialCollections")) { # if (is.null(int@polyobj)) { # ?? # warning('polygons do not intersect') # next # } # int <- int@polyobj #} if (!inherits(int, 'SpatialPolygons')) { warning('polygons do not intersect') next } if (doAtt) { ids <- do.call(rbind, strsplit(row.names(int), ' ')) idsy <- match(ids[,2], rownames(y@data)) rows <- 1:length(idsy) dat <- x@data[NULL, ,drop=FALSE] dat[rows, yinx] <- y@data[idsy, yinx] int <- sp::SpatialPolygonsDataFrame(int, dat, match.ID=FALSE) } x <- erase(x, int) if (is.null(x)) { x <- int } else { x <- bind(x, int) } } x } raster/R/projectRaster.R0000644000176200001440000003005114160241340014717 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 projectExtent <- function(object, crs) { .requireRgdal() use_proj6 <- .useproj6() object <- raster(object) dm <- oldm <- dim(object) # simple way to avoid a bug with a single column/row reported by # Jon Olav Skoien dm[1] <- max(10, dm[1]) dm[2] <- max(10, dm[2]) dim(object) <- dm pfrom <- .getCRS(object) pto <- .getCRS(crs) if (use_proj6) { projfrom <- wkt(pfrom) projto <- wkt(pto) if (is.null(projfrom) || is.null(projto)) { use_proj6 = FALSE projfrom <- pfrom projto <- pto } } else { projfrom <- proj4string(pfrom) projto <- proj4string(pto) } # rs <- res(object) # xmn <- object@extent@xmin - 0.5 * rs[1] # xmx <- object@extent@xmax + 0.5 * rs[1] # ymn <- object@extent@ymin - 0.5 * rs[2] # ymx <- object@extent@ymax + 0.5 * rs[2] # xha <- (xmn + xmx) / 2 # yha <- (ymn + ymx) / 2 # xy <- matrix(c(xmn, ymx, xha, ymx, xmx, ymx, xmn, yha, xha, yha, xmx, yha, xmn, ymn, xha, ymn, xmx, ymn), ncol=2, byrow=T) rows <- unique(c(seq(1,nrow(object), by=max(1, round(nrow(object)/50))), nrow(object))) cols <- unique(c(seq(1,ncol(object), by=max(1, round(ncol(object)/50))), ncol(object))) xy1 <- xyFromCell(object, cellFromRowCol(object, rows, 1)) xy1[,1] <- xy1[,1] - 0.5 * xres(object) xy1[1,2] <- xy1[1,2] + 0.5 * yres(object) xy1[nrow(xy1),2] <- xy1[nrow(xy1),2] + 0.5 * yres(object) xy2 <- xyFromCell(object, cellFromRowCol(object, rows, ncol(object))) xy2[,1] <- xy2[,1] + 0.5 * xres(object) xy2[1,2] <- xy2[1,2] + 0.5 * yres(object) xy2[nrow(xy2),2] <- xy2[nrow(xy2),2] + 0.5 * yres(object) xy3 <- xyFromCell(object, cellFromRowCol(object, 1, cols)) xy3[,2] <- xy3[,2] + 0.5 * yres(object) xy3[1,1] <- xy3[1,1] - 0.5 * xres(object) xy3[ncol(xy3),1] <- xy3[ncol(xy3),1] + 0.5 * xres(object) xy4 <- xyFromCell(object, cellFromRowCol(object, nrow(object), cols)) xy4[,2] <- xy4[,2] - 0.5 * yres(object) xy4[1,1] <- xy4[1,1] - 0.5 * xres(object) xy4[ncol(xy4),1] <- xy4[ncol(xy4),1] + 0.5 * xres(object) # added for circumpolar data: if (nrow(object) > 75 & ncol(object) > 75) { xy5 <- sampleRegular(object, 500, xy=TRUE) # rows <- c(seq(min(nrow(object), 25), nrow(object), by=50)) # cols <- c(seq(min(ncol(object), 25), ncol(object), by=50)) # xy5 <- xyFromCell(object, cellFromRowColCombine(object, rows, cols)) xy <- rbind(xy1, xy2, xy3, xy4, xy5) } else { xy <- rbind(xy1, xy2, xy3, xy4) } if (use_proj6) { res <- rgdal::rawTransform( projfrom, projto, nrow(xy), xy[,1], xy[,2], wkt=use_proj6) } else { res <- rgdal::rawTransform( projfrom, projto, nrow(xy), xy[,1], xy[,2]) } x <- res[[1]] y <- res[[2]] xy <- cbind(x, y) xy <- subset(xy, !(is.infinite(xy[,1]) | is.infinite(xy[,2])) ) x <- xy[,1] y <- xy[,2] if (length(y) == 0 | length(y) ==0) { stop("cannot do this transformation") } minx <- min(x) maxx <- max(x) if (maxx == minx) { maxx <- maxx + 0.5 minx <- minx - 0.5 } miny <- min(y) maxy <- max(y) if (maxy == miny) { maxy <- maxy + 0.5 miny <- miny - 0.5 } obj <- raster(extent(minx, maxx, miny, maxy), nrows=oldm[1], ncols=oldm[2], crs=crs) return(obj) } .computeRes <- function(obj, crs, proj6) { x <- xmin(obj) + 0.5 * (xmax(obj) - xmin(obj)) y <- ymin(obj) + 0.5 * (ymax(obj) - ymin(obj)) res <- res(obj) x1 <- x - 0.5 * res[1] x2 <- x + 0.5 * res[1] y1 <- y - 0.5 * res[2] y2 <- y + 0.5 * res[2] xy <- cbind(c(x1, x2, x, x), c(y, y, y1, y2)) fromcrs <- .getCRS(obj) if (proj6) { fromcrs <- wkt(fromcrs) pXY <- rgdal::rawTransform(fromcrs, crs, nrow(xy), xy[,1], xy[,2], wkt=proj6) } else { fromcrs <- proj4string(fromcrs) pXY <- rgdal::rawTransform(fromcrs, crs, nrow(xy), xy[,1], xy[,2]) } pXY <- cbind(pXY[[1]], pXY[[2]]) # out <- c((pXY[2,1] - pXY[1,1]), (pXY[4,2] - pXY[3,2])) outex <- extent(pXY) out <- c(xmax(outex) - xmin(outex), ymax(outex) - ymin(outex)) if (any(is.na(out))) { if (isLonLat(obj)) { out <- pointDistance(cbind(x1, y1), cbind(x2, y2), lonlat=TRUE) out <- c(out, out) } else { out <- res } } # abs should not be necessary, but who knows what a projection might do? abs( signif(out, digits=3) ) } .getAlignedRaster <- function(x,y) { x <- raster(x) y <- raster(y) p <- projectRaster(x, crs=.getCRS(y)) m <- merge(extent(y), extent(p)) rx <- extend(y, m) crop(rx, p) } projectRaster <- function(from, to, res, crs, method="bilinear", alignOnly=FALSE, over=FALSE, filename="", ...) { .requireRgdal() use_proj6 <- .useproj6() projfrom <- .getCRS(from) if (is.na(projfrom)) { stop("input projection is NA") } if (use_proj6) { if (is.null(wkt(projfrom))) { use_proj6 = FALSE } } lonlat <- isLonLat(projfrom) if (missing(to)) { if (missing(crs)) { stop("both 'to' and 'crs' arguments are missing.") } projto <- .getCRS(crs) if (use_proj6) { if (is.null(wkt(projto))) { use_proj6 = FALSE } } #compareCRS(projfrom, projto) if (use_proj6) { if (rgdal::compare_CRS(projto, projfrom)["strict"]) { warning("input and ouput crs are the same") #return(from) } projfrom <- wkt(projfrom) } else { if ( proj4string(projto) == proj4string(projfrom)) { warning("input and ouput crs are the same") } projfrom <- proj4string(projfrom) } to <- projectExtent(from, projto) to@crs <- projto if (use_proj6) { projto <- wkt(projto) } else { projto <- proj4string(projto) } if (missing(res)) { res <- .computeRes(from, projto, use_proj6) } res(to) <- res # add some cells to capture curvature e <- extent(to) add <- min(5, min(dim(to)[1:2])/10) * max(res) e@ymin <- e@ymin - add e@ymax <- e@ymax + add e@xmin <- e@xmin - add e@xmax <- e@xmax + add if (!is.character(projto)) projto <- projto@projargs if (substr(projto, 1, 13) == "+proj=longlat") { e@xmin <- max(-180, e@xmin) e@xmax <- min(180, e@xmax) e@ymin <- max(-90, e@ymin) e@ymax <- min(90, e@ymax) } to <- extend(to, e) } else { projto <-.getCRS(to) if (is.na(projto)) { stop("output projection is NA") } if (use_proj6) { if (rgdal::compare_CRS(projto, projfrom)["strict"]) { warning("input and ouput crs are the same") } projfrom <- wkt(projfrom) } else { if ( proj4string(projto) == proj4string(projfrom)) { warning("input and ouput crs are the same") } projfrom = proj4string(projfrom) } e <- extent( projectExtent(from, projto) ) add <- min(10, min(dim(to)[1:2])/10) * max(raster::res(to)) e@ymin <- e@ymin - add e@ymax <- e@ymax + add e@xmin <- e@xmin - add e@xmax <- e@xmax + add if (isLonLat(projto)) { e@xmin <- max(-180, e@xmin) e@xmax <- min(180, e@xmax) e@ymin <- max(-90, e@ymin) e@ymax <- min(90, e@ymax) } if (use_proj6) { projto <- wkt(projto) } else { projto <- proj4string(projto) } } methods::validObject(to) methods::validObject(.getCRS((to))) #if (identical(projfrom, projto)) { # warning('projections of "from" and "to" are the same') #} if ((!use_proj6) & lonlat & over) { projto_int <- paste(projto, "+over") } else { projto_int <- projto } if (alignOnly) { to <- .getAlignedRaster(from, to) return (to) } # pbb <- projectExtent(to,.getCRS(from)) # bb <- intersect(extent(pbb), extent(from)) # methods::validObject(bb) if (!method %in% c('bilinear', 'ngb')) { stop('invalid method') } nl <- nlayers(from) if ( nl == 1) { to <- raster(to) if (method=="ngb") { colortable(to) <- colortable(from) } } else { to <- brick(to, values=FALSE, nl=nl) } if (method=='ngb') { method <- 'simple' # for extract (.xyValues) } names(to) <- names(from) if ( ! hasValues(from) ) { #warning("'from' has no cell values") return(to) } if (canProcessInMemory(to, n=nl*4)) { inMemory <- TRUE } else { inMemory <- FALSE } if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(ceiling(to@nrows/10), length(cl)) # at least 10 rows per node message('Using cluster with ', nodes, ' nodes') utils::flush.console() tr <- blockSize(to, minblocks=nodes) pb <- pbCreate(tr$n, label='projectRaster', ...) parallel::clusterExport(cl, c('tr', 'to', 'from', 'e', 'nl', 'projto_int', 'projfrom', 'method'), envir=environment()) clFun <- function(i) { start <- cellFromRowCol(to, tr$row[i], 1) end <- start + tr$nrows[i] * ncol(to) - 1 cells <- start:end xy <- xyFromCell(to, cells) xy <- subset(xy, xy[,1] > e@xmin & xy[,1] < e@xmax) v <- matrix(nrow=length(cells), ncol=nl) if (nrow(xy) > 0) { ci <- match(cellFromXY(to, xy), cells) if (use_proj6) { xy <- rgdal::rawTransform(projto_int, projfrom, nrow(xy), xy[,1], xy[,2], wkt=use_proj6) } else { xy <- rgdal::rawTransform(projto_int, projfrom, nrow(xy), xy[,1], xy[,2]) } xy <- cbind(xy[[1]], xy[[2]]) v[ci, ] <- .xyValues(from, xy, method=method) } return(v) } .sendCall <- eval( parse( text="parallel:::sendCall") ) # for debugging # parallel::clusterExport(cl,c("tr", "projto", "projfrom", "method", "from", "to")) for (i in 1:nodes) { .sendCall(cl[[i]], clFun, list(i), tag=i) } if (inMemory) { v <- matrix(nrow=ncell(to), ncol=nlayers(from)) for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success) { print(d) stop('cluster error') } start <- cellFromRowCol(to, tr$row[d$value$tag], 1) end <- start + tr$nrows[d$value$tag] * ncol(to) - 1 v[start:end, ] <- d$value$value ni <- nodes+i if (ni <= tr$n) { .sendCall(cl[[d$node]], clFun, list(ni), tag=ni) } } to <- setValues(to, v) if (filename != '') { to <- writeRaster(to, filename, ...) } pbClose(pb) return(to) } else { to <- writeStart(to, filename=filename, ...) for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { print(d) stop('cluster error') } to <- writeValues(to, d$value$value, tr$row[d$value$tag]) ni <- nodes+i if (ni <= tr$n) { .sendCall(cl[[d$node]], clFun, list(ni), tag=ni) } } pbClose(pb) to <- writeStop(to) return(to) } } else { # this seems to need smaller chunks #cz <- max(5, 0.1 * .chunk() / nlayers(to)) if (inMemory) { xy <- sp::coordinates(to) xy <- subset(xy, xy[,1] > e@xmin & xy[,1] < e@xmax) cells <- cellFromXY(to, xy) if (use_proj6) { xy <- rgdal::rawTransform( projto_int, projfrom, nrow(xy), xy[,1], xy[,2], wkt=use_proj6 ) } else { xy <- rgdal::rawTransform( projto_int, projfrom, nrow(xy), xy[,1], xy[,2]) } xy <- cbind(xy[[1]], xy[[2]]) to[cells] <- .xyValues(from, xy, method=method) if (filename != '') { to <- writeRaster(to, filename, ...) } return(to) } else { tr <- blockSize(to, n=nlayers(to)*4) pb <- pbCreate(tr$n, label='projectRaster', ...) to <- writeStart(to, filename=filename, ...) for (i in 1:tr$n) { cells <- cellFromRowCol(to, tr$row[i], 1):cellFromRowCol(to, tr$row[i]+tr$nrows[i]-1, ncol(to)) xy <- xyFromCell(to, cells ) xy <- subset(xy, xy[,1] > e@xmin & xy[,1] < e@xmax) if (nrow(xy) > 0) { ci <- match(cellFromXY(to, xy), cells) if (use_proj6) { xy <- rgdal::rawTransform( projto_int, projfrom, nrow(xy), xy[,1], xy[,2], wkt=use_proj6 ) } else { xy <- rgdal::rawTransform( projto_int, projfrom, nrow(xy), xy[,1], xy[,2]) } xy <- cbind(xy[[1]], xy[[2]]) v <- matrix(nrow=length(cells), ncol=nl) v[ci, ] <- .xyValues(from, xy, method=method) to <- writeValues(to, v, tr$row[i]) } pbStep(pb) } pbClose(pb) to <- writeStop(to) return(to) } } } raster/R/scale.R0000644000176200001440000000146114160021141013155 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 setMethod('scale', signature('Raster'), function(x, center=TRUE, scale=TRUE) { if (canProcessInMemory(x)) { v <- values(x) x <- setValues(x, scale(v, center=center, scale=scale)) return(x) } if (!is.logical(center)) { stopifnot(length(center) == nlayers(x)) x <- x - center } else if (center) { m <- cellStats(x, 'mean', na.rm=TRUE) x <- x - m } if (!is.logical(scale)) { stopifnot(length(scale) == nlayers(x)) x <- x / scale } else if (scale) { if (center[1] & is.logical(center[1])) { st <- cellStats(x, 'sd', na.rm=TRUE) } else { st <- cellStats(x, 'rms', na.rm=TRUE) } x <- x / st } x } ) raster/R/commonDataType.R0000644000176200001440000000146614160021141015017 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2011 # Version 1.0 # Licence GPL v3 .commonDataType <- function(dtype) { dtype <- as.vector(unlist(dtype, use.names = FALSE)) dtype <- unique(dtype) if (length(dtype)==1) { datatype <- dtype } else { dsize <- dataSize(dtype) dtype <- .shortDataType(dtype) if (any(dtype == 'FLT')) { dsize <- max(dsize[dtype=='FLT']) datatype <- paste('FLT', dsize, 'S', sep='') } else { signed <- dataSigned(dtype) dsize <- max(dsize) if (all(signed)) { datatype <- paste('INT', dsize, 'S', sep='') } else if (all(!signed)) { datatype <- paste('INT', dsize, 'U', sep='') } else { dsize <- ifelse(dsize == 1, 2, ifelse(dsize == 2, 4, 8)) datatype <- paste('INT', dsize, 'S', sep='') } } } datatype } raster/R/isLonLat.R0000644000176200001440000000525714160236006013632 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .isGlobalLonLat <- function(x) { res <- FALSE tolerance <- 0.1 scale <- xres(x) if (isTRUE(all.equal(xmin(x), -180, tolerance=tolerance, scale=scale)) & isTRUE(all.equal(xmax(x), 180, tolerance=tolerance, scale=scale))) { if (couldBeLonLat(x, warnings=FALSE)) { res <- TRUE } } res } .couldBeLonLat <- function(x, warnings=TRUE) { crsLL <- isLonLat(x) crsNA <- is.na(projection(x)) e <- extent(x) extLL <- (e@xmin > -365 & e@xmax < 365 & e@ymin > -90.1 & e@ymax < 90.1) if (extLL & isTRUE(crsLL)) { return(TRUE) } else if (extLL & crsNA) { if (warnings) { warning('CRS is NA. Assuming it is longitude/latitude') } return(TRUE) } else if (isTRUE(crsLL)) { if (warnings) { warning('raster has a longitude/latitude crs, but coordinates do not match that') } return(TRUE) } else { return(FALSE) } } setMethod("couldBeLonLat", signature("ANY"), function(x, warnings=TRUE, ...) { .couldBeLonLat(x, warnings=warnings) } ) setMethod("couldBeLonLat", signature("BasicRaster"), function(x, warnings=TRUE, ...) { .couldBeLonLat(x, warnings=warnings) } ) setMethod("couldBeLonLat", signature("Spatial"), function(x, warnings=TRUE, ...) { .couldBeLonLat(x, warnings=warnings) } ) setMethod('isLonLat', signature(x='Spatial'), function(x, ...){ isLonLat(projection(x)) } ) setMethod('isLonLat', signature(x='BasicRaster'), # copied from the SP package (slightly adapted) #author: # ... function(x, ...){ p4str <- proj4string(x) if (is.na(p4str) || nchar(p4str) == 0) { return(FALSE) } res <- grep("longlat", p4str, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='character'), # copied from the SP package (slightly adapted) #author: # ... function(x, ...){ res <- grep("longlat", x, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='CRS'), # copied from the SP package (slightly adapted) #author: # ... function(x, ...){ if (is.na(x@projargs)) { return(FALSE) } else { s <- trim(x@projargs) } if (is.na(s) || nchar(s) == 0) { return(FALSE) } s <- gsub(" ", "", s) res1 <- grep("longlat", s) res2 <- grep("+init=epsg:4326", s) res <- c(res1, res2) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='ANY'), function(x, ...){ isLonLat(as.character(x)) } ) raster/R/show.R0000644000176200001440000002066714160241414013066 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod ('show' , 'Extent', function(object) { cat('class :' , class(object), '\n') cat('xmin :' , xmin(object), '\n') cat('xmax :' , xmax(object), '\n') cat('ymin :' , ymin(object), '\n') cat('ymax :' , ymax(object), '\n') } ) setMethod ('show' , 'BasicRaster', function(object) { cat('class :' , class(object), '\n') cat('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object),' (nrow, ncol, ncell)\n', sep="" ) cat('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat('crs :' , proj4string(object), '\n') } ) setMethod ('show' , 'RasterLayer', function(object) { cat('class :' , class(object), '\n') if (rotated(object)) { cat('rotated : TRUE\n') } if (nbands(object) > 1) { cat('band :' , bandnr(object), ' (of ', nbands(object), ' bands)\n') } cat('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object),' (nrow, ncol, ncell)\n', sep="" ) cat('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat('crs :' , proj4string(object), '\n') if (hasValues(object)) { fd <- object@data@fromdisk if (fd) { cat('source :', basename(filename(object)), '\n') } else { cat('source : memory\n') } cat('names :', names(object), '\n') if (object@data@haveminmax) { cat('values : ', minValue(object), ', ', maxValue(object), ' (min, max)\n', sep="") } } if (is.factor(object)) { x <- object@data@attributes[[1]] nc <- NCOL(x) # this can actually happen, but x should be a data.frame anyway #if (nc == 1) { # this should never happen # x <- data.frame(value=x) #} maxnl <- 12 if (nc > maxnl) { x <- x[, 1:maxnl] } #nfact <- sapply(1:ncol(x), function(i) is.numeric(x[,i])) if (nrow(x) > 5) { cat('attributes :\n') r <- x[c(1, nrow(x)), ,drop=FALSE] for (j in 1:ncol(r)) { r[is.numeric(r[,j]) & !is.finite(r[,j]), j] <- NA } r <- data.frame(x=c('from:','to :'), r) a <- colnames(x) colnames(r) <- c(' fields :', a) colnames(r) <- c('', a) rownames(r) <- NULL if (nc > maxnl) { r <- cbind(r, '...'=rbind('...', '...')) } print(r, row.names=FALSE) } else { cat('attributes :\n') print(x, row.names=FALSE) } } else { z <- getZ(object) if (length(z) > 0) { name <- names(object@z) if (is.null(name)) name <- 'z-value' name <- paste(sprintf("%-11s", name), ':', sep='') cat(name, as.character(z[1]), '\n') } if (object@file@driver == 'netcdf') { z <- attr(object@data, 'zvar') if (!is.null(z)) { cat('zvar :', z, '\n') } z <- attr(object@data, 'level') if (!is.null(z)) { if (z>0) { cat('level :', z, '\n') } } } } cat ('\n') } ) setMethod ('show' , 'RasterBrick', function ( object ) { cat ('class :' , class ( object ) , '\n') if (rotated(object)) { cat('rotated : TRUE\n') } mnr <- 15 nl <- nlayers(object) cat ('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object), ', ', nl, ' (nrow, ncol, ncell, nlayers)\n', sep="" ) #cat ('ncell :' , ncell(object), '\n') cat ('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat ('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat ('crs :' , proj4string(object), '\n') ln <- names(object) if (nl > mnr) { ln <- c(ln[1:mnr], '...') } if (hasValues(object)) { fd <- object@data@fromdisk if (fd) { cat('source :', basename(filename(object)), '\n') } else { cat('source : memory\n') } if (object@data@haveminmax) { minv <- format(minValue(object)) maxv <- format(maxValue(object)) minv <- gsub('Inf', '?', minv) maxv <- gsub('-Inf', '?', maxv) if (nl > mnr) { minv <- c(minv[1:mnr], '...') maxv <- c(maxv[1:mnr], '...') } n <- nchar(ln) if (nl > 5) { b <- n > 26 if (any(b)) { mid <- floor(n/2) ln[b] <- paste(substr(ln[b], 1, 9), '//', substr(ln[b], nchar(ln[b])-9, nchar(ln[b])), sep='') } } w <- pmax(nchar(ln), nchar(minv), nchar(maxv)) m <- rbind(ln, minv, maxv) # a loop because 'width' is not recycled by format for (i in 1:ncol(m)) { m[,i] <- format(m[,i], width=w[i], justify="right") } cat('names :', paste(m[1,], collapse=', '), '\n') cat('min values :', paste(m[2,], collapse=', '), '\n') cat('max values :', paste(m[3,], collapse=', '), '\n') } else { cat('names :', paste(ln, collapse=', '), '\n') } } z <- getZ(object) if (length(z) > 0) { name <- names(object@z) if (is.null(name)) name <- 'z-value' name <- paste(sprintf("%-11s", name), ':', sep='') if (length(z) < mnr) { cat(name, paste(as.character(z), collapse=', '), '\n') } else { cat(name, paste(as.character(range(z)), collapse=', '), '(min, max)\n') } } if (object@file@driver == 'netcdf') { z <- attr(object@data, 'zvar') if (!is.null(z)) { cat('varname :', z, '\n') } z <- attr(object@data, 'level') if (!is.null(z)) { if (z>0) { cat('level :', z, '\n') } } } cat ('\n') } ) setMethod ('show' , 'RasterStack', function ( object ) { cat ('class :' , class ( object ) , '\n') if (rotated(object)) { cat('rotated : TRUE\n') } mnr <- 15 if (filename(object) != '') { cat ('filename :' , filename(object), '\n') } nl <- nlayers(object) if (nl == 0) { cat ('nlayers :' , nl, '\n') } else { cat ('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object), ', ', nl, ' (nrow, ncol, ncell, nlayers)\n', sep="" ) #cat ('ncell :' , ncell(object), '\n') cat ('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat ('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat ('crs :' , proj4string(object), '\n') ln <- names(object) if (nl > mnr) { ln <- c(ln[1:mnr], '...') } n <- nchar(ln) if (nl > 5) { b <- n > 26 if (any(b)) { ln[b] <- paste(substr(ln[b], 1, 9), '//', substr(ln[b], nchar(ln[b])-9, nchar(ln[b])), sep='') } } minv <- minValue(object) if (all(is.na(minv))) { cat('names :', paste(ln, collapse=', '), '\n') } else { minv <- format(minv) maxv <- format(maxValue(object)) minv <- gsub('NA', '?', minv) maxv <- gsub('NA', '?', maxv) if (nl > mnr) { minv <- c(minv[1:mnr], '...') maxv <- c(maxv[1:mnr], '...') } w <- pmax(nchar(ln), nchar(minv), nchar(maxv)) m <- rbind(ln, minv, maxv) # a loop because 'width' is not recycled by format for (i in 1:ncol(m)) { m[,i] <- format(m[,i], width=w[i], justify="right") } cat('names :', paste(m[1,], collapse=', '), '\n') cat('min values :', paste(m[2,], collapse=', '), '\n') cat('max values :', paste(m[3,], collapse=', '), '\n') } } z <- getZ(object) if (length(z) > 0) { name <- names(object@z) if (is.null(name)) name <- 'z-value' if (name == '') name <- 'z-value' name <- paste(sprintf("%-12s", name), ':', sep='') if (length(z) < mnr) { cat(name, paste(as.character(z), collapse=', '), '\n') } else { z <- range(z) cat(name, paste(as.character(z), collapse=' - '), '(range)\n') } } cat ('\n') } ) setMethod ('show' , '.RasterList', function(object) { cat('class :' , class(object), '\n') cat('length : ', length(object), '\n', sep="" ) } ) raster/R/clusterR.R0000644000176200001440000001217014160021141013670 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 clusterR <- function(x, fun, args=NULL, export=NULL, filename='', cl=NULL, m=2, ...) { if (is.null(cl)) { cl <- getCluster() on.exit( returnCluster() ) } if (!is.null(export)) { parallel::clusterExport(cl, export) } .sendCall <- eval( parse( text="parallel:::sendCall") ) nodes <- length(cl) out <- raster(x) m <- max(1, round(m)) tr <- blockSize(x, minblocks=nodes*m ) if (tr$n < nodes) { nodes <- tr$n } tr$row2 <- tr$row + tr$nrows - 1 pb <- pbCreate(tr$n, label='clusterR', ...) if (!is.null(args)) { stopifnot(is.list(args)) clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) getValues(r) } } for (i in 1:nodes) { .sendCall(cl[[i]], clusfun, list(fun, i), tag=i) } if (canProcessInMemory(x)) { for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { print(d$value$value) stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } res <- matrix(NA, nrow=ncell(out), ncol=nl) } j <- d$value$tag res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } pbClose(pb) return(out) } else { for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } out <- writeStart(out, filename=filename, ...) } out <- writeValues(out, d$value$value, tr$row[d$value$tag]) ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- writeStop(out) pbClose(pb) return(out) } } .clusterR2 <- function(x, fun, args=NULL, filename='', cl=NULL, m=2, ...) { if (is.null(cl)) { cl <- getCluster() on.exit( returnCluster() ) } nodes <- length(cl) out <- raster(x) m <- max(1, round(m)) tr <- blockSize(x, minblocks=max(nodes+1, nodes*m)) nodes <- min(nodes, tr$n-1) tr$row2 <- tr$row + tr$nrows - 1 pb <- pbCreate(tr$n, label='clusterR', ...) canPiM <- canProcessInMemory(x) .sendCall <- eval( parse( text="parallel:::sendCall") ) if (!is.null(args)) { stopifnot(is.list(args)) if (canPiM) { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) writeValues(out, getValues(r), tr$row[i]) return(i) } } } else { if (canPiM) { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) writeValues(out, getValues(r), tr$row[i]) return(i) } } } if (canPiM) { for (i in 1:nodes) { .sendCall(cl[[i]], clusfun, list(fun, i), tag=i) } for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } res <- matrix(NA, nrow=ncell(out), ncol=nl) } j <- d$value$tag res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } pbClose(pb) return(out) } else { r <- crop(x, extent(out, r1=tr$row[1], r2=tr$row2[1], c1=1, c2=ncol(out))) r <- fun(values(r)) nl <- NCOL(r) if (nl > 1) { out <- brick(out, nl=nl) } out <- writeStart(out, filename=filename, ...) out <- writeValues(out, r, 1) for (i in 1:nodes) { .sendCall(cl[[i]], clusfun, list(fun, i+1), tag=i+1) } for (i in 2:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { stop('cluster error') } ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- writeStop(out) pbClose(pb) return(out) } } raster/R/calc.R0000644000176200001440000001454314160021141012775 0ustar liggesusers# Author: Robert J. Hijmans & Matteo Mattiuzzi # Date : June 2008 # Version 0.9 # Licence GPL v3 .makeTextFun <- function(fun) { if (class(fun)[1] != 'character') { if (is.primitive(fun)) { test <- try(deparse(fun)[[1]], silent=TRUE) if (test == '.Primitive(\"sum\")') { fun <- 'sum' } else if (test == '.Primitive(\"min\")') { fun <- 'min' } else if (test == '.Primitive(\"max\")') { fun <- 'max' } } else { test1 <- isTRUE(try( deparse(fun)[2] == 'UseMethod(\"mean\")', silent=TRUE)) test2 <- isTRUE(try( fun@generic == 'mean', silent=TRUE)) if (test1 | test2) { fun <- 'mean' } } } return(fun) } .getRowFun <- function(fun) { if (fun == 'mean') { return(rowMeans) } else if (fun == 'sum') { return(rowSums) } else if (fun == 'min') { return(.rowMin) } else if (fun == 'max') { return(.rowMax) } else { stop('unknown fun') } } .getColFun <- function(fun) { if (fun == 'mean') { return(colMeans) } else if (fun == 'sum') { return(colSums) } else if (fun == 'min') { return(.colMin) } else if (fun == 'max') { return(.colMax) } else { stop('unknown fun') } } .calcTest <- function(tstdat, fun, na.rm, forcefun=FALSE, forceapply=FALSE) { if (forcefun & forceapply) { forcefun <- FALSE forceapply <- FALSE } trans <- FALSE doapply <- FALSE makemat <- FALSE nl <- NCOL(tstdat) if (nl == 1) { # the main difference with nl > 1 is that # it is important to avoid using apply when a normal fun( ) call will do. # that is a MAJOR time saver. But in the case of a RasterStackBrick it is more # natural to try apply first. if (forceapply) { doapply <- TRUE makemat <- TRUE tstdat <- matrix(tstdat, ncol=1) if (missing(na.rm)) { test <- try( apply(tstdat, 1, fun), silent=TRUE) } else { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) } if (length(test) < length(tstdat) | inherits(test, "try-error")) { stop('cannot forceapply this function') } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } else { if (! missing(na.rm)) { test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) if (inherits(test, "try-error")) { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) doapply <- TRUE if (inherits(test, "try-error")) { stop("cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?") } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } } else { test <- try(fun(tstdat), silent=TRUE) if (length(test) < length(tstdat) | inherits(test, "try-error")) { doapply <- TRUE makemat <- TRUE tstdat <- matrix(tstdat, ncol=1) test <- try( apply(tstdat, 1, fun), silent=TRUE) if (inherits(test, "try-error")) { stop("cannot use this function") } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } } } } else { if (forcefun) { doapply <- FALSE test <- fun(tstdat) } else { doapply <- TRUE if (! missing(na.rm)) { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) if (inherits(test, "try-error")) { doapply <- FALSE test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) if (inherits(test, "try-error")) { stop("cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?") } } else if (is.matrix(test)) { trans <- TRUE } } else { test <- try( apply(tstdat, 1, fun), silent=TRUE) if (inherits(test, "try-error")) { doapply <- FALSE test <- try(fun(tstdat), silent=TRUE) if (inherits(test, "try-error")) { stop("cannot use this function") } } else if (is.matrix(test)) { trans <- TRUE } } } } if (trans) { test <- t(test) test <- ncol(test) } else { test <- length(test) / 5 } nlout <- as.integer(test) list(doapply=doapply, makemat=makemat, trans=trans, nlout=nlout) } #.calcTest(test[1:5], fun, forceapply=T) setMethod('calc', signature(x='Raster', fun='function'), function(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) { nl <- nlayers(x) test <- .calcTest(x[1:5], fun, na.rm, forcefun, forceapply) doapply <- test$doapply makemat <- test$makemat trans <- test$trans nlout <- test$nlout if (nlout == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) out@data@nlayers <- nlout } fun <- .makeTextFun(fun) if (class(fun)[1] == 'character') { doapply <- FALSE fun <- .getRowFun(fun) } filename <- trim(filename) estnl <- (nlayers(x) + nlayers(out)) * 2 if (canProcessInMemory(x, estnl)) { x <- getValues(x) if (makemat) { x <- matrix(x, ncol=1) } if (missing(na.rm)) { if (! doapply ) { x <- fun(x ) } else { x <- apply(x, 1, fun ) } } else { if ( ! doapply ) { x <- fun(x, na.rm=na.rm ) } else { x <- apply(x, 1, fun, na.rm=na.rm) } } if (trans) { x <- t(x) } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } # else x <- readStart(x) out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=estnl) pb <- pbCreate(tr$n, label='calc', ...) if (missing(na.rm)) { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if ( ! doapply ) { v <- fun(v) if (nlout > 1 && !is.matrix(v)) { v <- matrix(v, ncol=nlout) } } else { if (makemat) { v <- matrix(v, ncol=1) } v <- apply(v, 1, fun) if (trans) { v <- t(v) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if ( ! doapply ) { v <- fun(v, na.rm=na.rm) if (nlout > 1 && !is.matrix(v)) { v <- matrix(v, ncol=nlout) } } else { if (makemat) { v <- matrix(v, ncol=1) } v <- apply(v, 1, fun, na.rm=na.rm) if (trans) { v <- t(v) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb) } } out <- writeStop(out) x <- readStop(x) pbClose(pb) return(out) } ) raster/R/values.R0000644000176200001440000000121314160021141013360 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('values', signature(x='Raster'), function(x, ...) { getValues(x, ...) }) setMethod('values<-', signature(x='RasterLayer'), function(x, value) { setValues(x, value) } ) setMethod('values<-', signature(x='RasterBrick'), function(x, value) { setValues(x, values=value, layer=-1) } ) setMethod('values<-', signature(x='RasterStack'), function(x, value) { setValues(x, values=value, layer=-1) } ) setMethod('values<-', signature(x='RasterLayerSparse'), function(x, value) { setValues(x, value, index=NULL) } ) raster/R/reclassify.R0000644000176200001440000000477214160021141014242 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod('reclassify', signature(x='Raster', rcl='ANY'), function(x, rcl, filename='', include.lowest=FALSE, right=TRUE, ...) { filename <- trim(filename) if ( is.null(dim(rcl)) ) { rcl <- matrix(rcl, ncol=3, byrow=TRUE) } else if ( dim(rcl)[2] == 1 ) { rcl <- matrix(rcl, ncol=3, byrow=TRUE) } else if (is.data.frame(rcl)) { rcl <- as.matrix(rcl) } nc <- ncol(rcl) if ( nc != 3 ) { if (nc == 2) { colnames(rcl) <- c("Is", "Becomes") if (getOption('verbose')) { print(rcl) } rcl <- cbind(rcl[,1], rcl) right <- NA } else { stop('rcl must have 2 or 3 columns') } } else { colnames(rcl) <- c("From", "To", "Becomes") if (getOption('verbose')) { print(rcl) } } hasNA <- FALSE onlyNA <- FALSE valNA <- NA # if (nc == 3) { i <- which(is.na(rcl[, 1]) | is.na(rcl[, 2])) if (length(i) > 0) { valNA <- rcl[i[1],3] hasNA <- TRUE rcl <- rcl[-i, ,drop=FALSE] } # } else { # i <- which(is.na(rcl[, 1])) # if (length(i) > 1) { # valNA <- rcl[i[1], 2] # hasNA <- TRUE # rcl <- rcl[-i, ,drop=FALSE] # } # } if (dim(rcl)[1] == 0) { if (hasNA) { onlyNA <- TRUE } } else { stopifnot(all(rcl[,2] >= rcl[,1])) } nl <- nlayers(x) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) } names(out) <- names(x) include.lowest <- as.integer(include.lowest) if (is.na(right)) { leftright <- TRUE right <- TRUE } else { leftright <- FALSE } right <- as.integer(right) #hasNA <- as.integer(hasNA) onlyNA <- as.integer(onlyNA) valNA <- as.double(valNA) if (nc == 2) { rcl <- rcl[ , 2:3, drop=FALSE] } if (canProcessInMemory(out)) { out <- setValues(out, .reclassify(values(x), rcl, include.lowest, right, leftright, onlyNA, valNA)) if ( filename != "" ) { out <- writeRaster(out, filename=filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='reclassify', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) vals <- .reclassify(vals, rcl, include.lowest, right, leftright, onlyNA, valNA) if (nl > 1) { vals <- matrix(vals, ncol=nl) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) return(out) } } ) raster/R/clearValues.R0000644000176200001440000000216214160021141014333 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .clearRaster <- function(object) { object@data@inmemory <- FALSE # object@data@indices = vector(mode='numeric') object@data@values <- vector() if ( ! fromDisk(object) ) { object@data@min <- Inf object@data@max <- -Inf object@data@haveminmax <- FALSE } return(object) } clearValues <- function(x) { if (class(x) == "BasicRaster" ) { return(x) } else if (inherits(x, "RasterLayer" )) { x <- .clearRaster(x) } else if (inherits(x, "RasterStack") ) { for (i in seq(along.with=nlayers(x))) { if (fromDisk(x@layers[[i]])) { x@layers[[i]] <- .clearRaster(x@layers[[i]]) } } } else if (inherits(x, 'RasterBrick')) { x@data@values <- matrix(NA,0,0) x@data@inmemory <- FALSE # x@data@indices = c(0,0) if ( ! fromDisk(x) ) { x@data@min <- rep(Inf, nlayers(x)) x@data@max <- rep(-Inf, nlayers(x)) x@data@haveminmax <- FALSE } } return(x) } .clearFile <- function(x) { x@file@name <- '' x@data@fromdisk <- FALSE x@file@driver <- "" return(x) } raster/R/print.R0000644000176200001440000000733514160021141013230 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 setMethod ('print', 'Raster', function(x, ...) { if (inherits(x, 'RasterStack')) { show(x) } else { if (x@file@driver == 'netcdf') { nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) print(nc) ncdf4::nc_close(nc) } else if (any(is.factor(x))) { cat('factor levels (value attributes)\n') f <- x@data@attributes for (i in 1:length(f)) { ff <- f[[i]] if (!is.null(ff)) { if (nrow(ff) > 15) { ff <- ff[1:15,] } print(ff) } } # cat('levels :' , paste(object@data@levels, collapse=', '), '\n') # cat('labels :' , paste(object@data@labels, collapse=', '), '\n') } else { methods::callNextMethod(x, ...) } } } ) setMethod ('show' , 'Spatial', function(object) { .printSpatial(object) } ) setMethod ('show' , 'SpatialPoints', function(object) { .printSpatial(object) } ) setMethod ('show' , 'SpatialPointsDataFrame', function(object) { .printSpatial(object) } ) setMethod ('print' , 'Spatial', function(x, ...) { .printSpatial(x) } ) .printSpatial <- function(x, ...) { cat('class :' , class(x), '\n') isRaster <- hasData <- FALSE nc <- 0 if (.hasSlot(x, 'data')) { nc <- ncol(x@data) hasData <- TRUE } ln <- 1 if (inherits(x, 'SpatialPixels')) { isRaster <- TRUE cr <- x@grid@cells.dim cat ('dimensions : ', cr[2], ', ', cr[1], ', ', nrow(x@coords), ', ', nc, ' (nrow, ncol, npixels, nlayers)\n', sep="" ) cs <- x@grid@cellsize cat ('resolution : ', cs[1], ', ', cs[2], ' (x, y)\n', sep="") } else if (inherits(x, 'SpatialGrid')) { isRaster <- TRUE cr <- x@grid@cells.dim cat ('dimensions : ', cr[2], ', ', cr[1], ', ', prod(cr), ', ', nc, ' (nrow, ncol, ncell, nlayers)\n', sep="" ) cs <- x@grid@cellsize cat ('resolution : ', cs[1], ', ', cs[2], ' (x, y)\n', sep="") } else { nf <- length(x) cat('features :' , nf, '\n') } e <- sp::bbox(x) if (nf > 0) { cat('extent : ' , e[1,1], ', ', e[1,2], ', ', e[2,1], ', ', e[2,2], ' (xmin, xmax, ymin, ymax)\n', sep="") } cat('crs :' , x@proj4string@projargs, '\n') if (hasData) { x <- x@data maxnl <- 15 if (! isRaster) { cat('variables : ', nc, '\n', sep="" ) } if (nc > 0) { if (nc > maxnl) { x <- x[, 1:maxnl] } ln <- colnames(x) if (nc > maxnl) { ln <- c(ln[1:maxnl], '...') x <- x[, 1:maxnl] } wrn <- getOption('warn') on.exit(options('warn' = wrn)) options('warn'=-1) # r <- apply(x, 2, range, na.rm=TRUE) # can give bad sorting (locale dependent) # because as.matrix can add whitespace to numbers rangefun <- function(x) { if(is.factor(x)) { range(as.character(x), na.rm=TRUE) } else { range(x, na.rm=TRUE) } } r <- sapply(x, rangefun) i <- r[1,] == "Inf" r[,i] <- NA minv <- as.vector(r[1, ]) maxv <- as.vector(r[2, ]) if (nc > maxnl) { minv <- c(minv, '...') maxv <- c(maxv, '...') } w <- pmax(nchar(ln), nchar(minv), nchar(maxv)) w[is.na(w)] <- 2 m <- rbind(ln, minv, maxv) # a loop because 'width' is not recycled by format for (i in 1:ncol(m)) { m[,i] <- format(m[,i], width=w[i], justify="right") } cat('names :', paste(m[1,], collapse=', '), '\n') if (nf > 1) { cat('min values :', paste(m[2,], collapse=', '), '\n') cat('max values :', paste(m[3,], collapse=', '), '\n') } else if (nf == 1) { cat('value :', paste(m[2,], collapse=', '), '\n') } } } } raster/R/ifelse.R0000644000176200001440000000130514160021141013332 0ustar liggesusers# Author: Robert J. Hijmans # Date : May 2019 # Version 1.0 # Licence GPL v3 #setMethod("ifel", signature(test="Raster", yes="ANY", no="ANY"), .ifel <- function(test, yes, no, filename="", ...) { if (!inherits(no, "Raster")) { stopifnot(is.numeric(no)) if (length(no) > 1) warning('only the first element of "no" is used') no <- reclassify(test, rbind(c(0,no[1]), c(1,NA))) } else { no <- mask(no, test, maskvalue=TRUE) } if (!inherits(yes, "Raster")) { stopifnot(is.numeric(yes)) if (length(yes) > 1) warning('only the first element of "yes" is used') yes <- reclassify(test, rbind(c(1,yes[1]), c(0,NA))) } cover(no, yes, filename=filename) } #) raster/R/compareCRS.R0000644000176200001440000000273114160021141014065 0ustar liggesusers# author Robert Hijmans # June 2010 # version 1.0 # license GPL3 .compareCRS <- function(...) { warning('use "compareCRS", not ".compareCRS"') compareCRS(...) } # see sp:identicalCRS(x, y) compareCRS <- function(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) { x <- tolower(projection(x)) y <- tolower(projection(y)) step1 <- function(z) { z <- gsub(' ', '', z) if (!verbatim) { z <- unlist( strsplit(z, '+', fixed=TRUE) )[-1] z <- do.call(rbind, strsplit(z, '=')) } z } if (verbatim) { if (!is.na(x) & !is.na(y)) { return(x==y) } else { if (is.na(x) & is.na(y)) { return(TRUE) # ?? } else if (unknown) { return(TRUE) } else { return(FALSE) } } } x <- step1(x) y <- step1(y) if (length(x) == 0 & length(y) == 0) { return(TRUE) } else if (length(x) == 0 | length(y) == 0) { if (unknown) { return(TRUE) } else { if (verbose) { message('Unknown crs') } return(FALSE) } } x <- x[x[,1] != 'towgs84', , drop=FALSE] x <- x[x[,1] != 'no_defs', , drop=FALSE] x <- x[which(x[,1] %in% y[,1]), ,drop=FALSE] y <- y[which(y[,1] %in% x[,1]), ,drop=FALSE] x <- x[order(x[,1]), ,drop=FALSE] y <- y[order(y[,1]), ,drop=FALSE] i <- x[,2] == y[,2] if (! all(i)) { if (verbose) { i <- which(!i) for (j in i) { message('+',x[j,1], ': ', x[j,2],' != ', y[j,2], '\n') } } return(FALSE) } return(TRUE) } raster/R/rectify.R0000644000176200001440000000103614160021141013531 0ustar liggesusers# Robert J. Hijmans # May 2010 # Version 1.0 # Licence GPL v3 rotated <- function(x) { isTRUE(try(x@rotated, silent=TRUE)) } setMethod("rectify", signature(x="Raster"), function(x, ext, res, method='ngb', filename='', ...) { stopifnot(rotated(x)) if ( missing(ext)) { ext <- extent(x) } else { ext <- extent(ext) } out <- raster(ext) if ( missing(res)) { res(out) <- abs(raster::res(x)) } else { res(out) <- res } resample(x, out, method=method, filename=filename, ...) } ) raster/R/layerize.R0000644000176200001440000001040014160021141013703 0ustar liggesusers# Author: Robert J. Hijmans # Date : August 2012 # Version 1.0 # Licence GPL v3 setMethod('layerize', signature(x='RasterLayer', y='missing'), function(x, classes=NULL, falseNA=FALSE, filename='', ...) { doC <- list(...)$doC if (is.null(doC)) doC <- TRUE if (is.null(classes)) { classes <- as.integer( sort(unique(x)) ) } else { classes <- as.integer(classes) } out <- raster(x) if (length(classes) > 1) { out <- brick(out, nl=length(classes)) } names(out) <- classes if (canProcessInMemory(out)) { v <- as.integer(getValues(x)) if (doC) { v <- .layerize(v, as.integer(classes), falseNA) v <- matrix(v, ncol=length(classes)) } else { v <- t( apply(matrix(v), 1, function(x) x == classes) ) if (falseNA) { v[!v] <- NA } } # alternative approach (assuming sorted classes) # alternative approach (assuming sorted classes) # vv <- cbind(1:length(v), as.integer(as.factor(v))) # if (falseNA) { # v <- matrix(NA, nrow=ncell(out), ncol=nlayers(out)) # } else { # v <- matrix(0, nrow=ncell(out), ncol=nlayers(out)) # } # v[vv] <- 1 out <- setValues(out, v*1) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } # else to disk ## out <- writeStart(out, filename=filename, datatype='INT2S', ...) # } else { out <- writeStart(out, filename=filename, ...) # } tr <- blockSize(out) pb <- pbCreate(tr$n, label='layerize', ...) #fNA <- as.integer(falseNA) if (doC) { for (i in 1:tr$n) { v <- as.integer(getValues(x, tr$row[i], tr$nrows[i])) v <- .layerize(v, classes, falseNA) v <- matrix(v, ncol=length(classes)) out <- writeValues(out, v*1, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- t( apply(matrix(v, ncol=1), 1, function(x) x == classes) ) if (falseNA) { v[!v] <- NA } out <- writeValues(out, v*1, tr$row[i]) pbStep(pb, i) } } pbClose(pb) writeStop(out) } ) setMethod('layerize', signature(x='RasterLayer', y='RasterLayer'), function(x, y, classes=NULL, filename='', ...) { resx <- res(x) resy <- res(y) if (! all( resy > resx) ) { stop("x and y resolution of object y should be (much) larger than that of object x") } int <- intersect(extent(x), extent(y)) if (is.null(int)) { return(raster(y)) } if (is.null(classes)) { classes <- as.integer( sort(unique(x))) } out <- raster(y) if (length(classes) > 1) { out <- brick(out, nl=length(classes)) } names(out) <- paste('count_', as.character(classes), sep='') if (canProcessInMemory( out )) { b <- crop(x, int) xy <- xyFromCell(b, 1:ncell(b)) mc <- cellFromXY(out, xy) b <- as.integer(getValues(b)) if (!is.null(classes)) { b[! b %in% classes] <- NA } v <- table(mc, b) cells <- as.integer(rownames(v)) m <- match(cells, 1:ncell(out)) cn <- as.integer(colnames(v)) res <- matrix(NA, nrow=ncell(out), ncol=length(cn)) for (i in 1:length(cn)) { res[m,i] <- v[,i] } names(out) <- paste('count_', as.character(cn), sep='') out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } # else out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='layerize', ...) for(i in 1:tr$n) { e <- extent(xmin(y), xmax(y), yFromRow(y, tr$row[i]+tr$nrows[i]-1) - 0.5 * yres(y), yFromRow(y, tr$row[i])+0.5 * yres(y)) int <- intersect(e, extent(x)) res <- matrix(NA, nrow=tr$nrows[i] * ncol(y), ncol=length(classes)) if (!is.null(int)) { b <- crop(x, int) xy <- xyFromCell(b, 1:ncell(b)) mc <- cellFromXY(y, xy) v <- table(mc, as.integer(getValues(b))) cells <- as.integer(rownames(v)) modcells <- cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+ tr$nrows[i]-1, ncol(y)) m <- match(cells, modcells) cn <- as.integer(colnames(v)) mm <- match(cn, classes) for (j in 1:length(cn)) { res[, mm[j]] <- v[, j] } } out <- writeValues(out, res, tr$row[i]) } out <- writeStop(out) pbClose(pb) out } ) raster/R/fixDBFnames.R0000644000176200001440000000145714160021141014221 0ustar liggesusers .fixDBFNames <- function(x, verbose=TRUE) { n <- gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', x) ) nn <- n n <- gsub('[^[:alnum:]]', '_', n) n[nchar(n) > 10] <- gsub('_', '', n[nchar(n) > 10]) n[n==''] <- 'field' n <- gsub('^[^[:alpha:]]', 'X', n) n <- substr(n, 1, 10) # duplicate names nn <- as.matrix(table(n)) i <- which(nn > 1) if (! is.null(i)) { names <- rownames(nn)[i] n[n %in% names] <- substr(n[n %in% names], 1, 9) n <- make.unique(n, sep = "") } if (verbose) { i <- x == n if (! all(i)) { x <- rbind(x, n) colnames(x) <- paste('col_', 1:ncol(x), sep="") x <- x[, !i, drop=FALSE] rownames(x) = c('original name', 'adjusted name') print(x) } } return(n) } raster/R/ncell.R0000644000176200001440000000061614160021141013164 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod('ncell', signature(x='BasicRaster'), function(x) { return(as.numeric(x@ncols) * x@nrows) } ) setMethod('ncell', signature(x='ANY'), function(x) { NROW(x) * NCOL(x) } ) setMethod('length', signature(x='BasicRaster'), function(x) { ncell(x) * nlayers(x) } ) raster/R/readRasterLayer.R0000644000176200001440000001352214160021141015160 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 1.0 # Licence GPL v3 .readRasterLayerValues <- function(object, startrow, nrows=1, startcol=1, ncols=ncol(object)-startcol+1) { # if (nrows < 1) { stop("nrows should be > 1") } # startrow <- min(max(1, round(startrow)), object@nrows) # endrow <- min(object@nrows, startrow+nrows-1) # nrows <- endrow - startrow + 1 # if (ncols < 1) { stop("ncols should be > 1") } # startcol <- min(max(1, round(startcol)), object@ncols) # endcol <- min(object@ncols, startcol+ncols-1) # ncols <- endcol - startcol + 1 driver <- object@file@driver if (.isNativeDriver(driver)) { getBSQData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band=1) { offset <- raster@file@offset + (band-1) * raster@ncols * raster@nrows + (r-1) * raster@ncols if (c==1 & ncols==raster@ncols) { seek(raster@file@con, offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nrows*ncols, dsize, dsign, endian=raster@file@byteorder) } else { result <- matrix(ncol=nrows, nrow=ncols) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols + (c-1) seek(raster@file@con, off * dsize) result[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } } return(as.vector(result)) } getBilData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band) { offset <- raster@file@offset + raster@file@nbands * raster@ncols * (r-1) + (c-1) result <- matrix(ncol=nrows, nrow=ncols) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols * raster@file@nbands + (band-1) * raster@ncols seek(raster@file@con, off * dsize) result[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } return(as.vector(result)) } getBipData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band) { offset <- raster@file@offset + raster@file@nbands * raster@ncols * (r-1) nc <- ncols * raster@file@nbands index <- rep(FALSE, raster@file@nbands) index[band] <- TRUE index <- rep(index, ncols) result <- matrix(ncol=nrows, nrow=ncols) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols * raster@file@nbands + (c-1) * raster@file@nbands seek(raster@file@con, off * dsize) res <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) result[,i] <- res[index] } return(as.vector(result)) } if (! object@file@toptobottom ) { endrow <- object@nrows - startrow + 1 startrow <- endrow - nrows + 1 } dtype <- substr(object@file@datanotation, 1, 3) if (dtype == "INT" | dtype == "LOG" ) { dtype <- "integer" } else { dtype <- "numeric" } dsize <- dataSize(object@file@datanotation) dsign <- dataSigned(object@file@datanotation) if (dsize > 2) { dsign <- TRUE } is.open <- object@file@open if (!is.open) { object <- readStart(object) } if (object@file@nbands > 1) { band <- object@data@band bo <- object@file@bandorder if (bo == 'BSQ') { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign, band=band) } else if (bo == 'BIL') { result <- getBilData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign, band=band) } else if (bo == 'BIP') { result <- getBipData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign, band=band) } } else { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } if (!is.open) { object <- readStop(object) } if (! object@file@toptobottom ) { result <- t(matrix(result, nrow=ncols, ncol=nrows)) result <- result[nrows:1,] result <- as.vector(t(result)) } if (object@file@datanotation == 'INT4U') { i <- !is.na(result) & result < 0 result[i] <- 2147483647 - result[i] } if (dtype == 'numeric') { result[result <= (0.999999 * object@file@nodatavalue)] <- NA result[is.nan(result)] <- NA } else { result[result == object@file@nodatavalue ] <- NA } if (dtype == 'logical') { result <- as.logical(result) } # ascii is internal to this package but not 'native' (not binary) } else if (driver == 'ascii') { result <- .readRowsAscii(object, startrow, nrows, startcol, ncols) } else if (driver == 'netcdf') { result <- .readRowsNetCDF(object, startrow, nrows, startcol, ncols) # } else if (driver == 'big.matrix') { # bm <- attr(object@file, 'big.matrix') # if (nbands(object) > 1) { # bn <- bandnr(object) # startcell <- cellFromRowCol(object, startrow, startcol) # endcell <- cellFromRowCol(object, (startrow+nrows-1), (startcol+ncols-1)) # result <- bm[startcell:endcell, bn] # # } else { # result <- as.vector(t(bm[startrow:(startrow+nrows-1), startcol:(startcol+ncols-1)])) # } #use GDAL } else { offs <- c((startrow-1), (startcol-1)) reg <- c(nrows, ncols) if ( object@file@open ) { result <- rgdal::getRasterData(object@file@con, offset=offs, region.dim=reg, band=object@data@band) } else { con <- rgdal::GDAL.open(object@file@name, silent=TRUE) result <- rgdal::getRasterData(con, offset=offs, region.dim=reg, band=object@data@band) rgdal::closeDataset(con) } result <- as.vector(result) # if NAvalue() has been used..... if (object@file@nodatavalue < 0) { result[result <= object@file@nodatavalue ] <- NA } else { result[result == object@file@nodatavalue ] <- NA } } if (object@data@gain != 1 | object@data@offset != 0) { result <- result * object@data@gain + object@data@offset } return(result) } raster/R/plot2rasters.R0000644000176200001440000001001214160021141014522 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod("plot", signature(x='Raster', y='Raster'), function(x, y, maxpixels=100000, cex, xlab, ylab, nc, nr, maxnl=16, main, add=FALSE, gridded=FALSE, ncol=25, nrow=25, ...) { compareRaster(c(x, y), extent=TRUE, rowcol=TRUE, crs=FALSE, stopiffalse=TRUE) nlx <- nlayers(x) nly <- nlayers(y) maxnl <- max(1, round(maxnl)) nl <- max(nlx, nly) if (nl > maxnl) { nl <- maxnl if (nlx > maxnl) { x <- x[[1:maxnl]] nlx <- maxnl } if (nly > maxnl) { y <- y[[1:maxnl]] nly <- maxnl } } if (missing(main)) { main <- '' } if (missing(xlab)) { ln1 <- names(x) } else { ln1 <- xlab if (length(ln1) == 1) { ln1 <- rep(ln1, nlx) } } if (missing(ylab)) { ln2 <- names(y) } else { ln2 <- ylab if (length(ln1) == 1) { ln2 <- rep(ln2, nly) } } cells <- ncell(x) # gdal selects a slightly different set of cells than raster does for other formats. # using gdal directly to subsample is faster. if (gridded) { if ((ncell(x) * (nlx + nly)) < .maxmemory()) { maxpixels <- ncell(x) } } dx <- .driver(x, warn=FALSE) dy <- .driver(y, warn=FALSE) if ( all(dx =='gdal') & all(dy == 'gdal')) { x <- sampleRegular(x, size=maxpixels, useGDAL=TRUE) y <- sampleRegular(y, size=maxpixels, useGDAL=TRUE) } else { x <- sampleRegular(x, size=maxpixels) y <- sampleRegular(y, size=maxpixels) } if (NROW(x) < cells) { warning(paste('plot used a sample of ', round(100*NROW(x)/cells, 1), '% of the cells. You can use "maxpixels" to increase the sample)', sep="")) } if (missing(cex)) { if (NROW(x) < 100) { cex <- 1 } else if (NROW(x) < 1000) { cex <- 0.5 } else { cex <- 0.2 } } if (nlx != nly) { # recycling d <- cbind(as.vector(x), as.vector(y)) x <- matrix(d[,1], ncol=nl) y <- matrix(d[,2], ncol=nl) lab <- vector(length=nl) lab[] <- ln1 ln1 <- lab lab[] <- ln2 ln2 <- lab } if (nl > 1) { if (missing(nc)) { nc <- ceiling(sqrt(nl)) } else { nc <- max(1, min(nl, round(nc))) } if (missing(nr)) { nr <- ceiling(nl / nc) } else { nr <- max(1, min(nl, round(nr))) nc <- ceiling(nl / nr) } old.par <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(old.par)) graphics::par(mfrow=c(nr, nc), mar=c(4, 4, 2, 2)) if (! gridded) { if (add) { for (i in 1:nl) { points(x[,i], y[,i], cex=cex, ...) } } else { for (i in 1:nl) { plot(x[,i], y[,i], cex=cex, xlab=ln1[i], ylab=ln2[i], main=main[i], ...) } } } else { for (i in 1:nl) { .plotdens(x[,i], y[,i], nc=ncol, nr=nrow, main=main[i], xlab=ln1[i], ylab=ln2[i], add=add, ...) } } } else { if (! gridded) { if (add) { points(x, y, cex=cex, ...) } else { plot(x, y, cex=cex, xlab=ln1[1], ylab=ln2[1], main=main[1], ...) } } else { .plotdens(x, y, nc=ncol, nr=nrow, main=main[1], xlab=ln1[1], ylab=ln2[1], ...) } } } ) .plotdens <- function(x, y, nc, nr, asp=NULL, xlim=NULL, ylim=NULL, ...) { xy <- stats::na.omit(cbind(x,y)) if (nrow(xy) == 0) { stop('only NA values (in this sample?)') } r <- apply(xy, 2, range) rx <- r[,1] if (rx[1] == rx[2]) { rx[1] <- rx[1] - 0.5 rx[2] <- rx[2] + 0.5 } ry <- r[,2] if (ry[1] == ry[2]) { ry[1] <- ry[1] - 0.5 ry[2] <- ry[2] + 0.5 } out <- raster(xmn=rx[1], xmx=rx[2], ymn=ry[1], ymx=ry[2], ncol=nc, nrow=nr) out <- rasterize(xy, out, fun=function(x, ...) length(x), background=0) if (!is.null(xlim) | !is.null(ylim)) { if (is.null(xlim)) xlim <- c(xmin(x), xmax(x)) if (is.null(ylim)) ylim <- c(ymin(x), ymax(x)) e <- extent(xlim, ylim) out <- extend(crop(out, e), e, value=0) } .plotraster2(out, maxpixels=nc*nr, asp=asp, ...) } raster/R/union.R0000644000176200001440000000106314160021141013214 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 setMethod('union', signature(x='Extent', y='Extent'), function(x, y) { .unionExtent(x, y) } ) .unionExtent <- function(x, ...) { objects <- c(x, list(...)) if (length(objects) == 1) { return(extent(x)) } e <- extent(objects[[1]]) for (i in 2:length(objects)) { e2 <- extent(objects[[i]]) e@xmin <- min(e@xmin, e2@xmin) e@xmax <- max(e@xmax, e2@xmax) e@ymin <- min(e@ymin, e2@ymin) e@ymax <- max(e@ymax, e2@ymax) } return(e) } raster/R/image.R0000644000176200001440000000214414160021141013147 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod("image", signature(x='RasterLayer'), function(x, maxpixels=500000, useRaster=TRUE, ...) { # coltab <- x@legend@colortable # if (is.null(coltab) | length(coltab) == 0 | is.null(list(...)$col)) { # colortab <- FALSE # } # if (missing(main)) { main <- names(x) } x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) y <- yFromRow(x, nrow(x):1) # drop=F fix by Daniel Schlaepfer for single row image value <- t(as.matrix(x)[nrow(x):1, ,drop=FALSE]) x <- xFromCol(x,1:ncol(x)) # if (colortab) { # image(x=x, y=y, z=value, col=coltab[value], useRaster=useRaster, ...) # } else { image(x=x, y=y, z=value, useRaster=useRaster, ...) # } } ) setMethod("image", signature(x='RasterStackBrick'), function(x, y=1, maxpixels=100000, useRaster=TRUE, main, ...) { y <- round(y) stopifnot(y > 0 & y <= nlayers(x)) x <- raster(x, y) if (missing(main)) { main <- names(x) } image(x, maxpixels=maxpixels, useRaster=useRaster, main=main, ...) } ) raster/R/as.logical.R0000644000176200001440000000431514160021141014103 0ustar liggesusers# Author: Robert J. Hijmans # Date: November 2009, Jan 2016 # Version 1.0 # Licence GPL v3 setMethod('as.integer', signature(x='Raster'), function(x, filename='', ...) { if (nlayers(x) > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } datatype <- list(...)$datatype if (canProcessInMemory(x, 2)){ x <- getValues(x) x[] <- as.integer(x) out <- setValues(out, x) if (filename != '') { if (is.null(datatype)) { out <- writeRaster(out, filename, datatype='INT4S', ...) } else { out <- writeRaster(out, filename, ...) } } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (is.null(datatype)) { out <- writeStart(out, filename=filename, datatype='INT4S', ...) } else { out <- writeStart(out, filename=filename, ...) } tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { v <- as.integer( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('as.logical', signature(x='Raster'), function(x, filename='', ...) { if (nlayers(x) > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } datatype <- list(...)$datatype if (canProcessInMemory(x, 2)){ x <- getValues(x) x[] <- as.logical(x) out <- setValues(out, x) if (filename != '') { if (is.null(datatype)) { out <- writeRaster(out, filename, datatype='INT2S', ...) } else { out <- writeRaster(out, filename, ...) } } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (is.null(datatype)) { out <- writeStart(out, filename=filename, datatype='INT2S', ...) } else { out <- writeStart(out, filename=filename, ...) } tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { v <- as.logical ( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) return(out) } } ) raster/R/metadata.R0000644000176200001440000000137714160021141013654 0ustar liggesusers setMethod('metadata', signature(x='Raster'), function(x) { x@history } ) 'metadata<-' <- function(x, value) { stopifnot(is.list(value)) if (is.data.frame(values)) { values <- as.list(values) } if ( any(unlist(sapply(value, function(x)sapply(x, is.list)))) ) { stop('invalid metadata: list is nested too deeply') } nms <- c(names(value), unlist(sapply(value, names))) if (is.null(names) | any(nms == '')) { stop('invalid metadata: list elements without names') } if (any(unlist(sapply(value, is.data.frame)) )) { stop('invalid metadata: data.frames are not allowed') } type <- rapply(value, class) if (any(type == 'matrix')) { stop('invalid metadata: matrices are not allowed') } x@history <- value x } raster/R/cropSpatial.R0000644000176200001440000000555414160021141014356 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod('crop', signature(x='Spatial', y='ANY'), function(x, y, ...) { if (! inherits(y, 'SpatialPolygons')) { if (inherits(y, 'Extent')) { y <- as(y, 'SpatialPolygons') } else { y <- extent(y) methods::validObject(y) y <- as(y, 'SpatialPolygons') } y@proj4string <- x@proj4string } prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) if (inherits(y, 'SpatialPolygons')) { y <- rgeos::gUnaryUnion(y) row.names(y) <- '1' y <- sp::geometry(y) } if (inherits(x, 'SpatialPolygons')) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) x <- .cropSpatialPolygons(x, y, ...) } else if (inherits(x, 'SpatialLines')) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) x <- .cropSpatialLines(x, y, ...) } else if (inherits(x, 'SpatialPoints')) { x <- .cropSpatialPoints(x, y, ...) } else { x <- x[y] } if (inherits(x, "Spatial")) { x@proj4string <- prj } x } ) .cropSpatialPolygons <- function(x, y, ...) { rnx <- row.names(x) row.names(x) <- as.character(1:length(rnx)) if (.hasSlot(x, 'data')) { # to keep the correct IDs # in future versions of rgeos, this intermediate step won't be necessary i <- as.vector( rgeos::gIntersects(x, y, byid=TRUE) ) if (sum(i) == 0) { return(NULL) } y <- rgeos::gIntersection(x[i,], y, byid=TRUE, drop_lower_td=TRUE) if (inherits(y, "SpatialCollections")) { y <- y@polyobj } if (is.null(y)) { return(y) } ids <- strsplit(row.names(y), ' ') ids <- as.numeric(do.call(rbind, ids)[,1]) row.names(y) <- as.character(rnx[ids]) data <- x@data[ids, ,drop=FALSE] rownames(data) <- rnx[ids] return( sp::SpatialPolygonsDataFrame(y, data) ) } else { y <- rgeos::gIntersection(x, y, drop_lower_td=TRUE) #if (inherits(y, "SpatialCollections")) { # y <- y@polyobj #} return(y) } } .cropSpatialLines <- function(x, y, ...) { rnx <- row.names(x) row.names(x) <- as.character(1:length(rnx)) xy <- rgeos::gIntersection(x, y, byid=TRUE) if (inherits(xy, "SpatialCollections")) { xy <- xy@lineobj } if (.hasSlot(x, 'data')) { ids <- strsplit(row.names(xy), ' ') ids <- as.numeric(do.call(rbind, ids)[,1]) #row.names(y) <- as.character(rnx[ids]) data <- x@data[ids, ,drop=FALSE] #rownames(data) <- rnx[ids] xy <- sp::SpatialLinesDataFrame(xy, data, match.ID = FALSE) } return(xy) } .cropSpatialPoints <- function(x, y, ...) { i <- which(!is.na(sp::over(x, y))) if (length(i) > 0) { x <- x[i,] } else { x <- NULL } x } raster/R/writeAllAscii.R0000644000176200001440000000212614160021141014621 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .writeAscii <- function(x, filename, datatype='FLT4S', prj=FALSE, ...) { v <- getValues(x) if (!is.finite( x@file@nodatavalue) ) { x@file@nodatavalue <- min(-9999, min(v, na.rm=TRUE)-1) } x <- .startAsciiWriting(x, filename, ...) datatype <- substr(datatype, 1, 3) if (datatype == 'INT') { on.exit(options(scipen=options('scipen'))) options(scipen=10) v <- round(v) } v[is.na(v)] <- x@file@nodatavalue if (datatype=='FLT') { # hack to make sure that ArcGIS does not # assume values are integers if the first # values have no decimal point v <- as.character(v) v[1] <- formatC(as.numeric(v[1]), 15, format='f') } v <- matrix(v, ncol=ncol(x), byrow=TRUE) utils::write.table(v, x@file@name, append = TRUE, quote = FALSE, sep = " ", eol = "\n", dec = ".", row.names = FALSE, col.names = FALSE) if (prj) { crs <- .getCRS(x) if (!is.na(crs)) { writeLines(wkt(x), extension(filename, 'prj') ) } } return( .stopAsciiWriting(x) ) } raster/R/pointdistance.R0000644000176200001440000000766414160021141014745 0ustar liggesusers# Author: Robert J. Hijmans and Jacob van Etten # Date : June 2008 # Version 0.9 # Licence GPL v3 .pointsToMatrix <- function(p) { if (inherits(p, "sf")) { p <- as(p, "Spatial") } if (inherits(p, 'SpatialPoints')) { p <- sp::coordinates(p) } else if (is.data.frame(p)) { p <- as.matrix(p) } else if (is.vector(p)){ if (length(p) != 2) { stop('Wrong length for a vector, should be 2') } else { p <- matrix(p, ncol=2) } } if (is.matrix(p)) { if (ncol(p) != 2) { stop( 'A points matrix should have 2 columns') } cn <- colnames(p) if (length(cn) == 2) { if (toupper(cn[1]) == 'Y' | toupper(cn[2]) == 'X') { stop('Highly suspect column names (x and y reversed?)') } if (toupper(substr(cn[1],1,3) == 'LAT' | toupper(substr(cn[2],1,3)) == 'LON')) { stop('Highly suspect column names (longitude and latitude reversed?)') } } } else { stop('points should be vectors of length 2, matrices with 2 columns, or a SpatialPoints* object') } return(p) } .distm <- function (x, longlat) { if (longlat) { n <- nrow(x) dm <- matrix(ncol = n, nrow = n) dm[cbind(1:n, 1:n)] <- 0 if (n > 1) { for (i in 2:n) { j = 1:(i - 1) dm[i, j] = .geodist(x[i, 1], x[i, 2], x[j, 1], x[j, 2]) } } return(dm) } else { return(.planedist2(x, x)) } } .distm2 <- function (x, y, longlat) { if (longlat) { n <- nrow(x) m <- nrow(y) dm <- matrix(ncol=m, nrow=n) for (i in 1:n) { dm[i,] <- .geodist(x[i, 1], x[i, 2], y[, 1], y[, 2]) } return(dm) } else { return(.planedist2(x, y)) # fun <- .planedist } } .distm2new <- function (x, y, longlat, a=6378137, f=1/298.257223563) { if (longlat) { n <- nrow(x) m <- nrow(y) xx <- cbind(rep(x[,1], m), rep(x[,2], m)) yy <- cbind(rep(y[,1], each=n), rep(y[,2], each=n)) g <- .Call("_raster_point_distance", xx, yy, TRUE, a, f, PACKAGE='raster') return(matrix(g, n, m)) } else { return(.planedist2(x, y)) # fun <- .planedist } } pointDistance <- function (p1, p2, lonlat, allpairs=FALSE, ...) { longlat <- list(...)$longlat if (!is.null(longlat)) { lonlat <- longlat } if (missing(lonlat)) { if (isLonLat(p1)) { lonlat <- TRUE } else if (! is.na(projection(p1)) ) { lonlat <- FALSE } else { stop('you must provide a "lonlat" argument (TRUE/FALSE)') } } stopifnot(is.logical(lonlat)) p1 <- .pointsToMatrix(p1) if (missing(p2)) { return(.distm(p1, lonlat)) } p2 <- .pointsToMatrix(p2) if (nrow(p1) != nrow(p2)) { allpairs <- TRUE } if (allpairs) { if(nrow(p1) > 1 & nrow(p2) > 1) { return(.distm2(p1, p2, lonlat)) } } if (lonlat ) { # return( .haversine(p1[,1], p1[,2], p2[,1], p2[,2], r=6378137) ) return( .geodist(p1[,1], p1[,2], p2[,1], p2[,2]) ) } else { return( .planedist(p1[,1], p1[,2], p2[,1], p2[,2]) ) } } .planedist <- function(x1, y1, x2, y2) { sqrt(( x1 - x2)^2 + (y1 - y2)^2) } .planedist2 <- function(p1, p2) { # code by Bill Venables # https://stat.ethz.ch/pipermail/r-help/2008-February/153841.html z0 <- complex(, p1[,1], p1[,2]) z1 <- complex(, p2[,1], p2[,2]) outer(z0, z1, function(z0, z1) Mod(z0-z1)) } .geodist <- function(x1, y1, x2, y2, a=6378137, f=1/298.257223563) { # recycle p <- cbind(x1, y1, x2, y2) .Call("_raster_point_distance", p[,1:2, drop=FALSE], p[, 3:4,drop=FALSE], TRUE, a, f, PACKAGE='raster') # .Call("inversegeodesic", as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f), PACKAGE='raster') } .old_haversine <- function(x1, y1, x2, y2, r=6378137) { adj <- pi / 180 x1 <- x1 * adj y1 <- y1 * adj x2 <- x2 * adj y2 <- y2 * adj x <- sqrt((cos(y2) * sin(x1-x2))^2 + (cos(y1) * sin(y2) - sin(y1) * cos(y2) * cos(x1-x2))^2) y <- sin(y1) * sin(y2) + cos(y1) * cos(y2) * cos(x1-x2) return ( r * atan2(x, y) ) } raster/R/zoom.R0000644000176200001440000000304014160021141013045 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('zoom', signature(x='Raster'), function(x, ext=drawExtent(), maxpixels=100000, layer=1, new=TRUE, useRaster=TRUE, ...) { if (is.function(ext)) { ext <- ext # force to start with drawing before creating a new graphics device } else { ext <- extent(ext) } if (new) { grDevices::dev.new() } if (nlayers(x) > 1) { x <- raster(x, layer) } if (length(colortable(x)) > 0) { .plotCT(x, maxpixels=maxpixels, ext=ext, ...) } else if (useRaster) { .plotraster2(x, maxpixels=maxpixels, ext=ext, ...) } else { .plotraster(x, col=col, maxpixels=maxpixels, ...) } return(invisible(ext)) } ) setMethod('zoom', signature(x='Spatial'), function(x, ext=drawExtent(), new=TRUE, ...) { if (is.function(ext)) { ext <- ext # force to start with drawing before creating a new graphics device } else { ext <- extent(ext) } if (new) { grDevices::dev.new() } sp::plot(x, xlim=c(ext@xmin, ext@xmax), ylim=c(ext@ymin, ext@ymax), ...) return(invisible(ext)) } ) setMethod('zoom', signature(x='missing'), function(x, ext=drawExtent(), new=TRUE, ...) { if (is.function(ext)) { ext <- ext # force to start with drawing before creating a new graphics device } else { ext <- extent(ext) } if (new) { grDevices::dev.new() } plot(0, xlim=c(ext@xmin, ext@xmax), ylim=c(ext@ymin, ext@ymax), type='n', ...) return(invisible(ext)) } ) raster/R/hdrSAGA.R0000644000176200001440000000323414160021141013277 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrSAGA <- function(x) { hdrfile <- filename(x) hdrfile <- .setFileExtensionHeader(hdrfile, 'SAGA') thefile <- file(hdrfile, "w") # open an txt file connectionis cat("NAME\t=", names(x), "\n", file = thefile) cat("DESCRIPTION\t= \n", file = thefile) cat("UNIT\t= \n", file = thefile) dtype <- .shortDataType(x@file@datanotation) dsize <- dataSize(x@file@datanotation) if (dtype == 'INT' ) { if (dsize == 1) { pixtype <- "BYTE" } else if (dsize == 2) { pixtype <- "SHORTINT" } else if (dsize == 4) { pixtype <- "INTEGER" } if (! dataSigned(x@file@datanotation)) { pixtype <- paste(pixtype, "_UNSIGNED", sep="") } } else if ( x@file@datanotation == 'FLT4S' ) { pixtype <- "FLOAT" } else { stop(paste('cannot write SAGA file with data type:', x@file@datanotation)) } cat("DATAFORMAT\t=", pixtype, "\n", file = thefile) cat("DATAFILE_OFFSET\t= 0\n", file = thefile) cat("BYTEORDER_BIG\t=", x@file@byteorder != 'little', "\n", file = thefile) cat("POSITION_XMIN\t= ", as.character(xmin(x) + 0.5 * xres(x)), "\n", file = thefile) cat("POSITION_YMIN\t= ", as.character(ymin(x) + 0.5 * yres(x)), "\n", file = thefile) cat("CELLCOUNT_Y\t= ", nrow(x), "\n", file = thefile) cat("CELLCOUNT_X\t= ", ncol(x), "\n", file = thefile) cat("CELLSIZE\t= ", xres(x), "\n", file = thefile) cat("Z_FACTOR\t= 1.000000\n", file = thefile) cat("NODATA_VALUE\t=", .nodatavalue(x), "\n", file = thefile) cat("TOPTOBOTTOM\t= TRUE", "\n", file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/col2RGB.R0000644000176200001440000000055514160021141013263 0ustar liggesusers .col2RGB <- function(x) { d <- t( grDevices::col2rgb(x@legend@colortable) ) d <- data.frame(id=0:255, d) subs(x, d, which=2:4) } .alphaCT <- function(x, alpha) { ct <- colortable(x) z <- t(grDevices::col2rgb(ct)) ct <- apply(z, 1, function(i) grDevices::rgb(i[1], i[2], i[3], alpha*255, maxColorValue=255)) colortable(x) <- ct return(x) } raster/R/update.R0000644000176200001440000004061414160021141013353 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2010 # Version 0.9 # Licence GPL v3 if (!isGeneric("update")) { setGeneric("update", function(object, ...) standardGeneric("update")) } setMethod('update', signature(object='RasterLayer'), function(object, v, cell, ...) { if (!fromDisk(object)) { stop('object is not associated with a file on disk.') } band <- bandnr(object) cell <- stats::na.omit(round(cell)) driver <- object@file@driver if (.isNativeDriver(driver)) { stopifnot(object@file@toptobottom) if (nbands(object) > 1) { b <- brick(filename(object), native=TRUE) b <- update(b, v, cell, band=bandnr(object)) r <- raster(filename(object), band=bandnr(object)) return(r) } } datatype <- object@file@datanotation dtype <- substr(datatype, 1, 3) v <- .checkData(object, v, cell, dtype) setminmax <- FALSE if (object@data@haveminmax) { lst <- .updateMinMax(object, v, cell, 1) # band=1 because there is only one set of min/max values object <- lst[[1]] setminmax <- lst[[2]] } if (driver == 'gdal') { return( .updateGDAL(object, v, cell, band, setminmax) ) } else if (driver == 'netcdf') { return( .updateNCDF(object, v, cell, band ) ) } else if (.isNativeDriver(driver)) { return( .updateNativeSingle(object, v, cell, band, driver, datatype ) ) } stop('not implemented for: ', driver, ' files') } ) setMethod('update', signature(object='RasterBrick'), function(object, v, cell, band, ...) { if (!fromDisk(object)) { stop('object is not associated with a file on disk.') } stopifnot(band > 0 & band <= nbands(object)) cell <- stats::na.omit(round(cell)) datatype <- object@file@datanotation dtype <- substr(datatype, 1, 3) v <- .checkData(object, v, cell, dtype) setminmax <- FALSE if (object@data@haveminmax) { setminmax <- FALSE if (object@data@haveminmax) { object <- .updateMinMax(object, v, cell, band) setminmax <- object[[2]] object <- object[[1]] } } driver <- object@file@driver if (driver == 'gdal') { return( .updateGDAL(object, v, cell, band, setminmax) ) } else if (driver == 'netcdf') { return( .updateNCDF(object, v, cell, band ) ) } else if (.isNativeDriver(driver)) { stopifnot(object@file@toptobottom) return ( .updateNativeMultiple(object, v, cell, band, driver, datatype ) ) } stop('not implemented for: ', driver, ' files') } ) .updateNativeSingle <- function(object, v, cell, band, driver, datatype) { minv <- object@data@min maxv <- object@data@max object <- writeStart(object, filename(object), update=TRUE, format=driver, datatype=datatype, overwrite=TRUE) dtype <- substr(datatype, 1, 3) if (dtype == "INT" | dtype == "LOG") { v[is.na(v)] <- as.integer(object@file@nodatavalue) } else { v[] <- as.numeric(v) } if (is.matrix(v)) { for (r in 1:nrow(v)) { pos <- (cell-1) * object@file@dsize seek(object@file@con, pos, rw='w') writeBin(v[r,], object@file@con, size=object@file@dsize ) cell <- cell + object@ncols } } else { if (length(cell) == 1) { pos <- (cell-1) * object@file@dsize seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } else { for (i in 1:length(cell)) { pos <- (cell[i]-1) * object@file@dsize seek(object@file@con, pos, rw='w') writeBin(v[i], object@file@con, size=object@file@dsize ) } } } object@data@min <- minv object@data@max <- maxv object@data@haveminmax <- TRUE object <- writeStop(object) if (object@data@min == Inf) { object@data@haveminmax <- FALSE if (ncell(object) <= 1000000) { object <- setMinMax(object) hdr(object, driver) } } return( object ) } .updateNativeMultiple <- function(object, v, cell, band, driver, datatype ) { # need to support this too: stopifnot(object@file@toptobottom) bandorder <- object@file@bandorder getoff <- function(object, cell) { if (bandorder == 'BIL') { rc <- rowColFromCell(object, cell) - 1 off <- ((nbands(object) * (rc[1]) + (band-1)) * object@ncols + rc[2] ) * object@file@dsize } else if (bandorder == 'BIP') { off <- (nbands(object) * (cell-1) + band-1) * object@file@dsize } else if (bandorder == 'BSQ') { off <- (ncell(object) * (band-1) + (cell-1)) * object@file@dsize } else { stop("unknown band order") } return(off) } minv <- object@data@min maxv <- object@data@max object <- writeStart(object, filename(object), update=TRUE, format=driver, datatype=datatype, overwrite=TRUE, bandorder=bandorder) dtype <- substr(datatype, 1, 3) if (dtype == "INT" | dtype == "LOG") { v[is.na(v)] <- as.integer(object@file@nodatavalue) } else { v[] <- as.numeric(v) } if (is.matrix(v)) { if (bandorder == 'BIP') { for (r in 1:nrow(v)) { for (c in 1:ncol(v)) { pos <- getoff(object, cell+c-1) seek(object@file@con, pos, rw='w') writeBin(v[r,c], object@file@con, size=object@file@dsize ) } cell <- cell + object@ncols } } else { for (r in 1:nrow(v)) { pos <- getoff(object, cell) seek(object@file@con, pos, rw='w') writeBin(v[r,], object@file@con, size=object@file@dsize ) cell <- cell + object@ncols } } } else { if (length(cell) == 1) { if (bandorder == 'BSQ') { pos <- getoff(object, cell) seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } else if (bandorder == 'BIP') { for (i in 1:length(v)) { pos <- getoff(object, cell+i-1) seek(object@file@con, pos, rw='w') writeBin(v[i], object@file@con, size=object@file@dsize ) } } else { cell2 <- cell+length(v)-1 rows <- rowFromCell(object, cell) : rowFromCell(object, cell2) cols <- colFromCell(object, cell) : colFromCell(object, cell2) rows <- unique(rows) cols <- unique(cols) nr <- length(rows) if (nr == 1) { pos <- getoff(object, cell) seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } else { pos <- getoff(object, cellFromRowCol(object, rows[1], cols[1])) seek(object@file@con, pos, rw='w') nc <- object@ncols - cols[1] writeBin(v[1:nc], object@file@con, size=object@file@dsize ) v <- v[-(1:nc)] if (nr > 2) { nc <- object@ncols for (i in 3:(nr-1)) { pos <- getoff(object, cellFromRowCol(object, rows[i], 1)) seek(object@file@con, pos, rw='w') writeBin(v[1:nc], object@file@con, size=object@file@dsize ) v <- v[-(1:nc)] } if (length(v) > 0) { pos <- getoff(object, cellFromRowCol(object, rows[nr], 1)) seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } } } } } else { for (i in 1:length(cell)) { pos <- getoff(object, cell[i]) seek(object@file@con, pos, rw='w') writeBin(v[i], object@file@con, size=object@file@dsize ) } } } object@data@min <- minv object@data@max <- maxv object@data@haveminmax <- TRUE object <- writeStop(object) if (object@data@min[band] == Inf) { object@data@haveminmax <- FALSE if (ncell(object) * nbands(object) <= 1000000) { object <- setMinMax(object) hdr(object, driver) } } return( object ) } .updateNCDF <- function(object, v, cell, band) { nc <- ncdf4::nc_open(object@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) zvar <- object@data@zvar dims <- nc$var[[zvar]]$ndims if (dims > 3) { # there is code for one level higher, but I am not sure if it is OK, as it does not check the order or the vars. stop('not yet implemented for high dimensional (>4) ncdf files') } if (is.matrix(v)) { startrow <- rowFromCell(object, cell) startcol <- colFromCell(object, cell) if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(startcol, startrow), count=c(ncol(v), nrow(v))) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(startcol, startrow, band), count=c(ncol(v), nrow(v), 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(startcol, startrow, object@data@level, band), count=c(ncol(v), nrow(v), 1, 1)) ) } } else { if (length(cell) == 1) { cell <- cell:(cell+length(v)-1) rows <- rowFromCell(object, cell) cols <- colFromCell(object, cell) rows <- unique(rows) cols <- unique(cols) nr <- length(rows) if (nr == 1) { #v <- as.matrix(v) if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(cols[1], rows), count=c(length(cols), 1)) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(cols[1], rows, band), count=c(length(cols), 1, 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(cols[1], rows, object@data@level, band), count=c(length(cols), 1, 1, 1)) ) } } else { offset <- c(cols[1], rows[1]) ncols <- object@ncols - cols[1] vv <- v[1:ncols] if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(cols[1], rows), count=c(length(cols), 1)) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(cols[1], rows, band), count=c(length(cols), 1, 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(cols[1], rows, object@data@level, band), count=c(length(cols), 1, 1, 1)) ) } v <- v[-(1:nc)] if (nr > 2) { vv <- v[1:n] nrows <- nr-2 n <- nrows * object@ncols if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows), count=c(ncols, 1)) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, band), count=c(ncols, 1, 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, object@data@level, band), count=c(ncols, 1, 1, 1)) ) } v <- v[-(1:n)] } if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows), count=c(1, rows[nr])) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, band), count=c(1, rows[nr], 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, object@data@level, band), count=c(1, rows[nr], 1, 1)) ) } } } else { rows <- rowFromCell(object, cell) cols <- colFromCell(object, cell) if (nc$var[[zvar]]$ndims == 2) { for (i in 1:length(cell)) { try ( ncdf4::ncvar_put(nc, zvar, v[i], start=c(cols[i], rows[i]), count=c(1, 1)) ) } } else if (nc$var[[zvar]]$ndims == 3) { for (i in 1:length(cell)) { try ( ncdf4::ncvar_put(nc, zvar, v[i], start=c(cols[i], rows[i], band), count=c(1, 1, 1)) ) } } else if (nc$var[[zvar]]$ndims == 4) { for (i in 1:length(cell)) { try ( ncdf4::ncvar_put(nc, zvar, v[i], start=c(cols[i], rows[i], object@data@level, band), count=c(1, 1, 1, 1)) ) } } } } return( object ) } .updateGDAL <- function(object, v, cell, band, setminmax) { gdal <- methods::new("GDALDataset", filename(object)) on.exit( rgdal::GDAL.close(gdal) ) dr <- rgdal::getDriverName(rgdal::getDriver(gdal)) if (! dr %in% .gdalWriteFormats()[,1]) { stop('cannot update this file format (GDAL driver)') } if (is.matrix(v)) { startrow <- rowFromCell(object, cell) - 1 startcol <- colFromCell(object, cell) - 1 rgdal::putRasterData(gdal, t(v), band=band, offset= c(startrow, startcol) ) } else { if (length(cell) == 1) { cell <- cell:(cell+length(v)-1) rows <- rowFromCell(object, cell) - 1 cols <- colFromCell(object, cell) - 1 rows <- unique(rows) cols <- unique(cols) nr <- length(rows) if (nr == 1) { rgdal::putRasterData(gdal, v, band=band, offset=c(rows, cols[1])) } else { offset <- c(rows[1], cols[1]) nc <- object@ncols - cols[1] rgdal::putRasterData(gdal, v[1:nc], band=band, offset=offset) v <- v[-(1:nc)] if (nr > 2) { nrows <- nr-2 n <- nrows * object@ncols rgdal::putRasterData(gdal, t(matrix(v[1:n], ncol=object@ncols, byrow=TRUE)), band=band, offset=c(rows[2], 0)) v <- v[-(1:n)] } if (length(v) > 0) { rgdal::putRasterData(gdal, v, band=band, offset=c(rows[nr], 0)) } } } else { rows <- rowFromCell(object, cell) - 1 cols <- colFromCell(object, cell) - 1 for (i in 1:length(cell)) { rgdal::putRasterData(gdal, v[i], band=band, offset=c(rows[i], cols[i])) } } } if (setminmax) { b <- methods::new("GDALRasterBand", gdal, band) statistics <- c(object@data@min, object@data@max, NA, NA) rgdal::GDALcall(b, "SetStatistics", statistics) } return(object) } .checkData <- function(object, v, cell, dtype) { stopifnot(length(cell) > 0) if (is.matrix(v)) { if (length(cell) > 1) { warning('only first cell used') cell <- cell[1] } stopifnot(cell > 0) rc <- rowColFromCell(object, cell) if ((nrow(v) + rc[1] - 1) > nrow(object)) { stop('attempting to update beyond end of file') } if ((ncol(v) + rc[2] - 1) > ncol(object)) { stop('attempting to update beyond end of file') } dm <- dim(v) mat <- TRUE } else { stopifnot( is.vector(v) ) if (length(cell) > 1) { stopifnot(max(cell) <= ncell(object)) stopifnot(min(cell) > 0) if (length(cell) != length(v)) { # recycling vv <- cell vv[] <- v v <- vv } } else { stopifnot(cell > 0) if ((length(v) + cell - 1) > ncell(object)) { stop('attempting to update beyond end of file') } } mat <- FALSE } if (dtype == "INT" ) { v <- as.integer(round(v)) } else if ( dtype =='LOG' ) { v[v != 1] <- 0 v <- as.integer(v) } v[is.infinite(v)] <- NA if (mat) { dim(v) <- dm } return(v) } .updateMinMax <- function(object, v, cell, band) { setminmax <- FALSE v <- stats::na.omit(v) newmin <- FALSE newmax <- FALSE if (length(v) > 0) { minv <- min(v) maxv <- max(v) if (minv < object@data@min[band]) { newmin <- TRUE } if (maxv > object@data@max[band]) { newmax <- TRUE } } if (newmin & newmax) { object@data@min[band] <- minv object@data@max[band] <- maxv setminmax <- TRUE } else { if (is.matrix(v)) { rc <- rowColFromCell(object, cell) oldv <- getValuesBlock(object, rc[1], nrow(v), rc[2], ncol(v)) } else { if (length(cell) == 1) { oldv <- stats::na.omit(.cellValues(object, cell:(cell+length(v)-1))) } else { oldv <- stats::na.omit(.cellValues(object, cell)) } } if (length(oldv) > 0) { oldmin <- min(oldv) oldmax <- max(oldv) if (oldmin > object@data@min[band]) { lostmin <- FALSE } else { lostmin <- TRUE } if (oldmax < object@data@max[band]) { lostmax <- FALSE } else { lostmax <- TRUE } } else { lostmin <- FALSE lostmax <- FALSE } if (! (lostmin | lostmax) ) { if (newmin | newmax) { object@data@min <- min(object@data@min[band], minv) object@data@max <- max(object@data@max[band], maxv) setminmax <- TRUE } } else if ((lostmin & newmin) & (! lostmax)) { object@data@min <- min(object@data@min[band], minv) setminmax <- TRUE } else if ((lostmax & newmax) & (! lostmin)) { object@data@max <- max(object@data@max[band], maxv) setminmax <- TRUE } else { object@data@min[band] <- Inf object@data@max[band] <- -Inf object@data@haveminmax <- FALSE setminmax <- TRUE } } return(list(object, setminmax)) } .updateGDALminmax <- function(object, minv, maxv) { gdal <- methods::new("GDALDataset", filename(object)) on.exit( rgdal::GDAL.close(gdal) ) for (band in 1:nlayers(object)) { b <- methods::new("GDALRasterBand", gdal, band) statistics <- c(minv[band], maxv[band], NA, NA) rgdal::GDALcall(b, "SetStatistics", statistics) } return(object) } raster/R/AAgeneric_functions.R0000644000176200001440000003403114160021141015773 0ustar liggesusers if (!isGeneric("as.raster")) { setGeneric("as.raster", function(x, ...) standardGeneric("as.raster"))} if (!isGeneric("all.equal")) { setGeneric("all.equal", function(target, current, ...) standardGeneric("all.equal"))} if (!isGeneric("extent")) { setGeneric("extent", function(x, ...) standardGeneric("extent")) } if (!isGeneric("hillShade")) {setGeneric("hillShade", function(x, ...) standardGeneric("hillShade"))} if (!isGeneric("rectify")) {setGeneric("rectify", function(x, ...) standardGeneric("rectify"))} if (!isGeneric("whiches.max")) {setGeneric("whiches.max", function(x, ...)standardGeneric("whiches.max"))} if (!isGeneric("whicheses.min")) {setGeneric("whiches.min", function(x, ...)standardGeneric("whiches.min"))} if (!isGeneric("origin<-")) {setGeneric("origin<-", function(x, value) standardGeneric("origin<-"))} if (!isGeneric("weighted.mean")) {setGeneric("weighted.mean", function(x, w, ...) standardGeneric("weighted.mean"))} if (!isGeneric("%in%")) { setGeneric("%in%", function(x, table) standardGeneric("%in%"))} if (!isGeneric("adjacent")) {setGeneric("adjacent", function(x, ...) standardGeneric("adjacent"))} if (!isGeneric("aggregate")) {setGeneric("aggregate", function(x, ...) standardGeneric("aggregate"))} if (!isGeneric("animate")) { setGeneric("animate", function(x, ...) standardGeneric("animate")) } if (!isGeneric("approxNA")) {setGeneric("approxNA", function(x, ...) standardGeneric("approxNA"))} if (!isGeneric("area")) {setGeneric("area", function(x, ...) standardGeneric("area"))} if (!isGeneric("as.data.frame")) { setGeneric("as.data.frame", function(x, row.names = NULL, optional = FALSE, ...) standardGeneric("as.data.frame")) } if (!isGeneric("as.factor")) {setGeneric("as.factor", function(x) standardGeneric("as.factor"))} if (!isGeneric("is.factor")) {setGeneric("is.factor", function(x) standardGeneric("is.factor"))} if (!isGeneric("atan2")) { setGeneric("atan2", function(y, x) standardGeneric("atan2"))} if (!isGeneric("bbox")) {setGeneric("bbox", function(obj) standardGeneric("bbox"))} if (!isGeneric("barplot")) {setGeneric("barplot", function(height,...) standardGeneric("barplot"))} if (!isGeneric("boundaries")) { setGeneric("boundaries", function(x, ...) standardGeneric("boundaries"))} if (!isGeneric("boxplot")) { setGeneric("boxplot", function(x, ...) standardGeneric("boxplot")) } if (!isGeneric("brick")) { setGeneric("brick", function(x, ...) standardGeneric("brick"))} if (!isGeneric("buffer")) {setGeneric("buffer", function(x, ...) standardGeneric("buffer"))} if (!isGeneric("calc")) {setGeneric("calc", function(x, fun, ...) standardGeneric("calc")) } if (!isGeneric("clamp")) {setGeneric("clamp", function(x, ...) standardGeneric("clamp")) } if (!isGeneric("click")) { setGeneric("click", function(x, ...) standardGeneric("click"))} if (!isGeneric("clump")) {setGeneric("clump", function(x, ...) standardGeneric("clump")) } if (!isGeneric("contour")) { setGeneric("contour", function(x,...) standardGeneric("contour"))} if ( !isGeneric("corLocal") ) { setGeneric("corLocal", function(x, y, ...) standardGeneric("corLocal"))} if (!isGeneric("couldBeLonLat")) { setGeneric("couldBeLonLat", function(x, ...) standardGeneric("couldBeLonLat"))} if (!isGeneric("cover")) {setGeneric("cover", function(x, y, ...) standardGeneric("cover"))} if (!isGeneric("crop")) { setGeneric("crop", function(x, y, ...) standardGeneric("crop"))} if (!isGeneric("crosstab")) { setGeneric("crosstab", function(x, y, ...) standardGeneric("crosstab"))} if (!isGeneric("crs")) { setGeneric("crs", function(x, ...) standardGeneric("crs")) } if (!isGeneric("crs<-")) { setGeneric("crs<-", function(x, ..., value) standardGeneric("crs<-")) } if (!isGeneric("cut")) {setGeneric("cut", function(x, ...) standardGeneric("cut"))} if (!isGeneric("direction")) {setGeneric("direction", function(x, ...) standardGeneric("direction"))} if (!isGeneric("density")) { setGeneric("density", function(x, ...) standardGeneric("density"))} if (!isGeneric("disaggregate")) {setGeneric("disaggregate", function(x, ...) standardGeneric("disaggregate"))} if (!isGeneric("distance")) {setGeneric("distance", function(x, y, ...)standardGeneric("distance"))} if (!isGeneric("erase")) {setGeneric("erase", function(x, y, ...) standardGeneric("erase"))} if (!isGeneric("extend")) {setGeneric("extend", function(x, y, ...) standardGeneric("extend"))} if (!isGeneric("extract")) { setGeneric("extract", function(x, y, ...) standardGeneric("extract"))} if (!isGeneric("flip")) { setGeneric("flip", function(x, ...) standardGeneric("flip")) } if (!isGeneric("focal")) { setGeneric("focal", function(x, ...) standardGeneric("focal"))} if (!isGeneric("freq")) {setGeneric("freq", function(x, ...) standardGeneric("freq"))} if (!isGeneric("geom")) { setGeneric("geom", function(x, ...) standardGeneric("geom"))} if (!isGeneric("gridDistance")) {setGeneric("gridDistance", function(x, ...) standardGeneric("gridDistance"))} if (!isGeneric("head")) { setGeneric("head", function(x, ...) standardGeneric("head"))} if (!isGeneric("hasValues")) { setGeneric("hasValues", function(x, ...) standardGeneric("hasValues"))} if (!isGeneric("inMemory")) {setGeneric("inMemory", function(x, ...) standardGeneric("inMemory"))} #if (!isGeneric("ifel")) {setGeneric("ifel", function(test, yes, no, ...) standardGeneric("ifel"))} if (!isGeneric("image")) {setGeneric("image", function(x,...) standardGeneric("image"))} if (!isGeneric("init")) {setGeneric("init", function(x, ...) standardGeneric("init"))} if (!isGeneric("interpolate")) { setGeneric("interpolate", function(object, ...) standardGeneric("interpolate"))} if (!isGeneric("intersect")) { setGeneric("intersect", function(x, y) standardGeneric("intersect"))} if (!isGeneric("isLonLat")) { setGeneric("isLonLat", function(x, ...) standardGeneric("isLonLat"))} if (!isGeneric("layerize")) { setGeneric("layerize", function(x, y, ...) standardGeneric("layerize"))} if (!isGeneric("metadata")) { setGeneric("metadata", function(x, ...) standardGeneric("metadata"))} if (!isGeneric("match")) { setGeneric("match", function(x, table, nomatch=NA_integer_, incomparables=NULL) standardGeneric("match"))} if (!isGeneric("mask")) { setGeneric("mask", function(x, mask, ...) standardGeneric("mask"))} if (!isGeneric(".median")) {setGeneric(".median", function(x, y, ...) standardGeneric(".median"))} if (!isGeneric("merge")) {setGeneric("merge", function(x, y, ...) standardGeneric("merge"))} if (!isGeneric("mosaic")) {setGeneric("mosaic", function(x, y, ...)standardGeneric("mosaic"))} if (!isGeneric("modal")) {setGeneric("modal", function(x, ...) standardGeneric("modal"))} if (!isGeneric("ncell")) { setGeneric("ncell", function(x) standardGeneric("ncell")) } if (!isGeneric("ncol")) { setGeneric("nrow", function(x) standardGeneric("nrow")) } if (!isGeneric("ncol<-")) { setGeneric("ncol<-", function(x, ..., value) standardGeneric("ncol<-")) } if (!isGeneric("nrow")) { setGeneric("nrow", function(x) standardGeneric("nrow")) } if (!isGeneric("nrow<-")) { setGeneric("nrow<-", function(x, ..., value) standardGeneric("nrow<-")) } if (!isGeneric("overlay")) { setGeneric("overlay", function(x, y, ...) standardGeneric("overlay"))} if (!isGeneric("origin")) { setGeneric("origin", function(x, ...) standardGeneric("origin")) } if (!isGeneric("pairs")) { setGeneric("pairs", function(x, ...) standardGeneric("pairs"))} if (!isGeneric("persp")) { setGeneric("persp", function(x,...) standardGeneric("persp")) } if (!isGeneric("plot")) {setGeneric("plot", function(x,y,...)standardGeneric("plot"))} if (!isGeneric("plotRGB")) { setGeneric("plotRGB", function(x, ...) standardGeneric("plotRGB"))} if (!isGeneric("predict")) {setGeneric("predict", function(object, ...) standardGeneric("predict"))} if (!isGeneric("quantile")) {setGeneric("quantile", function(x, ...)standardGeneric("quantile"))} if (!isGeneric("RGB")) {setGeneric("RGB", function(x, ...) standardGeneric("RGB"))} if ( !isGeneric("raster") ) {setGeneric("raster", function(x, ...) standardGeneric("raster"))} if (!isGeneric("rasterize")) {setGeneric("rasterize", function(x, y, ...) standardGeneric("rasterize"))} if (!isGeneric("readStart")) {setGeneric("readStart", function(x, ...) standardGeneric("readStart"))} if (!isGeneric("readStop")) {setGeneric("readStop", function(x) standardGeneric("readStop"))} if (!isGeneric("reclassify")) { setGeneric("reclassify", function(x, rcl, ...) standardGeneric("reclassify"))} if (!isGeneric("res")) { setGeneric("res", function(x) standardGeneric("res")) } if (!isGeneric("res<-")) { setGeneric("res<-", function(x, value) standardGeneric("res<-")) } if (!isGeneric("resample")) { setGeneric("resample", function(x, y, ...) standardGeneric("resample"))} if (!isGeneric("rotate")) { setGeneric("rotate", function(x, ...) standardGeneric("rotate"))} if (!isGeneric("sampleRegular")) { setGeneric("sampleRegular", function(x, size, ...) standardGeneric("sampleRegular"))} if (!isGeneric("sampleRandom")) { setGeneric("sampleRandom", function(x, size, ...) standardGeneric("sampleRandom"))} if (!isGeneric("sampleStratified")) {setGeneric("sampleStratified", function(x, size, ...) standardGeneric("sampleStratified"))} if (!isGeneric("select")) {setGeneric("select", function(x, ...) standardGeneric("select"))} if (!isGeneric("setMinMax")) {setGeneric("setMinMax", function(x, ...) standardGeneric("setMinMax")) } if (!isGeneric("shift")) {setGeneric("shift", function(x, ...) standardGeneric("shift"))} if (!isGeneric("stretch")) {setGeneric("stretch", function(x, ...) standardGeneric("stretch"))} if (!isGeneric("subset")) { setGeneric("subset", function(x, ...) standardGeneric("subset"))} if (!isGeneric("t")) { setGeneric("t", function(x) standardGeneric("t"))} if (!isGeneric("tail")) { setGeneric("tail", function(x, ...) standardGeneric("tail"))} if (!isGeneric("terrain")) { setGeneric("terrain", function(x, ...) standardGeneric("terrain"))} if (!isGeneric("text")) { setGeneric("text", function(x, ...) standardGeneric("text")) } if (!isGeneric("trim")) { setGeneric("trim", function(x, ...) standardGeneric("trim"))} if (!isGeneric("unique")) { setGeneric("unique", function(x, incomparables=FALSE, ...) standardGeneric("unique")) } if (!isGeneric("union")) {setGeneric("union", function(x, y)standardGeneric("union"))} if (!isGeneric("setValues")) {setGeneric("setValues", function(x, values, ...) standardGeneric("setValues"))} if (!isGeneric("values")) { setGeneric("values", function(x, ...) standardGeneric("values")) } if (!isGeneric("values<-")) { setGeneric("values<-", function(x, value) standardGeneric("values<-"))} if (!isGeneric("which.max")) {setGeneric("which.max", function(x)standardGeneric("which.max"))} if (!isGeneric("which.min")) {setGeneric("which.min", function(x)standardGeneric("which.min"))} if (!isGeneric("writeRaster")) {setGeneric("writeRaster", function(x, filename, ...) standardGeneric("writeRaster"))} if (!isGeneric("writeStart")) { setGeneric("writeStart", function(x, filename, ...) standardGeneric("writeStart"))} if (!isGeneric("writeStop")) { setGeneric("writeStop", function(x) standardGeneric("writeStop"))} if (!isGeneric("writeValues")) { setGeneric("writeValues", function(x, v, ...) standardGeneric("writeValues")) } if (!isGeneric("wkt")) { setGeneric("wkt", function(obj) standardGeneric("wkt")) } if (!isGeneric("xres")) { setGeneric("xres", function(x) standardGeneric("xres")) } if (!isGeneric("yres")) { setGeneric("yres", function(x) standardGeneric("yres")) } if (!isGeneric("zonal")) {setGeneric("zonal", function(x, z, ...) standardGeneric("zonal"))} if (!isGeneric("zoom")) {setGeneric("zoom", function(x, ...)standardGeneric("zoom"))} if (!isGeneric("yFromRow")) { setGeneric("yFromRow", function(object, row) standardGeneric("yFromRow")) } if (!isGeneric("xFromCol")) { setGeneric("xFromCol", function(object, col) standardGeneric("xFromCol")) } if (!isGeneric("colFromX")) { setGeneric("colFromX", function(object, x) standardGeneric("colFromX")) } if (!isGeneric("rowFromY")) { setGeneric("rowFromY", function(object, y) standardGeneric("rowFromY")) } if (!isGeneric("cellFromXY")) { setGeneric("cellFromXY", function(object, xy) standardGeneric("cellFromXY")) } if (!isGeneric("cellFromRowCol")) { setGeneric("cellFromRowCol", function(object, row, col, ...) standardGeneric("cellFromRowCol")) } if (!isGeneric("cellFromRowColCombine")) { setGeneric("cellFromRowColCombine", function(object, row, col, ...) standardGeneric("cellFromRowColCombine")) } if (!isGeneric("xyFromCell")) { setGeneric("xyFromCell", function(object, cell, ...) standardGeneric("xyFromCell")) } if (!isGeneric("yFromCell")) { setGeneric("yFromCell", function(object, cell) standardGeneric("yFromCell")) } if (!isGeneric("xFromCell")) { setGeneric("xFromCell", function(object, cell) standardGeneric("xFromCell")) } if (!isGeneric("rowColFromCell")) { setGeneric("rowColFromCell", function(object, cell) standardGeneric("rowColFromCell")) } if (!isGeneric("rowFromCell")) { setGeneric("rowFromCell", function(object, cell) standardGeneric("rowFromCell")) } if (!isGeneric("colFromCell")) { setGeneric("colFromCell", function(object, cell) standardGeneric("colFromCell")) } # (!isGeneric("#")) { setGeneric("#", function(object) standardGeneric("#")) } if (!isGeneric("xmin")) {setGeneric("xmin", function(x) standardGeneric("xmin"))} if (!isGeneric("xmax")) {setGeneric("xmax", function(x) standardGeneric("xmax"))} if (!isGeneric("ymin")) {setGeneric("ymin", function(x) standardGeneric("ymin"))} if (!isGeneric("ymax")) {setGeneric("ymax", function(x) standardGeneric("ymax"))} if (!isGeneric("xmin<-")) { setGeneric("xmin<-", function(x, ..., value) standardGeneric("xmin<-")) } if (!isGeneric("xmax<-")) { setGeneric("xmax<-", function(x, ..., value) standardGeneric("xmax<-")) } if (!isGeneric("ymin<-")) { setGeneric("ymin<-", function(x, ..., value) standardGeneric("ymin<-")) } if (!isGeneric("ymax<-")) { setGeneric("ymax<-", function(x, ..., value) standardGeneric("ymax<-")) } raster/R/hdrBIL.R0000644000176200001440000000437114160235742013213 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrBIL <- function(x, layout='BIL') { hdrfile <- x@file@name extension(hdrfile) <- '.hdr' thefile <- file(hdrfile, "w") # open an txt file connectionis cat("NROWS ", x@nrows, "\n", file = thefile) cat("NCOLS ", x@ncols, "\n", file = thefile) cat("NBANDS ", nlayers(x), "\n", file = thefile) cat("NBITS ", dataSize(x@file@datanotation) * 8, "\n", file = thefile) btorder <- ifelse(x@file@byteorder == "little", "I", "M") cat("BYTEORDER ", btorder, "\n", file = thefile) # PIXELTYPE should work for Gdal, and perhpas ArcGIS, see: # http://lists.osgeo.org/pipermail/gdal-dev/2006-October/010416.html dtype <- .shortDataType(x@file@datanotation) if (dtype == 'INT' | dtype == 'LOG' ) { pixtype <- ifelse(dataSigned(x@file@datanotation), "SIGNEDINT", "UNSIGNEDINT") } else { pixtype <- "FLOAT" } cat("PIXELTYPE ", pixtype, "\n", file = thefile) cat("LAYOUT ", layout, "\n", file = thefile) cat("SKIPBYTES 0\n", file = thefile) cat("ULXMAP ", as.character(xmin(x) + 0.5 * xres(x)), "\n", file = thefile) cat("ULYMAP ", as.character(ymax(x) - 0.5 * yres(x)), "\n", file = thefile) cat("XDIM ", xres(x), "\n", file = thefile) cat("YDIM ", yres(x), "\n", file = thefile) browbytes <- round(ncol(x) * dataSize(x@file@datanotation) ) cat("BANDROWBYTES ", browbytes, "\n", file = thefile) cat("TOTALROWBYTES ", browbytes * nbands(x), "\n", file = thefile) cat("BANDGAPBYTES 0\n", file = thefile) cat("NODATA ", .nodatavalue(x), "\n", file = thefile) cat("\n\n", file = thefile) cat("The below is additional metadata, not part of the BIL/HDR format\n", file = thefile) cat("----------------------------------------------------------------\n", file = thefile) cat("CREATOR=R package:x\n", file = thefile) cat("CREATED=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n", file = thefile) cat("Projection=", proj4string(x), "\n", file = thefile) cat("MinValue=", minValue(x), "\n", file = thefile) cat("MaxValue=", maxValue(x), "\n", file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/mosaic.R0000644000176200001440000001054114160021141013340 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # redesigned for multiple row processing # October 2011 # version 1 setMethod('mosaic', signature(x='Raster', y='Raster'), function(x, y, ..., fun, tolerance=0.05, filename="") { x <- c(x, y, list(...)) isRast <- sapply(x, function(x) inherits(x, 'Raster')) dotargs <- x[ !isRast ] x <- x[ isRast ] if (is.null(dotargs$datatype)) { dotargs$datatype <- .commonDataType(sapply(x, dataType)) } filename <- trim(filename) dotargs$filename <- filename nl <- max(unique(sapply(x, nlayers))) compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance) bb <- .unionExtent(x) if (nl > 1) { out <- brick(x[[1]], values=FALSE, nl=nl) } else { out <- raster(x[[1]]) } out <- setExtent(out, bb, keepres=TRUE, snap=FALSE) fun <- .makeTextFun(fun) if (class(fun)[1] == 'character') { rowcalc <- TRUE fun <- .getRowFun(fun) } else { rowcalc <- FALSE } if ( canProcessInMemory(out, 2 + length(x)) ) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out)*nl, ncol=length(x)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) cells <- cells + rep(0:(nl-1)*ncell(out), each=length(cells)) v[cells, i] <- as.vector(getValues(x[[i]])) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } v <- matrix(v, ncol=nl) } else { v <- matrix(NA, nrow=ncell(out), ncol=length(x)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells,i] <- getValues(x[[i]]) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } rowcol <- matrix(NA, ncol=6, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] rowcol[i,1] <- rowFromY(out, xy1[2]) # start row on new raster rowcol[i,2] <- rowFromY(out, xy2[2]) # end row rowcol[i,3] <- colFromX(out, xy1[1]) # start col rowcol[i,4] <- colFromX(out, xy2[1]) # end col rowcol[i,5] <- i # layer rowcol[i,6] <- nrow(x[[i]]) } tr <- blockSize(out) pb <- pbCreate(tr$n, dotargs$progress, label='mosaic') dotargs$x <- out out <- do.call(writeStart, dotargs) if (nl == 1) { for (i in 1:tr$n) { rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { v <- matrix(NA, nrow=tr$nrow[i] * ncol(out), ncol=nrow(rc)) for (j in 1:nrow(rc)) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, j] <- getValues(x[[ rc[j,5] ]], r1, nr) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } } else { v <- rep(NA, tr$nrow[i] * ncol(out)) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out) * nl, ncol=nrow(rc)) for (j in 1:nrow(rc)) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) cells <- cells + rep(0:(nl-1)* tr$nrow[i]*ncol(out), each=length(cells)) v[cells, j] <- as.vector( getValues(x[[ rc[j,5] ]], r1, nr) ) } if (rowcalc) { v <- fun(v, na.rm=TRUE) } else { v <- apply(v, 1, fun, na.rm=TRUE) } v <- matrix(v, ncol=nl) } else { v <- matrix(NA, nrow=tr$nrow[i] * ncol(out), ncol=nl) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) writeStop(out) } ) raster/R/writeStartStopAscii.R0000644000176200001440000000352514160021141016060 0ustar liggesusers# Author: Robert J. Hijmans # Date : May 2010 # Version 0.9 # Licence GPL v3 .startAsciiWriting <- function(x, filename, NAflag, ...) { filename <- trim(filename) if (filename == '') { stop('provide a filename') } x@file@name <- filename x@file@driver <- 'ascii' overwrite <- .overwrite(...) dtype <- .shortDataType(.datatype(...)) x@file@datanotation = .datatype(...) dtype <- .shortDataType(x@file@datanotation) attr(x@file, "dtype") <- dtype if (!missing(NAflag)) { x@file@nodatavalue <- NAflag } else if (!is.finite( x@file@nodatavalue) ) { x@file@nodatavalue <- -3.4e+38 } resdif <- abs((yres(x) - xres(x)) / yres(x) ) if (resdif > 0.01) { stop(paste("x has unequal horizontal and vertical resolutions. Such data cannot be stored in arc-ascii format")) } else if (resdif > 0.001) { warning("ignoring the slightly unequal horizontal and vertical resolutions") } if (!overwrite & file.exists(filename)) { stop(paste(filename, "exists. Use 'overwrite=TRUE'")) } thefile <- file(filename, "w") # open an txt file connection cat("NCOLS", ncol(x), "\n", file = thefile) cat("NROWS", nrow(x), "\n", file = thefile) cat("XLLCORNER", as.character(xmin(x)), "\n", file = thefile) cat("YLLCORNER", as.character(ymin(x)), "\n", file = thefile) cat("CELLSIZE", as.character(xres(x)), "\n", file = thefile) cat("NODATA_value", x@file@nodatavalue, "\n", file = thefile) close(thefile) #close connection return(x) } .stopAsciiWriting <- function(x) { x@data@haveminmax <- TRUE if (x@file@dtype == "INT") { x@data@min <- round(x@data@min) x@data@max <- round(x@data@max) # } else if ( x@file@dtype =='LOG' ) { # raster@data@min <- as.logical(raster@data@min) # raster@data@max <- as.logical(raster@data@max) } return( raster( x@file@name ) ) } raster/R/dotdens.R0000644000176200001440000000262214160021141013526 0ustar liggesusers# Robert Hijmans # Based on maptools:dotsInPolys by Roger Bivand .dotdensity <- function(p, field, x=1, type="regular", seed=0, sp=FALSE, ...) { set.seed(seed) stopifnot(inherits(p, 'SpatialPolygons')) n <- length(p) if (n < 1) return(invisible(NULL)) f <- tolower(type) stopifnot(type %in% c('regular', 'random')) if (inherits(p, 'SpatialPolygonsDataFrame')) { if (is.numeric(field)) { if (length(field)==1) { field <- round(field) stopifnot(field > 0 & field <= ncol(p)) field <- p@data[, field] } else { stopifnot(length(field)==length(p)) } } else if (is.character(field)) { stopifnot(field %in% names(p)) field <- p@data[, field] } } else { stopifnot(is.numeric(field)) stopifnot(length(field)==length(p)) } x <- x[1] stopifnot(x > 0) d <- round(field / x) d[d < 1] <- 0 d[is.na(d)] <- 0 res <- vector(mode = "list", length = n) for (i in 1:n) { if (d[i] > 0) { ires <- try (sp::spsample(p[i, ], d[i], type=f), silent=TRUE ) if (inherits(ires, "try-error")) { print(paste('error, ', d[i])) ires <- NULL } if (!is.null(ires)) { res[[i]] <- cbind(sp::coordinates(ires), id=i) } } } res <- do.call("rbind", res) colnames(res)[1:2] <- c('x', 'y') if (sp) { res <- data.frame(res) sp::coordinates(res) <- ~ x+y crs(res) <- crs(p) } res } raster/R/mean.R0000644000176200001440000001344714160021141013015 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 .deepCopyRasterLayer <- function(x, filename="", ...) { out <- raster(x) if (canProcessInMemory(x)) { return( setValues(out, getValues(x)) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='copy') out <- writeStart(out, filename=filename) x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } setMethod("mean", signature(x='Raster'), function(x, ..., trim=NA, na.rm=FALSE){ if (!is.na(trim)) { warning("argument 'trim' is ignored") } dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- unlist(.addArgs(...)) } else { add <- NULL } out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (nlayers(x) == 1) { return(.deepCopyRasterLayer(x)) } if (canProcessInMemory(x)) { x <- getValues(x) x <- setValues(out, .rowMeans(x, nc, d[3], na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='mean') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMeans(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { d3 <- d[3] + length(add) if (canProcessInMemory(x)) { if (length(add) == 1) { x <- cbind(getValues(x), add) } else { x <- getValues(x) x <- t(apply(x, 1, function(i) c(i, add))) } x <- setValues(out, .rowMeans(x, nc, d3, na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='mean') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- t(apply(v, 1, function(i) c(i, add))) v <- .rowMeans(v, tr$nrows[i]*d[2], d3, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } ) .sum <- function(x, add=NULL, na.rm=FALSE){ out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowSums(getValues(x), nc, d[3], na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='sum') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowSums(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return ( writeStop(out) ) } else { add <- sum(add, na.rm=na.rm) d3 <- d[3] + 1 if (canProcessInMemory(x)) { return( setValues(out, .rowSums(cbind(getValues(x), add), nc, d3, na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='sum') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowSums(cbind(v, add), tr$nrows[i]*d[2], d3, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) writeStop(out) } } .min <- function(x, add=NULL, na.rm=FALSE) { out <- raster(x) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowMin(getValues(x), na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='min') out <- writeStart(out, filename="") #x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMin(v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) #x <- readStop(x) return ( writeStop(out) ) } else { add <- min(add, na.rm=na.rm) if (canProcessInMemory(x)) { x <- setValues(out, .rowMin(cbind(getValues(x), add), na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='min') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMin(cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return ( writeStop(out) ) } } .max <- function(x, add=NULL, na.rm=FALSE){ out <- raster(x) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowMax(getValues(x), na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='max') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMax( v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { add <- max(add, na.rm=na.rm) if (canProcessInMemory(x)) { x <- setValues(out, .rowMax(cbind(getValues(x), add), na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='max') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMax( cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } raster/R/index.R0000644000176200001440000000656114160021141013203 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("[", c("Extent", "numeric", "missing"), function(x, i, j, ... ,drop=TRUE) { x <- as.vector(x) x[i] }) setMethod("[", c("Extent", "missing", "missing"), function(x, i, j, ... ,drop=TRUE) { as.vector(x) }) setMethod("[", c("Raster", "Spatial", "missing"), function(x, i, j, ... ,drop=TRUE) { if (inherits(i, 'SpatialPoints')) { i <- sp::coordinates(i)[,1:2,drop=FALSE] i <- cellFromXY(x, i) .doExtract(x, i, ..., drop=drop) } else { if (drop) { extract(x, i, ...) } else { x <- crop(x, i, ...) rasterize(i, x, mask=TRUE, ...) } } }) setMethod("[", c("Raster", "RasterLayer", "missing"), function(x, i, j, ... ,drop=TRUE) { if (! hasValues(i) ) { i <- extent(i) methods::callNextMethod(x, i=i, ..., drop=drop) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { i <- which( as.logical( getValues(i) ) ) .doExtract(x, i, drop=drop) } else { i <- intersect(extent(x), extent(i)) methods::callNextMethod(x, i=i, ..., drop=drop) } }) setMethod("[", c("Raster", "Extent", "missing"), function(x, i, j, ... ,drop=TRUE) { if (drop) { return( extract(x, i) ) } else { return( crop(x, i) ) } } ) setMethod("[", c("Raster", "missing", "missing"), function(x, i, j, ... ,drop=TRUE) { if (drop) { return(getValues(x)) } else { return(x) } }) setMethod("[", c("Raster", "numeric", "numeric"), function(x, i, j, ... ,drop=TRUE) { i <- cellFromRowColCombine(x, i, j) .doExtract(x, i, drop=drop) } ) setMethod("[", c("Raster", "missing", "numeric"), function(x, i, j, ... ,drop=TRUE) { j <- cellFromCol(x, j) .doExtract(x, j, drop=drop) }) setMethod("[", c("Raster", "numeric", "missing"), function(x, i, j, ... ,drop=TRUE) { theCall <- sys.call(-1) narg <- length(theCall) - length(match.call(call=sys.call(-1))) if (narg > 0) { i <- cellFromRow(x, i) } .doExtract(x, i, drop=drop) }) setMethod("[", c("Raster", "matrix", "missing"), function(x, i, j, ... ,drop=TRUE) { if (ncol(i) == 2) { i <- cellFromRowCol(x, i[,1], i[,2]) } else { i <- as.vector(i) } .doExtract(x, i, drop=drop) }) setMethod("[", c("Raster", "logical", "missing"), function(x, i, j, ... , drop=TRUE) { theCall <- sys.call(-1) narg <- length(theCall) - length(match.call(call=sys.call(-1))) if (narg > 0) { stop('logical indices are only accepted if only the first index is used') } i <- which(i) .doExtract(x, i, drop=drop) }) .doExtract <- function(x, i, drop) { if (length(i) < 1) return(NULL) nacount <- sum(is.na(i)) if (nacount > 0) { warning('some indices are invalid (NA returned)') } if (!drop) { i <- stats::na.omit(i) r <- rasterFromCells(x, i, values=FALSE) if (nlayers(x) > 1) { r <- brick(r) if (hasValues(x)) { newi <- cellFromXY(r, xyFromCell(x, i)) v <- matrix(NA, nrow=ncell(r), ncol=nlayers(x)) v[newi,] <- .cellValues(x, i) r <- setValues(r, v) } return(r) } else { if (hasValues(x)) { newi <- cellFromXY(r, xyFromCell(x, i)) r[newi] <- .cellValues(x, i) } return(r) } } else { if (! hasValues(x) ) { stop('no data associated with this Raster object') } return( .cellValues(x, i) ) } } raster/R/netCDFreadCells.R0000644000176200001440000001127114160021141015010 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .readRasterCellsNetCDF <- function(x, cells) { if (canProcessInMemory(x, 2)) { # read all r <- getValues(x) r <- r[cells] return(r) } row1 <- rowFromCell(x, min(cells)) row2 <- rowFromCell(x, max(cells)) if ((row2 - row1) < 10 ) { # read only rows needed ncl <- (row2 - row1 + 1) * x@ncols r <- raster(nrow=1, ncol=ncl) v <- getValues(x, row1, row2-row1+1) v <- v[cells-cellFromRowCol(x, row1, 1)+1] return(v) } # read row by row colrow <- matrix(ncol=3, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow[,3] <- NA rows <- sort(unique(colrow[,2])) readrows <- rows if ( x@file@toptobottom ) { readrows <- x@nrows - readrows + 1 } zvar = x@data@zvar time = x@data@band nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) if (nc$var[[zvar]]$ndims == 1) { ncx <- x@ncols count <- ncx for (i in 1:length(rows)) { start <- (readrows[i]-1) * ncx + 1 v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else if (nc$var[[zvar]]$ndims == 2) { count <- c(x@ncols, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i]) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else if (nc$var[[zvar]]$ndims == 3) { count <- c(x@ncols, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], time) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { if (x@data@dim3 == 4) { count <- c(x@ncols, 1, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], x@data@level, time) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { count <- c(x@ncols, 1, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], time, x@data@level) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } } colrow <- colrow[,3] #if (!is.na(x@file@nodatavalue)) { colrow[colrow==x@file@nodatavalue] <- NA } #colrow <- x@data@add_offset + colrow * x@data@scale_factor colrow[colrow == x@file@nodatavalue] <- NA return(colrow) } .readBrickCellsNetCDF <- function(x, cells, layer, nl) { i <- which(!is.na(cells)) if (length(cells) > 1000) { if (canProcessInMemory(x, 2)) { # read all endlayer <- layer+nl-1 r <- getValues(x) r <- r[cells, layer:endlayer] return(r) } } # read cell by cell zvar <- x@data@zvar dim3 <- x@data@dim3 cols <- colFromCell(x, cells) rows <- rowFromCell(x, cells) if ( x@file@toptobottom ) { rows <- x@nrows - rows + 1 } nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) # this needs to be optimized. Read chunks and extract cells j <- which(!is.na(cells)) if (nc$var[[zvar]]$ndims == 2) { count <- c(1, 1) res <- matrix(NA, nrow=length(cells), ncol=1) for (i in j) { start <- c(cols[i], rows[i]) res[i] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } else if (nc$var[[zvar]]$ndims == 3) { count <- c(1, 1, nl) res <- matrix(NA, nrow=length(cells), ncol=nl) for (i in j) { start <- c(cols[i], rows[i], layer) res[i,] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } else { if (x@data@dim3 == 4) { count <- c(1, 1, 1, nl) res <- matrix(NA, nrow=length(cells), ncol=nl) for (i in j) { start <- c(cols[i], rows[i], x@data@level, layer) res[i,] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } else { count <- c(1, 1, nl, 1) res <- matrix(nrow=length(cells), ncol=nl) for (i in 1:length(cells)) { start <- c(cols[i], rows[i], layer, x@data@level) res[i,] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } } #if (!is.na(x@file@nodatavalue)) { res[res==x@file@nodatavalue] <- NA } #res <- x@data@add_offset + res * x@data@scale_factor res[res == x@file@nodatavalue] <- NA return(res) } raster/R/rasterizePoints.R0000644000176200001440000001340614160021141015275 0ustar liggesusers# Author: Robert J. Hijmans, Paul Hiemstra, Steven Mosher # Date : January 2009 # Version 0.9 # Licence GPL v3 .pointsToRaster <- function(xy, r, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...) { rs <- raster(r) if (mask & update) { stop('use either "mask=TRUE" OR "update=TRUE", or neither') } else if (mask) { oldraster <- r } else if (update) { oldraster <- r if (!is.numeric(updateValue)) { if (is.na(updateValue)) { updateValue <- 'NA' } else if (!(updateValue == 'NA' | updateValue == '!NA' | updateValue == 'all')) { stop('updateValue should be either "all", "NA", "!NA"') } } } if (is.character(fun)) { if (!(fun %in% c('first', 'last', 'sum', 'min', 'max', 'count'))) { stop('invalid value for fun') } if (fun == 'sum') { fun <- sum } else if (fun == 'min') { fun <- min } else if (fun == 'max') { fun <- max } else { if (na.rm) { if (fun == 'first') { fun <- function(x, ...) { # stats::na.omit(x[1]) # fix by Daniel Schlapfer stats::na.omit(x)[1] } } else if (fun == 'last') { fun <- function(x, ...) { x <- stats::na.omit(x); x[length(x)] } } else if (fun == 'count') { fun <- function(x, ...) length(stats::na.omit(x)) } } else { if (fun == 'first') { fun <- function(x, ...) { x[1] } } else if (fun == 'last') { fun <- function(x, ...) { # x[length(x)] # fix by Daniel Schlapfer x <- stats::na.omit(x) if (length(x) > 0) { x[length(x)] } else { NA } } } else if (fun == 'count') { fun <- function(x, ...) length(x) } } } } points <- .pointsToMatrix(xy) field <- .getPutVals(xy, field, nrow(points), mask) xy <- points nres <- max(length(fun(1)), length(fun(1:5))) ncols <- 1 if (NCOL(field) > 1) { if (nres > 1) stop('Either use a single function for "fun", or a single vector for "field"') nres <- ncols <- ncol(field) } else { if (is.atomic(field) & length(field)==1) { field <- rep(field, dim(xy)[1]) } if (nrow(xy) != NROW(field)) { stop('number of points does not match the number of fields') } } cells <- cellFromXY(rs, xy) # todisk <- TRUE todisk <- FALSE if (!canProcessInMemory(rs, 2 * nres)) { if (filename == '') { filename <- rasterTmpFile() } todisk <- TRUE } if (todisk) { rows <- rowFromCell(rs, cells) cols <- colFromCell(rs, cells) xyarc <- cbind(xy, rows, cols, field) urows <- unique(rows) # urows <- urows[order(urows)] if (nres==1) { dna <- vector(length=ncol(rs)) dna[] <- background } else { rs <- brick(rs) # return a'RasterBrick' rs@data@nlayers <- nres if (ncols > 1) { names(rs) <- colnames(field) } dna <- matrix(background, nrow=ncol(rs), ncol=nres) datacols <- 5:ncol(xyarc) } pb <- pbCreate(nrow(rs), ...) rs <- writeStart(rs, filename=filename, ...) for (r in 1:rs@nrows) { d <- dna if (r %in% urows) { ss <- subset(xyarc, xyarc[,3] == r) #ucols <- unique(ss[,5]) #for (c in 1:length(ucols)) { # sss <- subset(ss, ss[,5] == ucols[c] ) # d[ucols[c]] <- fun(sss[,3]) #} if (ncols > 1) { v <- aggregate(ss[,datacols,drop=FALSE], list(ss[,4]), fun, na.rm=na.rm) cells <- as.numeric(v[,1]) d[cells, ] <- as.matrix(v)[,-1] } else { v <- tapply(ss[,5], ss[,4], fun, na.rm=na.rm) cells <- as.numeric(rownames(v)) if (nres > 1) { v <- as.matrix(v) v <- t(apply(v, 1, function(x) x[[1]])) # Reshape the data if more than one value is returned by 'fun' d[cells, ] <- v } else { d[cells] <- v } } } # need to check if nlayers matches ncols (how many layers returned?) if (mask) { oldvals <- getValues(oldraster, r) ind <- which(is.na(d)) oldvals[ind] <- NA d <- oldvals } else if (update) { oldvals <- getValues(oldraster, r) if (updateValue == "all") { ind <- which(!is.na(d)) } else if (updateValue == "zero") { ind <- which(oldvals==0 & !is.na(d)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { ind <- which(!is.na(oldvals) & !is.na(d)) } oldvals[ind] <- d[ind] d <- oldvals } rs <- writeValues(rs, d, r) pbStep(pb, r) } rs <- writeStop(rs) pbClose(pb) } else { v <- aggregate(field, list(cells), fun, na.rm=na.rm) cells <- as.numeric(v[,1]) v <- as.matrix(v)[,-1,drop=FALSE] if(class(v[1]) == "list") { v <- t(apply(v, 1, function(x) x[[1]])) # Reshape the data if more than one value is returned by 'fun' } if (ncol(v) > 1) { vv <- matrix(background, nrow=ncell(rs), ncol=dim(v)[2]) vv[cells, ] <- v rs <- brick(rs) # return a'RasterBrick' } else { vv <- 1:ncell(rs) vv[] <- background vv[cells] <- v } if (mask) { oldvals <- getValues(oldraster) ind <- which(is.na(vv)) oldvals[ind] <- NA vv <- oldvals } else if (update) { oldvals <- getValues(oldraster) if (updateValue == "all") { ind <- which(!is.na(vv)) } else if (updateValue == "zero") { ind <- which(oldvals==0 & !is.na(vv)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { ind <- which(!is.na(oldvals) & !is.na(vv)) } oldvals[ind] <- vv[ind] vv <- oldvals } rs <- setValues(rs, vv) if (ncols > 1) { cn <- colnames(field) if (! is.null(cn)) { names(rs) <- cn } } if (filename != "") { rs <- writeRaster(rs, filename=filename, ...) } } return(rs) } raster/R/sampleAlong.R0000644000176200001440000000453614160021141014336 0ustar liggesusers# Based on code by Barry Rowlingson #http://r-sig-geo.2731867.n2.nabble.com/how-to-generate-perpendicular-transects-along-a-line-feature-td7583710.html # Some adaptations by Robert Hijmans .evenspace <- function(xy, sep, start=0.5*sep, direction=TRUE){ dx <- c(0,diff(xy[,1])) dy <- c(0,diff(xy[,2])) dseg <- sqrt(dx^2+dy^2) dtotal <- cumsum(dseg) linelength <- sum(dseg) pos <- seq(start,linelength, by=sep) whichseg <- unlist(lapply(pos, function(x){sum(dtotal<=x)})) x0 <- xy[whichseg,1] y0 <- xy[whichseg,2] x1 <- xy[whichseg+1,1] y1 <- xy[whichseg+1,2] dtotal <- dtotal[whichseg] further <- pos - dtotal dseg <- dseg[whichseg+1] f <- further/dseg x <- x0 + f * (x1-x0) y <- y0 + f * (y1-y0) r <- data.frame(x, y) if (direction) { r$direction <- atan2(y0-y1,x0-x1) } r } .transect <- function(pts, len){ directionT = pts$direction+pi/2 dx <- len*cos(directionT) dy <- len*sin(directionT) data.frame(x = c(pts$x + dx, pts$x - dx), y = c(pts$y + dy, pts$y - dy)) } .sampleAlong <- function(x, interval) { if (inherits(x, 'SpatialPolygons')) { line <- methods::as(line, 'SpatialLines') } if (inherits(x, 'SpatialLines')) { #requireNamespace('raster') x <- geom(x) allpts <- NULL for (p in unique(x[, 'cump'])) { y <- x[x[, 'cump']==p, c('x', 'y')] pts <- .evenspace(y, interval, direction=FALSE) allpts <- rbind(allpts, pts) } return(allpts) } else { x <- .pointsToMatrix(x) .evenspace(x, interval, direction=FALSE) } } .sampleAlongPerpendicular <- function(x, interval, pdist, np=1 ) { if (inherits(x, 'SpatialPolygons')) { line <- methods::as(line, 'SpatialLines') } if (inherits(x, 'SpatialLines')) { #requireNamespace('raster') x <- geom(x) allpts <- NULL for (p in unique(x[, 'cump'])) { y <- x[x[, 'cump']==p, c('x', 'y')] tspts <- .evenspace(y, interval, direction=TRUE) pts <- NULL for (i in 1:np) { pts1 <- .transect(tspts, i * pdist) pts <- cbind(pts, pts1) } allpts <- rbind(allpts, pts) } return(allpts) } else { x <- .pointsToMatrix(x) y <- .evenspace(x, interval, direction=TRUE) pts <- NULL for (i in 1:np) { pts1 <- .transect(y, i * pdist) pts <- rbind(pts, pts1) } return(pts) } } raster/R/dropLayer.R0000644000176200001440000000207414160021141014030 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("dropLayer")) { setGeneric("dropLayer", function(x, i, ...) standardGeneric("dropLayer")) } ...nameToIndex <- function(name, allnames) { # this is the same as match, I think k = NULL for (i in 1:length(name)) { k = c(k, which(allnames == name[i])[1]) } return(k) } setMethod('dropLayer', signature(x='RasterStack'), function(x, i, ...) { if (is.character(i)) { i = match(i, names(x)) } i <- sort(unique(round(i))) i <- i[i > 0 & i <= nlayers(x)] if (length(i) > 0) { x@layers <- x@layers[-i] } return(x) } ) setMethod('dropLayer', signature(x='RasterBrick'), function(x, i, ...) { if (is.character(i)) { i <- match(i, names(x)) } i <- sort(unique(round(i))) nl <- nlayers(x) i <- i[i > 0 & i <= nl] if (length(i) < 1) { return(x) } else { sel <- which(! 1:nl %in% i ) if (length(sel) == 0) { return(brick(x, values=FALSE)) } else { return(subset(x, sel, ...)) } } } ) raster/R/which.max.R0000644000176200001440000000437014160021141013756 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2013 # Version 1.0 # Licence GPL v3 setMethod("which.max", "RasterLayer", function(x) { m <- maxValue(x, warn=FALSE) if (is.na(m)) { return(NA) } if (canProcessInMemory(x)) { v <- values(x) return(which( v >= m)) } x <- x >= m - 0.00000001 pts <- rasterToPoints(x, function(y) y == 1) cellFromXY(x, pts[,1:2,drop=FALSE]) } ) setMethod("which.min", "RasterLayer", function(x) { m <- minValue(x, warn=FALSE) if (is.na(m)) { return(NA) } if (canProcessInMemory(x)) { v <- values(x) return(which( v <= m)) } xx <- x <= m + 0.000001 pts <- rasterToPoints(xx, function(y) y == 1) cellFromXY(xx, pts[,1:2,drop=FALSE]) } ) setMethod("which.min", "RasterStackBrick", function(x) { r <- raster(x) nl <- nlayers(x) if (canProcessInMemory(x)) { x <- values(x) i <- rowSums(is.na(x)) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, which.min) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) j <- rowSums(is.na(v)) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, which.min) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) setMethod("which.max", "RasterStackBrick", function(x) { r <- raster(x) nl <- nlayers(x) if (canProcessInMemory(x)) { x <- values(x) i <- rowSums(is.na(x)) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, which.max) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) j <- rowSums(is.na(v)) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, which.max) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) raster/R/RGB.R0000644000176200001440000000550014160021141012476 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 # partly based on functions in the pixmap package by Friedrich Leisch setMethod("RGB", signature(x='RasterLayer'), function(x, filename='', col=rainbow(25), breaks=NULL, alpha=FALSE, colNA='white',zlim=NULL, zlimcol=NULL, ext=NULL, ...) { getCols <- function(x, col, breaks=NULL, r=NULL, colNA=NA) { if (!is.null(breaks)) { breaks <- sort(breaks) x <- as.numeric(cut(x, breaks, include.lowest=TRUE)) } else { x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) } x <- col[x] if (!is.na(colNA)) { x[is.na(x)] <- grDevices::rgb(t(grDevices::col2rgb(colNA)), maxColorValue=255) } x } if (!is.null(ext)) { x <- crop(x, ext) } if (alpha) { out <- brick(x, nl=4, values=FALSE) } else { out <- brick(x, nl=3, values=FALSE) } names(out) <- c('red', 'green', 'blue', 'alpha')[1:nlayers(out)] if (canProcessInMemory(out)) { x <- getValues(x) if (is.logical(x)) { x <- as.integer(x) } x[is.infinite(x)] <- NA if (!is.null(zlim)) { if (!is.null(zlimcol)) { x[x < zlim[1]] <- zlim[1] x[x > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { x[x < zlim[1] | x > zlim[2]] <- NA } } w <- getOption('warn') options('warn'=-1) if (is.null(breaks)) { zrange <- range(x, zlim, na.rm=TRUE) } else { zrange <- range(x, zlim, breaks, na.rm=TRUE) } options('warn'=w) if (zrange[1] == zrange[2]) { zrange[1] <- zrange[1] - 0.001 zrange[2] <- zrange[2] + 0.001 } x <- getCols(x, col, breaks, zrange, colNA) x <- grDevices::col2rgb(x, alpha=alpha) out <- setValues(out, t(x)) if (filename != '') { out <- writeRaster(out, filename, datatype='INT2U', ...) } return(out) } else { r <- c(minValue(x), maxValue(x)) if (is.null(breaks)) { zrange <- range(r, zlim, na.rm=TRUE) } else { zrange <- range(r, zlim, breaks, na.rm=TRUE) } if (zrange[1] == zrange[2]) { zrange[1] <- zrange[1] - 0.001 zrange[2] <- zrange[2] + 0.001 } tr <- blockSize(out) pb <- pbCreate(tr$n, label='RGB', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (!is.null(zlim)) { if (!is.null(zlimcol)) { v[v < zlim[1]] <- zlim[1] v[v > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { v[v < zlim[1] | v > zlim[2]] <- NA } } v <- getCols(v, col, breaks, zrange, colNA) v <- grDevices::col2rgb(as.vector(v), alpha=alpha) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb) } pbClose(pb) return ( writeStop(out) ) } } ) #x = raster(nr=10, nc=10, vals=1:100) #y = RGB(x) #plotRGB(y) raster/R/stackQuick.R0000644000176200001440000000607514173042716014215 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2011 # Version 1.0 # Licence GPL v3 .quickStack <- function(files, nbands=1, band=1, native=FALSE) { r <- raster(files[[1]], native=native) if (length(nbands) == 1) { nbands <- rep(nbands, length(files)) } else { stopifnot(length(files == length(nbands))) } nbands <- as.integer(nbands) band <- as.integer(band) if (length(band) == 1) { band <- rep(band, length(files)) } else { stopifnot(length(files == length(band))) } r@data@haveminmax <- FALSE r@file@nbands <- nbands[1] r@data@band <- band[1] ln <- extension(basename(unlist(files)), '') s <- stack(r) s@layers <- sapply(1:length(files), function(i){ r@file@name <- files[[i]] r@file@nbands <- nbands[i] r@data@band <- band[i] r@data@names <- ln[i] r } ) s } .quickStackOneFile <- function(filename, bands=NULL, native=FALSE) { b <- brick(filename, native=native) .stackFromBrick(b, bands=bands) } .stackFromBrick <- function(b, bands=NULL) { nbands <- nlayers(b) if (is.null(bands)) { bands <- 1:nbands } else { if (is.character(bands)) { bands <- match(bands, names(b)) } bands <- bands[bands %in% 1:nbands] if (length(bands)==0) { bands <- 1:nbands } } bands <- as.integer(bands) havemnmx <- b@data@haveminmax if (havemnmx) { mn <- minValue(b) mx <- maxValue(b) } ln <- names(b) if (inMemory(b)) { r <- b[[ bands[1] ]] s <- stack(r) if (length(bands) > 1) { if (havemnmx) { s@layers <- sapply( bands, function(i) { r@data@values <- b@data@values[,i] r@data@names <- ln[i] r@data@min <- mn[i] r@data@max <- mx[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } else { s@layers <- sapply(bands, function(i){ r@data@values <- b@data@values[,i] r@data@names <- ln[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } } return(s) } r <- raster(b, bands[1]) s <- stack(r) if (length(bands) > 1) { if (havemnmx) { s@layers <- sapply(bands, function(i){ r@data@band <- i r@data@names <- ln[i] r@data@min <- mn[i] r@data@max <- mx[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } else { s@layers <- sapply(bands, function(i){ r@data@band <- i r@data@names <- ln[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } } s } raster/R/rasterFromCells.R0000644000176200001440000000127414160021141015177 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 rasterFromCells <- function(x, cells, values=TRUE) { x <- raster(x) u <- stats::na.omit(unique(cells)) # now removing NAs 2018-02-22 u <- u[ u > 0 & u <= ncell(x) ] if (length(u) == 0) { stop('no valid cells') } cols <- colFromCell(x, u) rows <- rowFromCell(x, u) res <- res(x) x1 <- xFromCol(x, min(cols)) - 0.5 * res[1] x2 <- xFromCol(x, max(cols)) + 0.5 * res[1] y1 <- yFromRow(x, max(rows)) - 0.5 * res[2] y2 <- yFromRow(x, min(rows)) + 0.5 * res[2] e <- extent(x1, x2, y1, y2) r <- crop(x, e) if (values) { r <- setValues(r, cellsFromExtent(x, e)) } return(r) } raster/R/zzz.R0000644000176200001440000000070714160021141012725 0ustar liggesusers loadModule("spmod", TRUE) #.onLoad <- function(lib, pkg) { # pkg.info <- utils::packageDescription('raster') # packageStartupMessage(paste("raster ", pkg.info[["Version"]], " (", pkg.info["Date"], ")", sep="")) # wd <- getwd() # options('startup.working.directory'=wd) # fn <- paste(wd, '/rasterOptions_', pkg.info[["Version"]], sep='') # .loadOptions(fn) # try( removeTmpFiles( .tmptime() ), silent=TRUE ) # return(invisible(0)) #} raster/R/clamp.R0000644000176200001440000000462314160021141013165 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2013 # Version 1.0 # Licence GPL v3 setMethod("clamp", signature(x="Raster"), function(x, lower=-Inf, upper=Inf, useValues=TRUE, filename="", ...) { if (!hasValues(x)) return(x) useValues <- as.integer(useValues) byCol = FALSE nl <- nlayers(x) if (nl == 1) { if ((length(lower) > 1) | (length(upper) > 1)) { warning("only the first element of lower/upper is used") lower <- lower[1] upper <- upper[1] } stopifnot(lower <= upper) out <- raster(x) crange <- c(lower, upper) } else { if ((length(lower) > 1) | (length(upper) > 1)) { lower = rep_len(lower, nl) upper = rep_len(upper, nl) stopifnot(all (lower <= upper) ) byCol = TRUE crange <- cbind(lower, upper) } else { stopifnot(lower <= upper) crange <- c(lower, upper) } out <- brick(x, values=FALSE) } names(out) <- names(x) if (byCol) { if (canProcessInMemory(out)) { v <- values(x) for (i in 1:ncol(v)) { v[,i] <- .clamp(v[,i], crange[i,], useValues) } out <- setValues(out, v) if (filename != "") { writeRaster(out, filename, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label="clamp", ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) for (j in 1:ncol(vals)) { vals[,j] <- .clamp(vals[,j], crange[j,], useValues) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } } else { if (canProcessInMemory(out)) { out <- setValues(out, .clamp(values(x), crange, useValues)) if (filename != "") { writeRaster(out, filename, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label="clamp", ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) vals <- .clamp(vals, crange, useValues) if (nl > 1) { vals <- matrix(vals, ncol=nl) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } } return(out) } ) setMethod("clamp", signature(x="numeric"), function(x, lower=-Inf, upper=Inf, ...) { stopifnot(lower <= upper) x[x < lower] <- lower x[x > upper] <- upper return(x) } ) raster/R/hdrBov.R0000644000176200001440000000210014160021141013301 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .writeHdrBOV <- function(raster) { hdrfile <- filename(raster) extension(hdrfile) <- '.bov' thefile <- file(hdrfile, "w") # open an txt file connectionis cat("TIME: 1.23456", "\n", file = thefile) datf <- filename(raster) extension(datf) <- '.gri' cat("DATA_FILE:", datf, "\n", file = thefile) cat("DATA_SIZE:", nrow(raster), ncol(raster), nlayers(raster), "\n", file = thefile) dtype <- substr(raster@file@datanotation, 1, 3) if (dtype == 'INT' | dtype == 'LOG' ) { pixtype <- "INT" } else { pixtype <- "FLOAT" } cat("DATA_FORMAT:", pixtype, "\n", file = thefile) cat("VARIABLE: ", basename(filename(raster)), "\n", file = thefile) cat("BYTEORDER ", toupper(.Platform$endian), "\n", file = thefile) cat("CENTERING: zonal", "\n", file = thefile) cat("BRICK_ORIGIN:", xmin(raster), ymin(raster), "0.", "\n", file = thefile) cat("BRICK_SIZE:", xres(raster), yres(raster), "1.", "\n", file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/stretch.R0000644000176200001440000000604414160021141013544 0ustar liggesusers# author Josh Gray # http://spatiallyexplicit.wordpress.com/2011/06/07/crop-circles/ # minor modifications by Robert Hijmans # Note: these functions only work (correctly) for single layer objects .linStretchVec <- function (x) { v <- stats::quantile(x, c(0.02, 0.98), na.rm = TRUE) temp <- (255 * (x - v[1]))/(v[2] - v[1]) temp[temp < 0] <- 0 temp[temp > 255] <- 255 return(temp) } .linStretch <- function (x) { v <- stats::quantile(x, c(0.02, 0.98), na.rm = TRUE) temp <- calc(x, fun = function(x) (255 * (x - v[1]))/(v[2] - v[1])) temp[temp < 0] <- 0 temp[temp > 255] <- 255 return(temp) } # Histogram equalization stretch .eqStretch <- function(x){ ecdfun <- stats::ecdf(getValues(x)) return( calc(x, fun=function(x) ecdfun(x)*255) ) } .eqStretchVec <- function(x){ ecdfun <- stats::ecdf(x) ecdfun(x)*255 } setMethod("stretch", signature(x="Raster"), function(x, minv=0, maxv=255, minq=0, maxq=1, smin=NA, smax=NA, samplesize=1000000, filename="", ...) { if ((length(minq) > 1) | (length(maxq) > 1)) { minq <- minq[1] maxq <- maxq[1] } stopifnot(maxq > minq) if ((length(minv) > 1) | (length(maxv) > 1)) { warning("only the first element of minv and maxv is used") maxv <- maxv[1] minv <- minv[1] } stopifnot(maxv > minv) if (!any(is.na(smin)) & !(any(is.na(smax)))) { stopifnot(all(smin < smax)) q <- cbind(smin, smax) } else { minq <- max(0,minq) maxq <- min(1,maxq) stopifnot(minq < maxq) if ((minq==0 & maxq==1) & .haveMinMax(x)) { q <- cbind(minValue(x), maxValue(x)) } else { if (samplesize[1] < ncell(x)) { stopifnot(samplesize[1] > 1) y <- sampleRegular(x, samplesize, asRaster=TRUE) q <- quantile(y, c(minq, maxq), na.rm=TRUE) } else { q <- quantile(x, c(minq, maxq), na.rm=TRUE) } } } if (nlayers(x) == 1) { out <- raster(x) mult <- maxv / (q[2]-q[1]) if (canProcessInMemory(out)) { x <- getValues(x) x <- mult * (x-q[1]) x[x < minv] <- minv x[x > maxv] <- maxv out <- setValues(out, x) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='stretch', ...) out <- writeStart(out, filename, ...) for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- mult*(v-q[1]) v[v < minv] <- minv v[v > maxv] <- maxv out <- writeValues(out, v, tr$row[i]) } out <- writeStop(out) } } else { out <- brick(x, values=FALSE) mult <- maxv / (q[,2]-q[,1]) if (canProcessInMemory(out)) { x <- getValues(x) x <- t(mult*(t(x)-q[,1])) x[x < minv] <- minv x[x > maxv] <- maxv out <- setValues(out, x) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='stretch', ...) out <- writeStart(out, filename, ...) for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- t(mult*(t(v)-q[,1])) v[v < minv] <- minv v[v > maxv] <- maxv out <- writeValues(out, v, tr$row[i]) } out <- writeStop(out) } } return(out) } ) raster/R/xyCell.R0000644000176200001440000001131014160021141013320 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 setMethod("yFromRow", signature(object="Raster", row="missing"), function(object, row) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } row=1:nrow(object) ymax(object) - ((row-0.5) * yres(object)) } ) setMethod("yFromRow", signature(object="Raster", row="numeric"), function(object, row) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } row <- round(as.vector(row)) row[row < 1 | row > object@nrows] <- NA ymax(object) - ((row-0.5) * yres(object)) } ) .yFromRow <- function(object, rownr) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } ymax(object) - ((rownr-0.5) * yres(object)) } setMethod("xFromCol", signature(object="Raster", col="numeric"), function(object, col=1:ncol(object)) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } col <- round(as.vector(col)) col[col < 1 | col > object@ncols] <- NA xmin(object) + (col - 0.5) * xres(object) } ) setMethod("xFromCol", signature(object="Raster", col="missing"), function(object, col=1:ncol(object)) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } col=1:ncol(object) xmin(object) + (col - 0.5) * xres(object) } ) .xFromCol <- function(object, colnr) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } xmin(object) + (colnr - 0.5) * xres(object) } setMethod("cellFromXY", signature(object="BasicRaster", xy="ANY"), function(object, xy) { if (inherits(xy, 'SpatialPoints')) { xy <- sp::coordinates(xy)[,1:2,drop=FALSE] x <- xy[,1] y <- xy[,2] } else if (is.null(dim(xy))) { x <- xy[1] y <- xy[2] } else { x <- xy[,1] y <- xy[,2] } if (rotated(object)) { cr <- object@rotation@transfun(xy, inv=TRUE) cell <- (cr[,2]-1) * object@ncols + cr[,1] } else { cell <- .doCellFromXY( object@ncols, object@nrows, object@extent@xmin, object@extent@xmax, object@extent@ymin, object@extent@ymax, x, y) } return(cell) } ) setMethod("colFromX", signature(object="BasicRaster", x="numeric"), function ( object, x ) { # from pre-generic # if (inherits(x, 'Spatial')) { # x <- x@coords[,1] # } if (rotated(object)) { stop('this function is not supported for rotated rasters') } colnr <- trunc((x - xmin(object)) / xres(object)) + 1 colnr[ x == xmax(object) ] <- object@ncols colnr[ x < xmin(object) | x > xmax(object) ] <- NA return(as.vector(colnr)) } ) setMethod("rowFromY", signature(object="BasicRaster", y="numeric"), function(object, y) { # from pre-generic # if (inherits(y, 'Spatial')) { # y <- y@coords[,2] # } if (rotated(object)) { stop('this function is not supported for rotated rasters') } rownr <- 1 + (trunc((ymax(object) - y) / yres(object))) rownr[y == ymin(object) ] <- object@nrows rownr[y > ymax(object) | y < ymin(object)] <- NA return(as.vector(rownr)) } ) setMethod("xyFromCell", signature(object="BasicRaster", cell="ANY"), function(object, cell, spatial=FALSE, ...) { if (rotated(object)) { xy <- object@rotation@transfun( cbind(x=colFromCell(object, cell), y=rowFromCell(object, cell)) ) } else { e <- object@extent xy <- .doXYFromCell( object@ncols, object@nrows, e@xmin, e@xmax, e@ymin, e@ymax, cell ) dimnames(xy) <- list(NULL, c("x", "y")) } if (spatial) { xy <- sp::SpatialPoints(stats::na.omit(xy), crs(object)) } return(xy) } ) if (!isGeneric("coordinates")) { setGeneric("coordinates", function(obj, ...) standardGeneric("coordinates")) } setMethod("coordinates", signature(obj="Raster"), function(obj, ...){ xyFromCell(obj, cell=1:ncell(obj), ...) } ) setMethod("coordinates", signature(obj="Extent"), function(obj, ...){ e <- as.vector(obj) rbind(cbind(e[1], e[3:4]), cbind(e[2], e[4:3])) } ) setMethod("yFromCell", signature(object="Raster",cell="numeric"), function(object, cell) { if (rotated(object)) { xy <- xyFromCell(object, cell) return(xy[,2]) } else { rows <- rowFromCell(object, cell) return( .yFromRow(object, rows) ) } } ) setMethod("xFromCell", signature(object="Raster",cell="numeric"), function(object, cell) { if (rotated(object)) { xy <- xyFromCell(object, cell) return(xy[,1]) } else { cols <- colFromCell(object, cell) return( .xFromCol(object, cols) ) } } ) raster/R/subset.R0000644000176200001440000000526414160021141013400 0ustar liggesusers# Authors: Robert J. Hijmans # Date : August 2009 # Version 1.0 # Licence GPL v3 setMethod('subset', signature(x='RasterStack'), function(x, subset, drop=TRUE, filename='', ...) { if (is.character(subset)) { i <- stats::na.omit(match(subset, names(x))) if (length(i)==0) { stop('invalid layer names') } else if (length(i) < length(subset)) { warning('invalid layer names omitted') } subset <- i } subset <- as.integer(subset) if (! all(subset %in% 1:nlayers(x))) { stop('not a valid subset') } if (length(x@z) > 0) { z <- lapply(x@z, function(x) x[subset]) } else { z <- list() } if (length(subset) == 1 & drop) { x <- x@layers[[subset]] } else { x@layers <- x@layers[subset] } x@z <- z if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } ) setMethod('subset', signature(x='Raster'), function(x, subset, drop=TRUE, filename='', ...) { if (is.character(subset)) { i <- stats::na.omit(match(subset, names(x))) if (length(i)==0) { stop('invalid layer names') } else if (length(i) < length(subset)) { warning('invalid layer names omitted') } subset <- i } subset <- as.integer(subset) nl <- nlayers(x) if (! all(subset %in% 1:nl)) { stop('not a valid subset') } # now _after_ checking for valid names and adding the possibility to # subset a RasterLayer multiple times. Fixed/suggested by Benjamin Leutner if (inherits(x, 'RasterLayer')) { if (length(subset) > 1) { x <- stack(lapply(subset, function(...) x)) } if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } nav <- NAvalue(x) e <- extent(x) if (length(x@z)>0) { z <- lapply(x@z, function(x) x[subset]) } else { z <- list() } if (fromDisk(x)) { nms <- names(x) if (drop & length(subset)==1) { x <- raster(x, subset) } else { x <- stack(x, layers=subset) } extent(x) <- e names(x) <- nms[subset] NAvalue(x) <- nav } else { if (drop & length(subset)==1) { if (hasValues(x)) { x <- raster(x, subset) } else { x <- raster(x) } x@z <- z extent(x) <- e NAvalue(x) <- nav return(x) } if (hasValues(x)) { x@data@values <- x@data@values[, subset, drop=FALSE] x@data@min <- x@data@min[subset] x@data@max <- x@data@max[subset] } x@data@names <- x@data@names[subset] x@z <- z x@data@nlayers <- as.integer(length(subset)) f <- is.factor(x) if (any(f)) { x@data@attributes <- x@data@attributes[subset] x@data@isfactor <- x@data@isfactor[subset] } } if (filename != '') { x <- writeRaster(x, filename, ...) } x } ) raster/R/setExtent.R0000644000176200001440000000264614160021141014057 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 'extent<-' <- function(x, value) { return(setExtent(x, value)) } setExtent <- function(x, ext, keepres=FALSE, snap=FALSE) { # oldbb <- extent(x) bb <- extent(ext) if (snap) { bb <- alignExtent(bb, x) } if (inherits(x, 'RasterStack')) { if (keepres) { stop('you cannot use keepres=TRUE with a RasterStack') } x@extent <- bb if (nlayers(x) > 0) { for (i in 1:nlayers(x)) { x@layers[[i]]@extent <- bb } } return(x) } if (keepres) { newobj <- clearValues(x) xrs <- xres(newobj) yrs <- yres(newobj) newobj@extent <- bb nc <- as.integer(round( (newobj@extent@xmax - newobj@extent@xmin) / xrs )) if (nc < 1) { stop( "xmin and xmax are less than one cell apart" ) } else { newobj@ncols <- nc } nr <- as.integer(round( (newobj@extent@ymax - newobj@extent@ymin) / yrs ) ) if (nr < 1) { stop( "ymin and ymax are less than one cell apart" ) } else { newobj@nrows <- nr } newobj@extent@xmax <- newobj@extent@xmin + newobj@ncols * xrs newobj@extent@ymax <- newobj@extent@ymin + newobj@nrows * yrs if ((x@ncols == newobj@ncols) & (x@nrows == newobj@nrows)) { x@extent <- newobj@extent return(x) } else { return(newobj) } } else if (class(x) != "BasicRaster") { x@extent <- bb return(x) } } raster/R/aggregate_sp.R0000644000176200001440000001463614160021141014526 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 .getVars <- function(v, cn, nc) { vl <- length(v) v <- unique(v) if (is.numeric(v)) { v <- round(v) v <- v[v>0 & v <= nc] if (length(v) < 1) { stop('invalid column numbers') } } else if (is.character(v)) { v <- v[v %in% cn] if (length(v) < 1) { stop('invalid column names') } } v } .doSums <- function(sums, cn, dc, x) { out <- list() for (i in 1:length(sums)) { if (length(sums[[i]]) != 2) { stop('argument "s" most of be list in which each element is a list of two (fun + varnames)') } fun = sums[[i]][[1]] if (!is.function(fun)) { if (is.character(fun)) { if (tolower(fun[1]) == 'first') { fun <- function(x) x[1] } else if (tolower(fun[1]) == 'last') { fun <- function(x) x[length(x)] } } } v <- .getVars(sums[[i]][[2]], cn, ncol(x@data)) ag <- aggregate(x@data[,v,drop=FALSE], by=list(dc$v), FUN=fun) out[[i]] <- ag[,-1,drop=FALSE] } do.call(cbind, out) } setMethod('aggregate', signature(x='SpatialPolygons'), function(x, by=NULL, sums=NULL, dissolve=TRUE, vars=NULL, ...) { if (!is.null(vars)) { if (is.null(by)) { by <- vars } else { stop('do not provide "by" and "vars" arguments') } warning('Use argument "by" instead of deprecated argument "vars"') } if (!is.null(by)) { if (!is.character(by)) { # sp::aggregate is not exported # solution by Matt Strimas-Mackey spAgg <- get('aggregate', envir=as.environment("package:sp")) return( spAgg(x, by, ..., dissolve=dissolve) ) } } if (dissolve) { if (!requireNamespace("rgeos")) { warning('Cannot dissolve because the rgeos package is not available') dissolve <- FALSE } } if (!.hasSlot(x, 'data') ) { hd <- FALSE if (!is.null(by)) { if (length(by) == length(x@polygons)) { x <- sp::SpatialPolygonsDataFrame(x, data=data.frame(ID=by)) by <- 1 } else if (is.character(by)) { stop('character argument for by not understood. It is not length(x) and x has no attributes') } } } else { hd <- TRUE } if (isTRUE(is.null(by))) { if (dissolve) { gval <- rgeos::get_RGEOS_CheckValidity() if (gval != 2) { on.exit(rgeos::set_RGEOS_CheckValidity(gval)) rgeos::set_RGEOS_CheckValidity(2L) } if (rgeos::version_GEOS() < "3.3.0") { x <- rgeos::gUnionCascaded(x) } else { x <- rgeos::gUnaryUnion(x) } } else { p <- list() for (i in 1:length(x)) { nsubobs <- length(x@polygons[[i]]@Polygons) p <- c(p, lapply(1:nsubobs, function(j) x@polygons[[i]]@Polygons[[j]])) } x <- sp::SpatialPolygons(list(sp::Polygons(p, '1')), proj4string=x@proj4string) } #if (hd) { # x <- sp::SpatialPolygonsDataFrame(x, data=data.frame(ID=1)) #} return(x) } else { dat <- x@data cn <- colnames(dat) v <- .getVars(by, cn) dat <- dat[,v, drop=FALSE] crs <- x@proj4string dc <- apply(dat, 1, function(y) paste(as.character(y), collapse='_')) dc <- data.frame(oid=1:length(dc), v=as.integer(as.factor(dc))) id <- dc[!duplicated(dc$v), , drop=FALSE] if (nrow(id) == nrow(dat)) { # nothing to aggregate if (hd) { x@data <- dat } else { x <- as(x, 'SpatialPolygons') } return(x) } id <- id[order(id$v), ] dat <- dat[id[,1], ,drop=FALSE] if (!is.null(sums)) { out <- .doSums(sums, cn, dc, x) dat <- cbind(dat, out) } if (hd) { x <- as(x, 'SpatialPolygons') } if (dissolve) { if (rgeos::version_GEOS0() < "3.3.0") { x <- lapply(1:nrow(id), function(y) sp::spChFIDs(rgeos::gUnionCascaded(x[dc[dc$v==y,1],]), as.character(y))) } else { x <- lapply(1:nrow(id), function(y) { z <- x[dc[dc$v==y, 1], ] z <- try( rgeos::gUnaryUnion(z) ) if (! inherits(z, "try-error")) { sp::spChFIDs(z, as.character(y)) } } ) } } else { #x <- lapply(1:nrow(id), function(y) { #spChFIDs(aggregate(x[dc[dc$v==y,1],], dissolve=FALSE), as.character(y))) x <- lapply(1:nrow(id), function(y) { d <- data.frame(geom(x[dc[dc$v==y,1],])) pmx = tapply(d[,"part"], d[,"object"], max) z <- as.vector(cumsum(pmx) - 1) d$part <- z[d$object] + d$part d$object <- y d <- as(d, "SpatialPolygons") sp::spChFIDs(d, as.character(y)) }) } x <- do.call(rbind, x) x@proj4string <- crs rownames(dat) <- NULL sp::SpatialPolygonsDataFrame(x, dat, FALSE) } } ) setMethod('aggregate', signature(x='SpatialLines'), function(x, by=NULL, sums=NULL, ...) { if (!is.null(by)) { if (!is.character(by)) { # sp::aggregate is not exported # solution by Matt Strimas-Mackey spAgg <- get('aggregate', envir=as.environment("package:sp")) return( spAgg(x, by, ...) ) } } if (!.hasSlot(x, 'data') ) { hd <- FALSE if (!is.null(by)) { if (length(by) == length(x@lines)) { x <- sp::SpatialLinesDataFrame(x, data=data.frame(ID=by)) by <- 1 } else if (is.character(by)) { stop('character argument for by not understood. It is not length(x) and x has no attributes') } } } else { hd <- TRUE } if (isTRUE(is.null(by))) { p <- list() for (i in 1:length(x)) { nsubobs <- length(x@lines[[i]]@Lines) p <- c(p, lapply(1:nsubobs, function(j) x@lines[[i]]@Lines[[j]])) } x <- sp::SpatialLines(list(sp::Lines(p, '1')), proj4string=crs(x)) return(x) } else { dat <- x@data cn <- colnames(dat) v <- .getVars(by, cn) dat <- dat[,v, drop=FALSE] crs <- x@proj4string dc <- apply(dat, 1, function(y) paste(as.character(y), collapse='_')) dc <- data.frame(oid=1:length(dc), v=as.integer(as.factor(dc))) id <- dc[!duplicated(dc$v), , drop=FALSE] if (nrow(id) == nrow(dat)) { # nothing to aggregate if (hd) { x@data <- dat } else { x <- as(x, 'SpatialLines') } return(x) } id <- id[order(id$v), ] dat <- dat[id[,1], ,drop=FALSE] if (!is.null(sums)) { out <- .doSums(sums, cn, dc, x) dat <- cbind(dat, out) } if (hd) { x <- as(x, 'SpatialLines') } x <- lapply(1:nrow(id), function(y) sp::spChFIDs(aggregate(x[dc[dc$v==y,1],]), as.character(y))) x <- do.call(rbind, x) crs(x) <- crs rownames(dat) <- NULL sp::SpatialLinesDataFrame(x, dat, FALSE) } } ) raster/R/range.R0000644000176200001440000000324314160021141013162 0ustar liggesusers# Authors: Robert J. Hijmans # Date : May 2012 # Version 1.0 # Licence GPL v3 .range <- function(x, ..., na.rm=FALSE) { dots <- list(...) if (length(dots) > 0) { d <- sapply(dots, function(i) inherits(i, 'Raster')) if (any(d)) { x <- .makeRasterList(x, dots[d]) if (length(x) > 1) { x <- stack(x) } else { x <- x[[1]] } } add <- .addArgs(unlist(dots[!d])) } else { add <- NULL } if (nlayers(x)==1 & length(add)==0) { warning('Cannot compute a range from a single RasterLayer; see cellStats') return(x) } out <- raster(x) out <- brick(out, nl=2, values=FALSE) names(out) <- c('range_min', 'range_max') if (canProcessInMemory(x)) { if (!is.null(add)) { add <- range(add, na.rm=na.rm) x <- cbind(getValues(x), add[1], add[2]) } else { x <- getValues(x) } x <- apply(x, 1, range, na.rm=na.rm) out <- setValues(out, t(x)) return(out) } tr <- blockSize(x) out <- writeStart(out, filename="") pb <- pbCreate(tr$n, label='range',) if (!is.null(add)) { add <- range(add) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- cbind(v, add[1], add[2]) v <- apply(v, 1, FUN=range, na.rm=na.rm) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- apply(v, 1, FUN=range, na.rm=na.rm) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) names(out) <- c('range_min', 'range_max') out } raster/R/maxDataType.R0000644000176200001440000000044314160021141014306 0ustar liggesusers .maxDatatype <- function(x) { x <- sort(x) x <- x[substr(x, 1, 3)== substr(x[1], 1, 3)] size <- max(as.integer(substr(x, 4, 4))) if (substr(x[1], 1, 3) == 'FLT') { return( paste('FLT', size, 'S', sep="") ) } else { # need to do better than this return( 'INT4S' ) } }raster/R/setMinMax.R0000644000176200001440000000516414160021141013777 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('setMinMax', signature(x='RasterLayer'), function(x, ...) { #w <- getOption('warn') #on.exit(options('warn' = w)) #options('warn'=-1) if ( inMemory(x) ) { suppressWarnings(x@data@min <- min(x@data@values, na.rm=TRUE)) suppressWarnings(x@data@max <- max(x@data@values, na.rm=TRUE)) } else { if (! fromDisk(x)) { stop('no values associated with this RasterLayer') } x@data@min <- Inf x@data@max <- -Inf tr <- blockSize(x) pb <- pbCreate(tr$n) x <- readStart(x) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) x@data@min <- suppressWarnings(min(x@data@min, min(v, na.rm=TRUE))) x@data@max <- suppressWarnings(max(x@data@max, max(v, na.rm=TRUE))) } x <- readStop(x) } # if (datatype == 'logical') { # x@data@min <- as.logical(x@data@min) # x@data@max <- as.logical(x@data@max) # } x@data@haveminmax <- TRUE return(x) } ) setMethod('setMinMax', signature(x='RasterBrick'), function(x, ...) { inMem <- inMemory(x) if ( ! inMem ) { if (! fromDisk(x) ) { stop('no values associated with this RasterBrick') } } else if (canProcessInMemory(x, (2 + nlayers(x)))) { inMem <- TRUE } w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) if ( inMem ) { rge <- apply( getValues(x), 2, FUN=function(x){ c(min(x, na.rm=TRUE), max(x, na.rm=TRUE)) } ) x@data@min <- as.vector(rge[1,]) x@data@max <- as.vector(rge[2,]) } else { minv <- rep(Inf, nlayers(x)) maxv <- rep(-Inf, nlayers(x)) minmax <- rbind(minv, maxv) tr <- blockSize(x) x <- readStart(x) for (i in 1:tr$n) { rsd <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) minmax[1,] <- apply(rbind(rsd, minmax[1,]), 2, min, na.rm=TRUE) minmax[2,] <- apply(rbind(rsd, minmax[2,]), 2, max, na.rm=TRUE) } x@data@min <- minmax[1,] x@data@max <- minmax[2,] x <- readStop(x) } # if (datatype == 'logical') { # x@data@min <- as.logical(x@data@min) # x@data@max <- as.logical(x@data@max) # } x@data@haveminmax <- TRUE return(x) } ) setMethod('setMinMax', signature(x='RasterStack'), function(x, ...) { for (i in 1:nlayers(x)) { x@layers[[i]] <- setMinMax(x@layers[[i]]) } return(x) } ) .haveMinMax <- function(x) { if (inherits(x, "RasterLayer") || inherits(x, "RasterBrick")) { return(x@data@haveminmax) } else if (inherits(x, "RasterStack")) { return(all(sapply(x@layers, function(y) y@data@haveminmax))) } else { return(FALSE) } } raster/R/kml.R0000644000176200001440000000621414160021141012652 0ustar liggesusers# Derived, with only minor changes, from functions GE_SpatialGrid and kml Overlay # in the maptools package. These were written by Duncan Golicher, David Forrest and Roger Bivand # Adaptation for the raster packcage by Robert J. Hijmans, # Date : March 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("KML")) { setGeneric("KML", function(x, ...) standardGeneric("KML")) } setMethod('KML', signature(x='Spatial'), function (x, filename, zip='', overwrite=FALSE, ...) { .requireRgdal() if (! is.na(projection(x))) { if (! isLonLat(x) ) { warning('transforming data to longitude/latitude') sp::spTransform(x, sp::CRS('+proj=longlat +datum=WGS84')) } } if (!.hasSlot(x, 'data') ) { x <- sp::addAttrToGeom(x, data.frame(id=1:length(x)), match.ID=FALSE) } extension(filename) <- '.kml' if (file.exists(filename)) { if (overwrite) { file.remove(filename) } else { stop('file exists, use "overwrite=TRUE" to overwrite it') } } name <- list(...)$name if (is.null(name)) { name <- deparse(substitute(x)) } rgdal::writeOGR(x, filename, name, 'KML', ...) .zipKML(filename, '', zip, overwrite=overwrite) } ) setMethod('KML', signature(x='RasterLayer'), function (x, filename, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) { if (! couldBeLonLat(x)) { stop("CRS of x must be longitude / latitude") } if (nlayers(x) > 1) { x <- x[[1]] } stopifnot(hasValues(x)) if (missing(filename)) { filename <- extension(basename(rasterTmpFile('G_')), '.kml') } x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE) imagefile <- filename extension(imagefile) <- '.png' kmlfile <- kmzfile <- filename extension(kmlfile) <- '.kml' if (file.exists(kmlfile)) { if (overwrite) { file.remove(kmlfile) } else { stop('kml file exists, use "overwrite=TRUE" to overwrite it') } } grDevices::png(filename = imagefile, width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg="transparent") if (!is.na(colNA)) { graphics::par(mar=c(0,0,0,0), bg=colNA) } else { graphics::par(mar=c(0,0,0,0)) } image(x, col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...) grDevices::dev.off() name <- names(x)[1] if (name == "") { name <- 'x' } kml <- c('', '', "") kmname <- paste("", name, "", sep = "") icon <- paste("", basename(imagefile), "0.75", sep = "") e <- extent(x) latlonbox <- c("\t", paste("\t\t", e@ymax, "", e@ymin, "", e@xmax, "", e@xmin, "", sep = ""), "\t") footer <- "" kml <- c(kml, kmname, icon, latlonbox, footer) f <- file(kmlfile, 'wt', encoding='UTF-8') cat(paste(kml, sep="", collapse="\n"), file=f, sep="") close(f) .zipKML(kmlfile, imagefile, zip, overwrite=overwrite) } ) raster/R/interpolate.R0000644000176200001440000001204114160021141014410 0ustar liggesusers # to do: should allow index to be a vector setMethod('interpolate', signature(object='Raster'), function(object, model, filename="", fun=predict, xyOnly=TRUE, xyNames=c('x','y'), ext=NULL, const=NULL, index=1, na.rm=TRUE, debug.level=1, ...) { predrast <- raster(object) filename <- trim(filename) ln <- NULL if (!is.null(ext)) { predrast <- crop(predrast, extent(ext)) firstrow <- rowFromY(object, yFromRow(predrast, 1)) firstcol <- colFromX(object, xFromCol(predrast, 1)) } else { firstrow <- 1 firstcol <- 1 } ncols <- ncol(predrast) lyrnames <- names(object) haveFactor <- FALSE dataclasses <- try( attr(model$terms, "dataClasses")[-1], silent=TRUE) if (!is.null(dataclasses)) { varnames <- names(dataclasses) if (! inherits(dataclasses, "try-error")) { if ( length( unique(lyrnames[(lyrnames %in% varnames)] )) != length(lyrnames[(lyrnames %in% varnames)] )) { stop('duplicate names in Raster* object: ', lyrnames) } f <- names( which(dataclasses == 'factor') ) if (length(f) > 0) { haveFactor <- TRUE } } } if (!canProcessInMemory(predrast) && filename == '') { filename <- rasterTmpFile() } if (! xyOnly) { if (inherits(object, 'RasterStack')) { if (nlayers(object)==0) { warning('"object" has no data, xyOnly set to TRUE') xyOnly <- TRUE } } else { if ( ! fromDisk(object) ) { if (! inMemory(object) ) { warning('"object" has no data, xyOnly set to TRUE') xyOnly <- TRUE } } } } if (xyOnly) { na.rm <- FALSE } if (inherits(model, "gstat")) { gstatmod <- TRUE if (!is.null(model$locations) && inherits(model$locations, "formula")) { # should be ~x + y ; need to check if it is ~lon + lat; or worse ~y+x sp <- FALSE } else { sp <- TRUE } } else { gstatmod <- FALSE } tr <- blockSize(predrast, n=nlayers(object)+3) ablock <- 1:(ncol(predrast) * tr$nrows[1]) napred <- rep(NA, ncol(predrast)*tr$nrows[1]) pb <- pbCreate(tr$n, label='interpolate', ... ) if (filename == '') { v <- matrix(NA, ncol=nrow(predrast), nrow=ncol(predrast)) } else { predrast <- writeStart(predrast, filename=filename, ... ) } for (i in 1:tr$n) { if (i==tr$n) { ablock <- 1:(ncol(predrast) * tr$nrows[i]) napred <- rep(NA, ncol(predrast) * tr$nrows[i]) } rr <- firstrow + tr$row[i] - 1 if (xyOnly) { p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) p <- stats::na.omit(p) blockvals <- data.frame(x=p[,1], y=p[,2]) } else { blockvals <- data.frame(getValuesBlock(object, row=rr, nrows=tr$nrows[i], firstcol, ncols)) colnames(blockvals) <- lyrnames # necessary if there is only one layer p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) blockvals <- cbind(data.frame( x=p[,1], y=p[,2]), blockvals) } if (!is.null(const)) { blockvals <- cbind(blockvals, const) } if (haveFactor) { for (j in 1:length(f)) { blockvals[,f[j]] <- as.factor(blockvals[,f[j]]) } } colnames(blockvals)[1:2] <- xyNames[1:2] if (gstatmod) { if (sp) { row.names(p) <- 1:nrow(p) blockvals <- sp::SpatialPointsDataFrame(coords=p, data = blockvals, proj4string=.getCRS((predrast))) } if (i == 1) { predv <- predict(model, blockvals, debug.level=debug.level, ...) ln <- names(predv)[index] } else { predv <- predict(model, blockvals, debug.level=0, ...) } if (sp) { predv <- predv@data[,index] } else { predv <- predv[,index+2] } } else { if (na.rm) { blockvals <- stats::na.omit(blockvals) } if (nrow(blockvals) == 0 ) { predv <- napred } else { predv <- fun(model, blockvals, ...) } if (class(predv)[1] == 'list') { predv <- unlist(predv, use.names = FALSE) if (length(predv) != nrow(blockvals)) { predv <- matrix(predv, nrow=nrow(blockvals)) } } if (isTRUE(dim(predv)[2] > 1)) { predv = predv[,index] } if (na.rm) { naind <- as.vector(attr(blockvals, "na.action")) if (!is.null(naind)) { p <- napred p[-naind] <- predv predv <- p rm(p) } } # to change factor to numeric; should keep track of this to return a factor type RasterLayer predv <- as.numeric(predv) } if (filename == '') { predv = matrix(predv, nrow=ncol(predrast)) cols = tr$row[i]:(tr$row[i]+dim(predv)[2]-1) v[,cols] <- predv } else { predrast <- writeValues(predrast, predv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (gstatmod) { names(predrast) <- ln } if (filename == '') { predrast <- setValues(predrast, as.numeric(v)) # or as.vector } else { predrast <- writeStop(predrast) } return(predrast) } ) raster/R/netCDFutil.R0000644000176200001440000001101414160021141014062 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .getCRSfromGridMap4 <- function(g) { sp <- g$standard_parallel if (length(sp) > 1) { g$standard_parallel1 <- sp[1] g$standard_parallel2 <- sp[2] g$standard_parallel <- NULL } vals <- sapply(g, function(i) i[1]) vars <- names(vals) if (any(vars == "epsg_code")) { crs <- vals[vars=="epsg_code"] crs <- paste0("+init=epsg:", crs) return(crs) } else if (any(vars %in% c("proj4", "crs_wkt", "spatial_ref"))) { crs=vals[vars %in% c("proj4", "crs_wkt", "spatial_ref")][1] return(crs) } # based on info at # http://trac.osgeo.org/gdal/wiki/NetCDF_ProjectionTestingStatus # accessed 7 October 2012 prj <- matrix(c("albers_conical_equal_area", "aea", "azimuthal_equidistant", "aeqd", "lambert_cylindrical_equal_area", "cea", "lambert_azimuthal_equal_area", "laea", "lambert_conformal_conic", "lcc", "latitude_longitude", "longlat", "mercator", "merc", "orthographic", "ortho", "polar_stereographic", "stere", "stereographic", "stere", "transverse_mercator", "tmerc"), ncol=2, byrow=TRUE) m <- matrix(c("grid_mapping_name", "+proj", "false_easting", "+x_0","false_northing", "+y_0", "scale_factor_at_projection_origin", "+k_0", "scale_factor_at_central_meridian", "+k_0", "standard_parallel", "+lat_1", "standard_parallel1", "+lat_1", "standard_parallel2", "+lat_2", "longitude_of_central_meridian", "+lon_0", "longitude_of_projection_origin", "+lon_0", "latitude_of_projection_origin", "+lat_0", "straight_vertical_longitude_from_pole", "+lon_0", "longitude_of_prime_meridian", "+pm", "semi_major_axis", "+a", "semi_minor_axis", "+b", "inverse_flattening", "+rf", "earth_radius", "+a"), ncol=2, byrow=TRUE) # add logic that if prime merid is defined but not centr merid. centr merid is same as prime. i <- match(vars, m[,1]) if (all(is.na(i))) { gg <- cbind(vars, vals) mtxt <- paste(apply(gg, 1, function(x) paste(x, collapse='=')), collapse='; ') warning("cannot process the crs\n", mtxt) return(NA) } else if (any(is.na(i))) { vr <- vars[is.na(i)] vl <- vals[is.na(i)] gg <- cbind(vr, vl) gg <- gg[!(gg[,1] %in% c("crs_wkt", "esri_pe_string")), ,drop=FALSE] if (NROW(gg) > 0) { mtxt <- paste(apply(gg, 1, function(x) paste(x, collapse='=')), collapse='\n') warning("cannot process these parts of the crs:\n", mtxt) } vars <- vars[!is.na(i)] vals <- vals[!is.na(i)] i <- stats::na.omit(i) } tab <- cbind(m[i,], vals) rr <- which(tab[,1] == "earth_radius") if (length(rr) > 0) { bb <- tab[rr,] bb[2] <- "+b" tab <- rbind(tab, bb) } p <- which(tab[,2] == '+proj') if (length(p) == 0) { warning("cannot create a valid crs\n", mtxt) return(NA) } else { tab <- rbind(tab[p, ], tab[-p, ]) } j <- match(tab[1,3], prj[,1]) tab[1,3] <- prj[j,2] cr <- paste(apply(tab[,2:3], 1, function(x) paste(x, collapse='=')), collapse=' ') crtst <- try(sp::CRS(cr), silent=TRUE) if ( inherits(crtst, "try-error")) { mtxt <- paste(m, collapse='; ') warning("cannot create a valid crs\n", mtxt) return(NA) } else { return(cr) } } .isNetCDF <- function(x) { fcon <- file(x, "rb") suppressWarnings( tst <- try( w <- readBin(fcon, what='character', n=1), silent=TRUE) ) close(fcon) if ( isTRUE((substr(w, 1, 3) == "CDF" ))) { return(TRUE) } else { return(FALSE) } } .getRasterDTypeFromCDF <- function(type) { if (type == "char" ) { return("INT1U") } else if (type == "byte" ) { return("INT1S") } else if (type == "short" ) { return("INT2S") } else if (type == "int" ) { return("INT4S") } else if (type == "integer" ) { return("INT4S") } else if (type == "float" ) { return("FLT4S") } else if (type =="double" ) { return("FLT8S") } else { return("FLT4S") } } .getNetCDFDType <- function(dtype) { if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S'))) { stop('not a valid data type') } type <- .shortDataType(dtype) size <- dataSize(dtype) * 8 signed <- dataSigned(dtype) if (size == 8) { if (!signed) { return("char") #8-bit characters intended for representing text. } else { return("byte") } } else if (type == 'INT') { if (!signed) { warning('netcdf only stores signed integers') } if (size == 16) { return( "short" ) } else if (size == 32 ) { return( "integer" ) } else { return ( "double" ) } } else { if (size == 32) { return( "float" ) } else { return ( "double" ) } } } raster/R/xyValuesBuffer.R0000644000176200001440000001452214160021141015042 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .xyvBuf <- function(object, xy, buffer, fun=NULL, na.rm=TRUE, layer, nl, cellnumbers=FALSE, small=FALSE, onlycells=FALSE) { buffer <- abs(buffer) if (length(buffer == 1)) { buffer <- rep(buffer, times=nrow(xy)) } else if (length(buffer) != nrow(xy) | ! is.vector(buffer) ) { stop('buffer should be a single value or a vector of length==nrow(xy)') } buffer[is.na(buffer)] <- 0 if (onlycells) { cellnumbers <- TRUE fun <- NULL small <- TRUE object <- raster(object) } else if (! is.null(fun)) { cellnumbers <- FALSE } cv <- list() obj <- raster(object) # ? centralcells <- cellFromXY(obj, xy) # needs to deal with global wrapping.... if (couldBeLonLat(obj)) { # from m to degrees bufy <- buffer / 111319.5 ymx <- pmin(90, xy[,2] + bufy) ymn <- pmax(-90, xy[,2] - bufy) bufx1 <- buffer / pointDistance(cbind(0, ymx), cbind(1, ymx), lonlat=TRUE) bufx2 <- buffer / pointDistance(cbind(0, ymn), cbind(1, ymn), lonlat=TRUE) bufx <- pmax(bufx1, bufx2) cn <- colFromX(obj, xy[,1]-bufx) cx <- colFromX(obj, xy[,1]+bufx) cn[is.na(cn) & (xy[,1]-bufx <= xmin(obj) & xy[,1]+bufx >= xmin(obj))] <- 1 cx[is.na(cx) & (xy[,1]-bufx <= xmax(obj) & xy[,1]+bufx > xmax(obj))] <- ncol(obj) rn <- rowFromY(obj, xy[,2]+bufy) rx <- rowFromY(obj, xy[,2]-bufy) rn[is.na(rn) & (xy[,2]-bufy <= ymax(obj) & xy[,2]+bufy >= ymax(obj))] <- 1 rx[is.na(rx) & (xy[,2]-bufy <= ymin(obj) & xy[,2]+bufy >= ymin(obj))] <- nrow(obj) for (i in 1:nrow(xy)) { s <- sum(rn[i], rx[i], cn[i], cx[i]) if (is.na(s)) { cv[[i]] <- NA } else { if (onlycells) { value <- i } else { value <- getValuesBlock(object, rn[i], rx[i]-rn[i]+1, cn[i], cx[i]-cn[i]+1) } cell <- cellFromRowColCombine(obj, rn[i]:rx[i], cn[i]:cx[i]) coords <- xyFromCell(obj, cell) if (cellnumbers) { pd <- cbind(pointDistance(xy[i,], coords, lonlat=TRUE), cell, value) } else { pd <- cbind(pointDistance(xy[i,], coords, lonlat=TRUE), value) } if (nrow(pd) > 1) { v <- pd[pd[,1] <= buffer[i], -1] if (NROW(v) == 0) { cv[[i]] <- pd[which.min(pd[,1]), -1] } else { cv[[i]] <- v } } else { cv[[i]] <- pd[,-1] } } } } else { cn <- colFromX(obj, xy[,1]-buffer) cx <- colFromX(obj, xy[,1]+buffer) cn[is.na(cn) & (xy[,1]-buffer <= xmin(obj) & xy[,1]+buffer >= xmin(obj))] <- 1 cx[is.na(cx) & (xy[,1]-buffer <= xmax(obj) & xy[,1]+buffer > xmax(obj))] <- ncol(obj) rn <- rowFromY(obj, xy[,2]+buffer) rx <- rowFromY(obj, xy[,2]-buffer) rn[is.na(rn) & (xy[,2]-buffer <= ymax(obj) & xy[,2]+buffer >= ymax(obj))] <- 1 rx[is.na(rx) & (xy[,2]-buffer <= ymin(obj) & xy[,2]+buffer >= ymin(obj))] <- nrow(obj) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nrow(xy), length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() parallel::clusterExport(cl, c('object', 'obj', 'cellnumbers'), envir=environment()) clFun2 <- function(i, xy, rn, rx, cn, cx) { s <- sum(rn, rx, cn, cx) if (is.na(s)) { return(NA) } else { if (onlycells) { value <- i } else { value <- getValuesBlock(object, rn, rx-rn+1, cn, cx-cn+1) } cell <- cellFromRowColCombine(obj, rn:rx, cn:cx) coords <- xyFromCell(obj, cell) if (cellnumbers) { pd <- cbind(pointDistance(xy, coords, lonlat=TRUE), cell, value) } else { pd <- cbind(pointDistance(xy, coords, lonlat=TRUE), value) } if (nrow(pd) > 1) { pd <- pd[pd[,1] <= buffer[i], -1] } else { pd <- pd[,-1] } return(pd) } } .sendCall <- eval( parse( text="parallel:::sendCall") ) for (i in 1:nodes) { .sendCall(cl[[i]], clFun2, list(i, xy[i, ,drop=FALSE], rn[i], rx[i], cn[i], cx[i]), tag=i) } for (i in 1:nrow(xy)) { d <- .recvOneData(cl) if (! d$value$success) { print(d) stop('cluster error') } else { cv[[i]] <- d$value$value } ni <- nodes + i if (ni <= nrow(xy)) { .sendCall(cl[[d$node]], clFun2, list(ni, xy[i, ,drop=FALSE], rn[i], rx[i], cn[i], cx[i]), tag=i) } } } else { for (i in 1:nrow(xy)) { s <- sum(rn[i], rx[i], cn[i], cx[i]) if (is.na(s)) { cv[[i]] <- NA } else { if (onlycells) { value <- i } else { value <- getValuesBlock(object, rn[i], rx[i]-rn[i]+1, cn[i], cx[i]-cn[i]+1) } cell <- cellFromRowColCombine(obj, rn[i]:rx[i], cn[i]:cx[i]) coords <- xyFromCell(obj, cell) if (cellnumbers) { pd <- cbind(pointDistance(xy[i,], coords, lonlat=FALSE), cell, value) } else { pd <- cbind(pointDistance(xy[i,], coords, lonlat=FALSE), value) } if (nrow(pd) > 1) { cv[[i]] <- pd[pd[,1] <= buffer[i], -1] } else { cv[[i]] <- pd[,-1] } } } } } if (small) { i <- sapply(cv, function(x) length(x)==0) if (any(i)) { i <- which(i) if (onlycells) { vv <- cbind(cellFromXY(object, xy[i, ,drop=FALSE]), NA) } else { vv <- extract(object, xy[i, ,drop=FALSE], na.rm=na.rm, layer=layer, nl=nl, cellnumbers=cellnumbers) } if (NCOL(vv) > 1) { for (j in 1:length(i)) { cv[[ i[j] ]] <- vv[j, ] } } else { for (j in 1:length(i)) { cv[[ i[j] ]] <- vv[j] } } } } nls <- nlayers(object) nms <- names(object) if (nls > 1) { if (layer > 1 | nl < nls) { lyrs <- layer:(layer+nl-1) nms <- nms[ lyrs ] cv <- lapply(cv, function(x) x[, lyrs ]) } } if (! is.null(fun)) { fun <- match.fun(fun) if (na.rm) { fun2 <- function(x){ x <- stats::na.omit(x) if (length(x) > 0) { return(fun(x)) } else { return(NA) } } } else { fun2 <- fun } #if (inherits(object, 'RasterLayer')) { if (nl == 1) { cv <- unlist(lapply(cv, fun2), use.names = FALSE) } else { np <- length(cv) cv <- lapply(cv, function(x) { if (!is.matrix(x)) { x <- t(matrix(x)) } apply(x, 2, fun2)} ) cv <- matrix(unlist(cv, use.names = FALSE), nrow=np, byrow=TRUE) colnames(cv) <- nms } } return(cv) } raster/R/netCDFtoRasterCD.R0000644000176200001440000002525214160021141015130 0ustar liggesusers# Author: Robert J. Hijmans # Date: Aug 2009 # Version 1.0 # Licence GPL v3 # Aug 2012, adapted for use with ncdf4 library .doTime <- function(x, nc, zvar, dim3) { dodays <- TRUE dohours <- FALSE doseconds <- FALSE un <- nc$var[[zvar]]$dim[[dim3]]$units if (substr(un, 1, 10) == "days since") { startDate = as.Date(substr(un, 12, 22)) } else if (substr(un, 1, 11) == "hours since") { dohours <- TRUE dodays <- FALSE startTime <- substr(un, 13, 30) mult <- 3600 } else if (substr(un, 1, 13) == "seconds since") { doseconds <- TRUE dodays <- FALSE startTime = as.Date(substr(un, 15, 31)) mult <- 1 } else if (substr(un, 1, 12) == "seconds from") { doseconds <- TRUE dodays <- FALSE startTime = as.Date(substr(un, 14, 31)) mult <- 1 } else { return(x) } if (!dodays) { start <- strptime(startTime, "%Y-%m-%d %H:%M:%OS", tz = "UTC") if (is.na(start)) start <- strptime(startTime, "%Y-%m-%d", tz = "UTC") if (is.na(start)) return(x) startTime <- start time <- startTime + as.numeric(getZ(x)) * mult time <- as.character(time) if (!is.na(time[1])) { x@z <- list(time) names(x@z) <- as.character('Date/time') } } else if (dodays) { # cal = nc$var[[zvar]]$dim[[dim3]]$calendar ? cal <- ncdf4::ncatt_get(nc, "time", "calendar") if (! cal$hasatt ) { greg <- TRUE } else { cal <- cal$value if (cal =='gregorian' | cal =='proleptic_gregorian' | cal=='standard') { greg <- TRUE } else if (cal == 'noleap' | cal == '365 day' | cal == '365_day') { greg <- FALSE nday <- 365 } else if (cal == '360_day') { greg <- FALSE nday <- 360 } else { greg <- TRUE warning('assuming a standard calender:', cal) } } time <- getZ(x) if (greg) { time <- as.Date(time, origin=startDate) } else { startyear <- as.numeric( format(startDate, "%Y") ) startmonth <- as.numeric( format(startDate, "%m") ) startday <- as.numeric( format(startDate, "%d") ) year <- trunc( as.numeric(time)/nday ) doy <- (time - (year * nday)) origin <- paste(year+startyear, "-", startmonth, "-", startday, sep='') time <- as.Date(doy, origin=origin) } x@z <- list(time) names(x@z) <- 'Date' } return(x) } .dimNames <- function(nc) { n <- nc$dim nams <- vector(length=n) if (n > 0) { for (i in 1:n) { nams[i] <- nc$dim[[i]]$name } } return(nams) } .varName <- function(nc, varname='', warn=TRUE) { n <- nc$nvars dims <- vars <- vector(length=n) if (n > 0) { for (i in 1:n) { vars[i] <- nc$var[[i]]$name dims[i] <- nc$var[[i]]$ndims } vars <- vars[dims > 1] dims <- dims[dims > 1] } if (varname=='') { nv <- length(vars) if (nv == 0) { return('z') } if (nv == 1) { varname <- vars } else { varname <- vars[which.max(dims)] if (warn) { if (sum(dims == max(dims)) > 1) { vars <- vars[dims==max(dims)] warning('varname used is: ', varname, '\nIf that is not correct, you can set it to one of: ', paste(vars, collapse=", ") ) } } } } zvar <- which(varname == vars) if (length(zvar) == 0) { stop('varname: ', varname, ' does not exist in the file. Select one from:\n', paste(vars, collapse=", ") ) } return(varname) } .rasterObjectFromCDF <- function(filename, varname='', band=NA, type='RasterLayer', lvar, level=0, warn=TRUE, dims=1:3, crs="", stopIfNotEqualSpaced=TRUE, ...) { stopifnot(requireNamespace("ncdf4")) stopifnot(type %in% c('RasterLayer', "RasterBrick")) nc <- ncdf4::nc_open(filename, readunlim=FALSE, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) conv <- ncdf4::ncatt_get(nc, 0, "Conventions") #grads <- FALSE #if (grepl("GrADS", conv$value) { # grads <- TRUE #} # else assuming > "CF-1.0" zvar <- .varName(nc, varname, warn=warn) # datatype <- .getRasterDTypeFromCDF( nc$var[[zvar]]$prec ) dim3 <- dims[3] ndims <- nc$var[[zvar]]$ndims if (ndims== 1) { return(.rasterObjectFromCDF_GMT(nc)) } else if (ndims == 4) { if (missing(lvar)) { nlevs3 <- nc$var[[zvar]]$dim[[3]]$len nlevs4 <- nc$var[[zvar]]$dim[[4]]$len if (nlevs3 > 1 & nlevs4 == 1) { lvar <- 4 } else { lvar <- 3 } } nlevs <- nc$var[[zvar]]$dim[[lvar]]$len if (level <=0 ) { level <- 1 # perhaps detect case where lvar should be 4? #https://stackoverflow.com/questions/56261199/extracting-all-levels-from-netcdf-file-in-r/ if (nlevs > 1) { warning('"level" set to 1 (there are ', nlevs, ' levels)') } } else { oldlevel <- level <- round(level) level <- max(1, min(level, nlevs)) if (oldlevel != level) { warning('level set to: ', level) } } if (lvar == 4) { dim3 <- 3 } else { dim3 <- 4 } } else if (ndims > 4) { warning(zvar, ' has more than 4 dimensions, I do not know what to do with these data') } ncols <- nc$var[[zvar]]$dim[[dims[1]]]$len nrows <- nc$var[[zvar]]$dim[[dims[2]]]$len ## to allow suppress_dimvals ## xx <- nc$var[[zvar]]$dim[[dims[1]]]$vals xx <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dims[1]]]$name), silent = TRUE) if (inherits(xx, "try-error")) { xx <- seq_len(nc$var[[zvar]]$dim[[dims[1]]]$len) } rs <- xx[-length(xx)] - xx[-1] if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) { if (is.na(stopIfNotEqualSpaced)) { warning('cells are not equally spaced; you should extract values as points') } else if (stopIfNotEqualSpaced) { stop('cells are not equally spaced; you should extract values as points') } } xrange <- c(min(xx), max(xx)) resx <- (xrange[2] - xrange[1]) / (ncols-1) rm(xx) ## to allow suppress_dimvals ## yy <- nc$var[[zvar]]$dim[[dims[2]]]$vals yy <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dims[2]]]$name), silent = TRUE) if (inherits(yy, "try-error")) { yy <- seq_len(nc$var[[zvar]]$dim[[dims[2]]]$len) } rs <- yy[-length(yy)] - yy[-1] if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) { if (is.na(stopIfNotEqualSpaced)) { warning('cells are not equally spaced; you should extract values as points') } else if (stopIfNotEqualSpaced) { stop('cells are not equally spaced; you should extract values as points') } } yrange <- c(min(yy), max(yy)) resy <- (yrange[2] - yrange[1]) / (nrows-1) if (yy[1] > yy[length(yy)]) { toptobottom <- FALSE } else { toptobottom <- TRUE } rm(yy) xrange[1] <- xrange[1] - 0.5 * resx xrange[2] <- xrange[2] + 0.5 * resx yrange[1] <- yrange[1] - 0.5 * resy yrange[2] <- yrange[2] + 0.5 * resy long_name <- zvar unit <- '' natest <- ncdf4::ncatt_get(nc, zvar, "_FillValue") natest2 <- ncdf4::ncatt_get(nc, zvar, "missing_value") prj <- NA minv <- maxv <- NULL a <- ncdf4::ncatt_get(nc, zvar, "min") if (a$hasatt) { minv <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "max") if (a$hasatt) { maxv <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "long_name") if (a$hasatt) { long_name <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "units") if (a$hasatt) { unit <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "grid_mapping") if ( a$hasatt ) { gridmap <- a$value try(atts <- ncdf4::ncatt_get(nc, gridmap), silent=TRUE) try(prj <- .getCRSfromGridMap4(atts), silent=TRUE) } if (is.na(prj)) { if ((tolower(substr(nc$var[[zvar]]$dim[[dims[1]]]$name, 1, 3)) == 'lon') & ( tolower(substr(nc$var[[zvar]]$dim[[dims[2]]]$name, 1, 3)) == 'lat' ) ) { if ( yrange[1] > -91 | yrange[2] < 91 ) { if ( xrange[1] > -181 | xrange[2] < 181 ) { prj <- '+proj=longlat +datum=WGS84' } else if ( xrange[1] > -1 | xrange[2] < 361 ) { prj <- '+proj=longlat +lon_wrap=180 +datum=WGS84' } } } } crs <- .getProj(prj, crs) if (type == 'RasterLayer') { r <- raster(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) names(r) <- long_name } else if (type == 'RasterBrick') { r <- brick(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) r@title <- long_name } else { stop("unknown object type") } r@file@name <- filename r@file@toptobottom <- toptobottom r@data@unit <- unit attr(r@data, "zvar") <- zvar attr(r@data, "dim3") <- dim3 attr(r@data, "level") <- level r@file@driver <- "netcdf" if (natest$hasatt) { r@file@nodatavalue <- as.numeric(natest$value) } else if (natest2$hasatt) { r@file@nodatavalue <- as.numeric(natest2$value) } r@data@fromdisk <- TRUE if (ndims == 2) { nbands <- 1 } else { nbands <- nc$var[[zvar]]$dim[[dim3]]$len r@file@nbands <- nbands ## to allow suppress_dimvals # r@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals ) dim3_vals <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dim3]]$name), silent = TRUE) if (inherits(dim3_vals, "try-error")) { dim3_vals <- seq_len(nc$var[[zvar]]$dim[[dim3]]$len) } r@z <- list(dim3_vals) if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) { try( r <- .doTime(r, nc, zvar, dim3) ) } else { vname <- nc$var[[zvar]]$dim[[dim3]]$name vunit <- nc$var[[zvar]]$dim[[dim3]]$units names(r@z) <- paste0(vname, " (", vunit, ")") } } if (length(ndims)== 2 & type != 'RasterLayer') { warning('cannot make a RasterBrick from data that has only two dimensions (no time step), returning a RasterLayer instead') } if (type == 'RasterLayer') { if (is.null(band) | is.na(band)) { if (ndims > 2) { stop(zvar, ' has multiple layers, provide a "band" value between 1 and ', nc$var[[zvar]]$dim[[dim3]]$len) } } else { if (length(band) > 1) { stop('A RasterLayer can only have a single band. You can use a RasterBrick instead') } if (is.na(band)) { r@data@band <- as.integer(1) } else { band <- as.integer(band) if ( band > nbands(r) ) { stop(paste("The band number is too high. It should be between 1 and", nbands)) } if ( band < 1) { stop(paste("band should be 1 or higher")) } r@data@band <- band } r@z <- list( getZ(r)[r@data@band] ) if (!(is.null(minv) | is.null(maxv))) { r@data@min <- minv[band] r@data@max <- maxv[band] r@data@haveminmax <- TRUE } } } else { r@data@nlayers <- r@file@nbands try( names(r) <- as.character(r@z[[1]]), silent=TRUE ) if (!(is.null(minv) | is.null(maxv))) { r@data@min <- minv r@data@max <- maxv r@data@haveminmax <- TRUE } else { r@data@min <- rep(Inf, r@file@nbands) r@data@max <- rep(-Inf, r@file@nbands) } } return(r) } raster/R/extractLines.R0000644000176200001440000001625114160021141014536 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='SpatialLines'), function(x, y, fun=NULL, na.rm=FALSE, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, along=FALSE, sp=FALSE, ...){ #px <-.getCRS(x, asText=FALSE) px <-.getCRS(x) comp <- compareCRS(px,.getCRS(y), unknown=TRUE) if (!comp) { .requireRgdal() warning('Transforming SpatialLines to the crs of the Raster object') y <- sp::spTransform(y, px) } if (missing(layer)) { layer <- 1 } if (missing(nl)) { nl <- nlayers(x) } if (!is.null(fun)) { cellnumbers <- FALSE along <- FALSE if (sp) { df <- TRUE } } else { if (sp) { sp <- FALSE warning('argument sp=TRUE is ignored if fun=NULL') } } if (along) { return(.extractLinesAlong(x, y, cellnumbers=cellnumbers, df=df, layer, nl, factors=factors, ...)) } spbb <- sp::bbox(y) rsbb <- bbox(x) addres <- 2 * max(res(x)) nlns <- length( y@lines ) res <- list() res[[nlns+1]] <- NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { if (df) { res <- matrix(ncol=1, nrow=0) colnames(res) <- 'ID' return(res) } else { return(res[1:nlns]) } } rr <- raster(x) cn <- names(x) pb <- pbCreate(nlns, label='extract', ...) if (.doCluster()) { .sendCall <- eval( parse( text="parallel:::sendCall") ) cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nlns, length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() parallel::clusterExport(cl, c('rsbb', 'rr', 'addres', 'cellnumbers'), envir=environment()) clFun <- function(i, pp) { spbb <- sp::bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # always TRUE? r <- .xyValues(x, xy, layer=layer, nl=nl) if (cellnumbers) { r <- cbind(cellFromXY(rr, xy), r) colnames(r) <- c('cell', cn) } } else { r <- NULL } } r } for (ni in 1:nodes) { .sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni) } for (i in 1:nlns) { d <- .recvOneData(cl) if (! d$value$success) { stop('cluster error at polygon: ', i) } res[[d$value$tag]] <- d$value$value ni <- ni + 1 if (ni <= nlns) { .sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni) } pbStep(pb) } } else { for (i in 1:nlns) { pp <- y[i,] spbb <- sp::bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (cellnumbers) { v <- cbind(cellFromXY(rr, xy), .xyValues(x, xy, layer=layer, nl=nl)) colnames(v) <- c('cell', cn) res[[i]] <- v } else { res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl) } } pbStep(pb) } } res <- res[1:nlns] pbClose(pb) if (! is.null(fun)) { i <- sapply(res, is.null) if (nlayers(x) > 1) { j <- matrix(ncol=nlayers(x), nrow=length(res)) j[!i] <- t(sapply(res[!i], function(x) apply(x, 2, fun, na.rm=na.rm))) colnames(j) <- names(x) } else { j <- vector(length=length(i)) j[i] <- NA j[!i] <- sapply(res[!i], fun, na.rm=na.rm) } res <- j } if (df) { if (!is.list(res)) { res <- data.frame(ID=1:NROW(res), res) } else { res <- data.frame( do.call(rbind, sapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) } lyrs <- layer:(layer+nl-1) if (cellnumbers) { colnames(res) <- c("ID", "cell", names(x)[lyrs]) } else { colnames(res) <- c("ID", names(x)[lyrs]) } if (any(is.factor(x)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } if (sp) { if (nrow(res) != nlns) { warning('sp=TRUE is ignored because fun does not summarize the values of each line to a single number') return(res) } if (!.hasSlot(y, 'data') ) { y <- sp::SpatialLinesDataFrame(y, res[, -1, drop=FALSE], match.ID=FALSE) } else { y@data <- cbind(y@data, res[, -1, drop=FALSE]) } return(y) } res } ) .extractLinesAlong <- function(x, y, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, ...){ spbb <- sp::bbox(y) rsbb <- bbox(x) addres <- 2 * max(res(x)) nlns <- length( y@lines ) res <- list() res[[nlns+1]] <- NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { if (df) { res <- matrix(ncol=1, nrow=0) colnames(res) <- 'ID' return(res) } else { return(res[1:nlns]) } } rr <- raster(x) cn <- names(x) pb <- pbCreate(nlns, label='extract', ...) y <- data.frame(geom(y) ) for (i in 1:nlns) { yp <- y[y$object == i, ] nparts <- max(yp$part) vv <- NULL for (j in 1:nparts) { pp <- yp[yp$part==j, c('x', 'y'), ] for (k in 1:(nrow(pp)-1)) { ppp <- pp[k:(k+1), ] spbb <- sp::bbox(as.matrix(ppp)) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { lns <- sp::SpatialLines(list(sp::Lines(list(sp::Line(ppp)), "1"))) rc <- crop(rr, extent(lns) + addres) rc <- .linesToRaster(lns, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] v <- cbind(row=rowFromY(rr, xy[,2]), col=colFromX(rr, xy[,1]), .xyValues(x, xy, layer=layer, nl=nl)) #up or down? updown <- c(1,-1)[(ppp[1,2] < ppp[2,2]) + 1] rightleft <- c(-1,1)[(ppp[1,1] < ppp[2,1]) + 1] v <- v[order(updown*v[,1], rightleft*v[,2]), ] #up <- ppp[1,2] < ppp[2,2] #right <- ppp[1,1] < ppp[2,1] # if (up) { # if (right) { # v <- v[order(-v[,1], v[,2]), ] # } else { # v <- v[order(-v[,1], -v[,2]), ] # } # } else { # if (!right) { # v <- v[order(v[,1], -v[,2]), ] # } # } vv <- rbind(vv, v) } } } if (cellnumbers) { vv <- cbind(cellFromRowCol(rr, vv[,1], vv[,2]), vv[,-c(1:2)]) colnames(vv) <- c('cell', names(x)) } else { vv <- vv[,-c(1:2)] if (NCOL(vv) > 1) { colnames(vv) <- names(x) } } res[[i]] <- vv pbStep(pb) } res <- res[1:nlns] pbClose(pb) if (df) { res <- data.frame( do.call(rbind, lapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) lyrs <- layer:(layer+nl-1) colnames(res) <- c('ID', names(x)[lyrs]) if (any(is.factor(x)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } res } raster/R/progressBar.R0000644000176200001440000000332114160021141014354 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2008 # Version 0.9 # Licence GPL v3 pbCreate <- function(nsteps, progress, style=3, label='Progress', ...) { if (missing(progress)) { progress <- .progress() } if (is.null(progress)) { progress <- .progress() } if (progress=='text') { pb <- utils::txtProgressBar(min=0, max=nsteps, style=style) } else if (progress %in% c('window', 'tcltk', 'windows')) { tit <- paste(label, ' (', nsteps, ' steps)', sep='') #if (.Platform$OS.type == "windows" ) { # pb <- winProgressBar(title=tit, min=0 , max=nsteps, width = 300, label='starting') #} else { requireNamespace("tcltk") pb <- tcltk::tkProgressBar(title=tit, min=0, max=nsteps, width = 300, label='starting') #} } else { pb <- 'none' } attr(pb, "starttime") <- Sys.time() return(pb) } pbStep <- function(pb, step=NULL, label='') { pbclass <- class(pb) if (pbclass=="txtProgressBar") { if (is.null(step)) { step = pb$getVal() + 1 } utils::setTxtProgressBar(pb, step) } else if (pbclass=="tkProgressBar") { if (is.null(step)) { step = pb$getVal() + 1 } tcltk::setTkProgressBar(pb, step, label=paste(label, step)) #} else if (pbclass=="winProgressBar") { # if (is.null(step)) { step <- getWinProgressBar(pb)+1 } # setWinProgressBar(pb, step, label=paste(label, step)) } } pbClose <- function(pb, timer) { pbclass <- class(pb) if (pbclass=="txtProgressBar") { cat("\n\r") close(pb) } else if (pbclass=="tkProgressBar") { close(pb) } if (missing(timer)) { timer <- .timer() } if (timer) { elapsed <- difftime(Sys.time(), attr(pb, "starttime"), units = "secs") cat(round(as.numeric(elapsed)), 'seconds\n') } } raster/R/whiches.max.R0000644000176200001440000000502514160021141014304 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2016 # Version 1.0 # Licence GPL v3 # 'whiches' functions based on code by Data Munger: # https://stackoverflow.com/questions/36117678/r-raster-how-to-record-ties-using-which-max/36120244#36120244 .whiches <- function(i, fun=min, na.rm=TRUE) { w <- getOption('warn') on.exit(options('warn'= w)) options('warn'=-1) m <- which(i == fun(i, na.rm=na.rm)) sum(m * 10^(rev(seq_along(m)) - 1)) } setMethod("whiches.min", "RasterStackBrick", function(x) { whichesMin <- function(i) { m <- which(i == min(i, na.rm=TRUE)) sum(m * 10^(rev(seq_along(m)) - 1)) } r <- raster(x) nl <- nlayers(x) if (nl > 9) { stop('you can use only use this function for an object with less than 10 layers') } if (canProcessInMemory(x)) { x <- values(x) d <- dim(x) i <- .rowSums(is.na(x), d[1], d[2]) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, whichesMin) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) d <- dim(v) j <- .rowSums(is.na(v), d[1], d[2]) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, whichesMin) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) setMethod("whiches.max", "RasterStackBrick", function(x) { whichesMax <- function(i) { m <- which(i == max(i, na.rm=TRUE)) sum(m * 10^(rev(seq_along(m)) - 1)) } r <- raster(x) nl <- nlayers(x) if (nl > 9) { stop('you can use only use this function for an object with less than 10 layers') } if (canProcessInMemory(x)) { x <- values(x) d <- dim(x) i <- .rowSums(is.na(x), d[1], d[2]) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, whichesMax) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) d <- dim(v) j <- .rowSums(is.na(v), d[1], d[2]) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, whichesMax) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) raster/R/disaggregate.R0000644000176200001440000000527514160021141014523 0ustar liggesusers# Author: Robert Hijmans # Date : October 2008 - December 2011 # Version 1.0 # Licence GPL v3 # April 2012: Several patches & improvements by Jim Regetz setMethod('disaggregate', signature(x='Raster'), function(x, fact=NULL, method='', filename='', ...) { method <- tolower(method) if (!method %in% c('bilinear', '')) { stop('unknown "method". Should be "bilinear" or ""') } stopifnot(!is.null(fact)) fact <- as.integer(round(fact)) if (length(fact)==1) { if (fact == 1) return(x) if (fact < 2) { stop('fact should be >= 1') } xfact <- yfact <- fact } else if (length(fact)==2) { xfact <- fact[1] yfact <- fact[2] if (xfact < 1) { stop('fact[1] should be > 0') } if (yfact < 1) { stop('fact[2] should be > 0') } if (xfact == 1 & yfact == 1) { return(x) } } else { stop('length(fact) should be 1 or 2') } filename <- trim(filename) nl <- nlayers(x) if (nl > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } ncx <- ncol(x) nrx <- nrow(x) dim(out) <- c(nrx * yfact, ncx * xfact) names(out) <- names(x) if (! inherits(x, 'RasterStack')) { if (! inMemory(x) & ! fromDisk(x) ) { return(out) } } if (method=='bilinear') { return(resample(x, out, method='bilinear', filename=filename, ...)) } if (canProcessInMemory(out, 3)) { x <- getValues(x) cols <- rep(seq.int(ncx), each=xfact) rows <- rep(seq.int(nrx), each=yfact) cells <- as.vector( outer(cols, ncx*(rows-1), FUN="+") ) if (nl > 1) { x <- x[cells, ] } else { x <- x[cells] } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename,...) } } else { tr <- blockSize(x, n=nlayers(x) * prod(fact)) rown <- (tr$row-1) * yfact + 1 pb <- pbCreate(tr$n, label='disaggregate', ...) if (is.null(list(...)$datatype)) { out <- writeStart(out, filename=filename, datatype=.commonDataType(dataType(x)), ...) } else { out <- writeStart(out, filename=filename, ...) } x <- readStart(x, ...) cols <- rep(seq.int(ncx), each=xfact) rows <- rep(seq.int(tr$nrows[1]), each=yfact) cells <- as.vector( outer(cols, ncx*(rows-1), FUN="+") ) for (i in 1:tr$n) { if (i == tr$n) { if (tr$nrows[i] != tr$nrows[1]) { rows <- rep(seq.int(tr$nrows[i]), each=yfact) cells <- outer(cols, ncx*(rows-1), FUN="+") } } v <- getValues(x, tr$row[i], tr$nrows[i]) if (nl > 1) { v <- v[cells, ] } else { v <- v[cells] } out <- writeValues(out, v, rown[i]) pbStep(pb, i) } out <- writeStop(out) x <- readStop(x) pbClose(pb) } return(out) } ) raster/R/rasterFromRasterFile.R0000644000176200001440000002661114160021141016177 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .getRat <- function(x, ratvalues, ratnames, rattypes) { rat <- data.frame(matrix(ratvalues, nrow=length(ratvalues) / length(ratnames)), stringsAsFactors=FALSE) colnames(rat) <- ratnames for (i in 1:ncol(rat)) { if (rattypes[i] == 'integer') { rat[, i] <- as.integer(rat[,i]) } else if (rattypes[i] == 'numeric') { rat[, i] <- as.numeric(rat[,i]) } else if (rattypes[i] == 'factor') { rat[, i] <- as.factor(rat[,i]) } } x@data@isfactor <- TRUE x@data@attributes <- list(rat) x } .getProj <- function(proj, crs) { if (is.na(proj)) { proj <- "" } if ( crs != "" ) { if (proj == "") { proj <- crs } else { warning('argument "crs" ignored because the file provides a crs') } } proj } .getmetadata <- function(x) { x <- x[x[,1] == 'metadata', , drop=FALSE] if (nrow(x) == 0) { return( list() ) } y <- sapply(x[,2], function(i) .strSplitOnFirstToken(i, '.')) colnames(y) <- NULL v1 <- y[1,] v2 <- y[2,] vv <- sapply(x[,3], function(i) .strSplitOnFirstToken(i, ':')) colnames(vv) <- NULL type <- vv[1,] v3 <- gsub('#NL#', '\n', vv[2,]) a <- list() for (i in 1:length(v1)) { value <- unlist(strsplit(v3[i], '#,#')) if (type[i] == 'Date') { try(value <- as.Date(value)) } else { try(value <- as(value, type[i])) } if (is.na(v2[i])) { a[[v1[i]]] <- value } else { b <- list(value) names(b) <- v2[i] a[[v1[i]]] <- c(a[[v1[i]]], b) } } a } .rasterFromRasterFile <- function(filename, band=1, type='RasterLayer', driver='raster', RAT=TRUE, crs="", ...) { valuesfile <- .setFileExtensionValues(filename, driver) if (!file.exists( valuesfile )){ stop( paste(valuesfile, "does not exist")) } filename <- .setFileExtensionHeader(filename, driver) ini <- readIniFile(filename) metadata <- .getmetadata(ini) ini <- ini[ini[,1] != 'metadata', , drop=FALSE] ini[,2] = toupper(ini[,2]) byteorder <- .Platform$endian nbands <- as.integer(1) band <- as.integer(band) bandorder <- "BIL" prj <- NA minval <- NA maxval <- NA nodataval <- -Inf layernames <- "" zvalues <- "" zclass <- NULL colortable <- NULL isCat <- FALSE ratnames <- rattypes <- ratvalues <- NULL catlevels <- matrix(NA) #match(c("MINX", "MAXX", "MINY", "MAXY", "XMIN", "XMAX", "YMIN", "YMAX", "ROWS", "COLUMNS", "NROWS", "NCOLS"), toupper(ini[,2])) grdversion <- ifelse(isTRUE((ini[ini[,1] =="version",3] == "2")), 2, 1) if (grdversion >= 2) { for (i in 1:nrow(ini)) { if (ini[i,2] == "MINX") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MINY") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXY") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMIN") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMAX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMIN") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMAX") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "NROW") { nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "NCOL") { nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "RANGE_MIN") { suppressWarnings( try ( minval <- as.numeric(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE)), silent = TRUE ) ) } else if (ini[i,2] == "RANGE_MAX") { suppressWarnings( try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE)), use.names=FALSE), silent = TRUE ) ) } else if (ini[i,2] == "VALUEUNIT") { try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE)), use.names=FALSE), silent = TRUE) } else if (ini[i,2] == "CATEGORICAL") { try ( isCat <- as.logical(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE)), use.names=FALSE), silent = TRUE ) #else if (ini[i,2] == "RATROWS") { ratrows <- as.integer(ini[i,3]) } } else if (ini[i,2] == "RATNAMES") { ratnames <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE) } else if (ini[i,2] == "RATTYPES") { rattypes <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE) } else if (ini[i,2] == "RATVALUES") { ratvalues <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE) } else if (ini[i,2] == "LEVELS") { try ( catlevels <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE ), silent = TRUE) } else if (ini[i,2] == "COLORTABLE") { try ( colortable <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE), silent = TRUE ) } else if (ini[i,2] == "NODATA") { if (ini[i,3] == "NA") { nodataval <- as.double(NA) } else { nodataval <- as.numeric(ini[i,3]) } } else if (ini[i,2] == "DATATYPE") { inidatatype <- ini[i,3] } else if (ini[i,2] == "BYTEORDER") { byteorder <- ini[i,3] } else if (ini[i,2] == "NLYR") { nbands <- as.integer(ini[i,3]) } else if (ini[i,2] == "BANDORDER") { bandorder <- ini[i,3] } else if (ini[i,2] == "CRS") { prj <- ini[i,3] } else if (ini[i,2] == "NAMES") { layernames <- ini[i,3] } else if (ini[i,2] == "ZVALUES") { zvalues <- ini[i,3] } else if (ini[i,2] == "ZCLASS") { zclass <- ini[i,3] } } } else { for (i in 1:length(ini[,1])) { if (ini[i,2] == "MINX") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MINY") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXY") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMIN") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMAX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMIN") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMAX") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "ROWS") { nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "COLUMNS") { nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "NROWS") { nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "NCOLS") { nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "MINVALUE") { suppressWarnings( try ( minval <- as.numeric(unlist(strsplit(ini[i,3], ':'), use.names=FALSE)), silent = TRUE ) ) } else if (ini[i,2] == "MAXVALUE") { suppressWarnings( try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE ) ) } else if (ini[i,2] == "VALUEUNIT") { try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE) } else if (ini[i,2] == "CATEGORICAL") { try ( isCat <- as.logical(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE ) #else if (ini[i,2] == "RATROWS") { ratrows <- as.integer(ini[i,3]) } } else if (ini[i,2] == "RATNAMES") { ratnames <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE) } else if (ini[i,2] == "RATTYPES") { rattypes <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE) } else if (ini[i,2] == "RATVALUES") { ratvalues <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE) ratvalues <- gsub('~^colon^~', ':', ratvalues) } else if (ini[i,2] == "LEVELS") { try ( catlevels <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE ), silent = TRUE) } else if (ini[i,2] == "COLORTABLE") { try ( colortable <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE), silent = TRUE ) } else if (ini[i,2] == "NODATAVALUE") { if (ini[i,3] == 'NA') { nodataval <- as.double(NA) } else { nodataval <- as.numeric(ini[i,3]) } } else if (ini[i,2] == "DATATYPE") { inidatatype <- ini[i,3] } else if (ini[i,2] == "BYTEORDER") { byteorder <- ini[i,3] } else if (ini[i,2] == "NBANDS") { nbands <- as.integer(ini[i,3]) } else if (ini[i,2] == "BANDORDER") { bandorder <- ini[i,3] } else if (ini[i,2] == "PROJECTION") { prj <- ini[i,3] } else if (ini[i,2] == "LAYERNAME") { layernames <- ini[i,3] } else if (ini[i,2] == "ZVALUES") { zvalues <- ini[i,3] } else if (ini[i,2] == "ZCLASS") { zclass <- ini[i,3] } } if (!is.na(prj)) { if (prj == 'GEOGRAPHIC') { prj <- "+proj=longlat" } else if (prj == 'UNKNOWN' | prj == 'NA') { prj <- NA } } } prj <- .getProj(prj, crs) if (band < 1) { stop("band must be 1 or larger") #band <- 1 #warning('band set to 1') } else if (band > nbands) { stop(paste("band too high. Should be between 1 and", nbands)) #band <- nbands #warning('band set to ', nbands) } minval <- minval[1:nbands] maxval <- maxval[1:nbands] minval[is.na(minval)] <- Inf maxval[is.na(maxval)] <- -Inf if (type == 'RasterBrick') { x <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=prj) x@data@nlayers <- as.integer(nbands) x@data@min <- minval x@data@max <- maxval } else { x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=prj) x@data@band <- as.integer(band) x@data@min <- minval[band] x@data@max <- maxval[band] if (RAT) { if (isTRUE(isCat[band])) { # currently only for a single layer! try( x <- .getRat(x, ratvalues, ratnames, rattypes), silent=TRUE ) } } } x@file@nbands <- as.integer(nbands) if (bandorder %in% c("BSQ", "BIP", "BIL")) { x@file@bandorder <- bandorder } if (nchar(layernames) > 0) { lnames <- as.vector(unlist(strsplit(layernames, ':'))) if (length(lnames) != nbands) { lnames <- rep( gsub(" ", "_", extension(basename(filename), "")), nbands) } } else { lnames <- gsub(" ", "_", extension(basename(filename), "")) if (nbands < 0) { lnames <- paste(lnames , 1:nbands, sep='_') } } if (zvalues != '') { names(zvalues) <- NULL zvalues <- unlist(strsplit(zvalues, ':')) zname <- zvalues[1] zvalues <- zvalues[-1] if (!is.null(zclass)) { if (zclass == 'Date') { try( zvalues <- as.Date(zvalues), silent=TRUE ) # by Stefan Schlaffer } else if (length(grep("POSIXt",zclass)) > 0 & length(zvalues) == nbands*3) { zvalues <- sapply(seq(1,nbands*3,3), function(i) paste0(zvalues[c(i,i+1,i+2)], collapse=":")) try( zvalues <- as.POSIXct(strptime(zvalues, "%Y-%m-%d %H:%M:%S", tz="UTC")), silent=TRUE ) } else { try( zvalues <- as(zvalues, zclass), silent=TRUE ) } } if (type == 'RasterBrick') { zvalues <- list(zvalues) } else { zvalues <- list(zvalues[band]) } names(zvalues) <- zname x@z <- zvalues } if (type == 'RasterBrick') { names(x) <- lnames } else { names(x) <- lnames[band] } dataType(x) <- inidatatype x@data@haveminmax <- TRUE # should check? x@file@nodatavalue <- nodataval if ((byteorder == "little") | (byteorder == "big")) { x@file@byteorder <- byteorder } x@data@fromdisk <- TRUE x@file@driver <- driver # if( dataSize(x) * (ncell(x) * nbands(x) + x@file@offset) != file.info(valuesfile)$size ) { # if (driver == 'big.matrix') { # requireNamespace("bigmemory") # x@file@name <- valuesfile # dscfile <- extension(valuesfile, 'big.dsc') # attr(x@file, 'big.matrix') <- attach.big.matrix(dscfile) # } else { x@file@name <- filename if( (dataSize(x) * ncell(x) * nbands(x)) != file.info(valuesfile)$size ) { warning('size of values file does not match the number of cells (given the data type)') # } } if (!is.null(colortable)) { x@legend@colortable <- colortable } x@history <- metadata return(x) } raster/R/gdalFormats.R0000644000176200001440000000560114160021141014331 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .isSupportedFormat <- function(dname) { #res <- dname %in% c(.nativeDrivers(), 'ascii', 'big.matrix', 'CDF') res <- dname %in% c(.nativeDrivers(), 'ascii', 'CDF') if (!res) { res <- .isSupportedGDALFormat(dname) } return(res) } .gdalWriteFormats <- function() { .requireRgdal() gd <- rgdal::gdalDrivers() gd <- as.matrix( gd[gd[,3] == T, ] ) i <- which(gd[,1] %in% c('VRT', 'MEM', 'MFF', 'MFF2')) gd[-i,] } .isSupportedGDALFormat <- function(dname) { .requireRgdal() gd <- .gdalWriteFormats() res <- dname %in% gd[,1] if (!res) { stop(paste(dname, "is not a supported file format. See writeFormats()" ) ) } return(res) } #.GDALDataTypes <- c('Unknown', 'Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', ' # what are these? CInt16', 'CInt32', 'CFloat32', 'CFloat64') "as in C"? # this needs to get fancier; depending on object and the abilties of the drivers .getGdalDType <- function(dtype, format='') { if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'INT4U', 'FLT4S', 'FLT8S'))) { stop('not a valid data type') } if (dtype == 'INT1S') { # gdal does not have this warning('data type "INT1S" is not available in GDAL. Changed to "INT2S" (you may prefer "INT1U" (Byte))') dtype <- 'INT2S' } type <- .shortDataType(dtype) size <- dataSize(dtype) * 8 if (format=='BMP' | format=='ADRG' | format=='IDA' | format=='SGI') { return('Byte') } if (format=='PNM') { if (size == 8) { return('Byte') } else { return('UInt16') } } if (format=='RMF') { if (type == 'FLT') { return('Float64') } } if (type == 'LOG') { warning('data type "LOG" is not available in GDAL. Changed to "INT1U"') return('Byte') } if (type == 'INT') { type <- 'Int' if (size == 64) { size <- 32 warning('8 byte integer values not supported by rgdal, changed to 4 byte integer values') } if (! dataSigned(dtype) ) { if (size == 8) { return('Byte') } else { type <- paste('U', type, sep='') } } } else { type <- 'Float' } return(paste(type, size, sep='')) } .getRasterDType <- function(dtype) { if (!(dtype %in% c('Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', 'CInt16', 'CInt32', 'CFloat32', 'CFloat64'))) { return ('FLT4S') } else if (dtype == 'Byte') { return('INT1U') } else if (dtype == 'UInt16') { return('INT2U') } else if (dtype == 'Int16' | dtype == 'CInt16') { return('INT2S') } else if (dtype == 'UInt32') { return('INT4U') } else if (dtype == 'Int32' | dtype == 'CInt32') { return('INT4S') } else if (dtype == 'Float32' | dtype == 'CFloat32' ) { return('FLT4S') } else if (dtype == 'Float64' | dtype == 'CFloat64' ) { return('FLT8S') } else { return('FLT4S') } } raster/R/factor.R0000644000176200001440000001106014160021141013340 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2010 / June 2012 # Version 1.0 # Licence GPL v3 factorValues <- function(x, v, layer=1, att=NULL, append.names=FALSE) { stopifnot(is.factor(x)[layer]) rat <- levels(x)[[layer]] if (!is.data.frame(rat)) { rat <- rat[[1]] } # if (colnames(rat)[2]=='WEIGHT') { # i <- which(match(rat$ID, round(v))==1) # } else { i <- match(round(v), rat$ID) # } r <- rat[i, -1, drop=FALSE] rownames(r) <- NULL if (!is.null(att)) { if (is.character(att)) { att <- stats::na.omit(match(att, colnames(r))) if (length(att) == 0) { warning("att does not includes valid names") } else { r <- r[, att, drop=FALSE] } } else { r <- r[, att, drop=FALSE] } } if (append.names) { colnames(r) <- paste(names(x)[layer], colnames(r), sep="_") } r } .insertFacts <- function(x, v, lyrs) { facts <- is.factor(x)[lyrs] if (!any(facts)) { return(v) } i <- which(facts) v <- lapply(1:length(facts), function(i) { if (facts[i]) { data.frame(factorValues(x, v[, i], i, append.names=TRUE)) } else { v[, i, drop=FALSE] } } ) do.call(data.frame, v) } setMethod('is.factor', signature(x='Raster'), function(x) { f <- x@data@isfactor nl <- nlayers(x) if (length(f) < nl) { f <- c(f, rep(FALSE, nl))[1:nl] } f } ) setMethod('is.factor', signature(x='RasterStack'), function(x) { if (nlayers(x) > 0) { s <- sapply(x@layers, function(x) x@data@isfactor) return(s) } else { return(FALSE) } } ) if (!isGeneric("levels")) { setGeneric("levels", function(x) standardGeneric("levels")) } setMethod('levels', signature(x='Raster'), function(x) { f <- is.factor(x) if (any(f)) { if (inherits(x, 'RasterStack')) { return( sapply(x@layers, function(i) i@data@attributes) ) } else { return(x@data@attributes) } } else { return(NULL) } } ) .checkLevels <- function(old, newv) { if (! is.data.frame(newv)) { stop('new raster attributes (factor values) should be in a data.frame (inside a list)') } if (! ncol(newv) > 0) { stop('the number of columns in the raster attributes (factors) data.frame should be > 0') } if (! colnames(newv)[1] == c('ID')) { stop('the first column name of the raster attributes (factors) data.frame should be "ID"') } if (!is.null(old)) { # if (colnames(newv)[2] == 'WEIGHT') { # if (nrow(newv) < nrow(old)) { # warning('the number of rows in the raster attributes (factors) data.frame is lower than expected (values missing?)') # } # if (! all(unique(sort(newv[,1])) == sort(unique(old[,1])))) { # warning('the values in the "ID" column in the raster attributes (factors) data.frame have changed') # } # } else { if (! nrow(newv) == nrow(old)) { warning('the number of rows in the raster attributes (factors) data.frame is unexpected') } if (! all(sort(newv[,1]) == sort(old[,1]))) { warning('the values in the "ID" column in the raster attributes (factors) data.frame have changed') } # } } newv[, 1] <- as.integer(newv[, 1]) # if (colnames(newv)[2] == 'WEIGHT') { # newv[, 2] <- as.numeric(newv[, 2]) # } newv } setMethod('levels<-', signature(x='Raster'), function(x, value) { if (is.null(value)) { return(x) } isfact <- is.factor(x) if (inherits(x, 'RasterLayer')) { if (!is.data.frame(value)) { if (is.list(value)) { value <- value[[1]] } } value <- .checkLevels(levels(x)[[1]], value) x@data@attributes <- list(value) x@data@isfactor <- TRUE return(x) } i <- ! sapply(value, is.null) if ( any(i) ) { stopifnot (length(value) == nlayers(x)) levs <- levels(x) for (j in which(i)) { value[[j]] <- .checkLevels(levs[[j]], value[[j]]) } x@data@attributes <- value x@data@isfactor <- i } else { x@data@attributes <- list() } x@data@isfactor <- i return(x) } ) setMethod('as.factor', signature(x='RasterLayer'), function(x) { ratify(x) } ) if (!isGeneric("asFactor")) { setGeneric("asFactor", function(x, ...) standardGeneric("asFactor")) } setMethod('asFactor', signature(x='RasterLayer'), function(x, value=NULL, ...) { #warning("please use as.factor") x@data@isfactor <- TRUE if (is.null(value) ) { #x <- round(x) #this makes methods::slot( isfactor FALSE again x@data@attributes <- list(data.frame(VALUE=unique(x))) } else { x@data@attributes <- value } return(x) } ) raster/R/makeProjString.R0000644000176200001440000000336014160021141015025 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .newCRS <- function(projs) { if (is.null(projs)) { prj <- sp::CRS() } else if (is.na(projs)) { prj <- sp::CRS() } else if (nchar(projs) < 3) { prj <- sp::CRS() } else { projs <- trim(projs) prj <- try(sp::CRS(projs), silent = TRUE) if (inherits(prj, "try-error")) { warning(paste(projs, 'is not a valid PROJ.4 crs string')) prj <- sp::CRS() } } return(prj) } .makeProj <- function(projection='longlat', ..., ellipsoid="", datum="", asText=TRUE) { prj <- rgdal::projInfo("proj") ell <- rgdal::projInfo("ellps") dat <- rgdal::projInfo("datum") projection <- trim(projection) ellipsoid <- trim(ellipsoid) datum <- trim(datum) if (!(projection %in% prj[,1])) { stop("unknown projection. See rgdal::projInfo()") } else { pstr <- paste('+proj=',projection, sep="") projname <- as.vector(prj[which(prj[,1]==projection), 2]) } pargs <- list(...) if ( length(pargs) > 0 ) { for (i in 1:length(pargs)) { pstr <- paste(pstr, ' +', pargs[[i]], sep="") } } if (ellipsoid != "") { if (!(ellipsoid %in% ell[,1])) { stop("unknown ellipsoid. See rgdal::projInfo('ellps')") } else { pstr <- paste(pstr, " +ellps=", ellipsoid, sep="") # ellipname <- ell[which(ell[,1]==ellipsoid), 2] } } if (datum != "") { if (!(datum %in% dat[,1])) { stop("unknown datum. See rgdal::projInfo('datum')") } else { pstr <- paste(pstr, " +datum=", datum, sep="") # datumname <- as.vector(dat[which(dat[,1]==datum), 2]) } } # cat("Projection: ", projname[1], "\n") crs <- .newCRS(pstr) if (asText) { return(trim(crs@projargs)) } else { return(crs) } } raster/R/modalRaster.R0000644000176200001440000000220114160021141014334 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 setMethod("modal", signature(x='Raster'), function(x, ..., ties='random', na.rm=FALSE, freq=FALSE){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- .addArgs(...) } else { add <- NULL } nl <- nlayers(x) if (nl < 2) { warning('there is not much point in computing a modal value for a single layer') return(x[[1]]) } else if (nl == 2) { warning('running modal with only two layers!') } out <- raster(x) if (canProcessInMemory(x)) { x <- cbind(getValues(x), add) x <- setValues(out, apply(x, 1, modal, ties=ties, na.rm=na.rm, freq=freq)) return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n, label='modal') out <- writeStart(out, filename="") for (i in 1:tr$n) { v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add) v <- apply(v, 1, modal, ties=ties, na.rm=na.rm, freq=freq) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) writeStop(out) } ) raster/R/getValuesFocal.R0000644000176200001440000000535414160021141014777 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric("getValuesFocal")) { setGeneric("getValuesFocal", function(x, row, nrows, ngb, ...) standardGeneric("getValuesFocal")) } setMethod("getValuesFocal", signature(x='Raster', row='missing', nrows='missing', ngb='numeric'), function(x, ngb, names=FALSE, ...) { getValuesFocal(x, 1, nrow(x), ngb, names=names, ...) }) setMethod("getValuesFocal", signature(x='Raster', row='numeric', nrows='numeric', ngb='numeric'), function(x, row, nrows, ngb, names=FALSE, padValue=NA, array=FALSE, ...) { nl <- nlayers(x) if (nl == 0) { stop("x has no values") } else if (nl > 1) { mm <- list() } xx <- raster(x) nc <- ncol(xx) row <- round(row) nrows <- round(nrows) if (!validRow(xx, row)) { stop("Not a valid row number") } if ( (row+nrows-1) > nrow(xx) ) { stop("'nrows' is too high") } stopifnot(is.atomic(padValue)) geo <- couldBeLonLat(xx) mask <- FALSE if (is.matrix(ngb)) { w <- ngb ngb <- dim(w) w <- ! is.na(as.vector(t(w))) mask <- TRUE } ngb <- .checkngb(ngb, mustBeOdd=TRUE) ngbr <- floor(ngb[1]/2) ngbc <- floor(ngb[2]/2) startrow <- row-ngbr endrow <- row+nrows-1+ngbr sr <- max(1, startrow) # startrow er <- min(endrow, nrow(xx)) if (nl==1) { vv <- matrix(getValues(x, sr, (er-sr+1)), ncol=1) } else { vv <- getValues(x, sr, (er-sr+1)) } for (i in 1:nl) { v <- matrix(vv[,i], ncol=nc, byrow=TRUE) if (sr > startrow) { add <- sr - startrow v <- rbind(matrix(padValue, nrow=add, ncol=ncol(v)), v) } if (endrow > er) { add <- endrow - er v <- rbind(v, matrix(padValue, nrow=add, ncol=ncol(v))) } if (geo) { nv <- ncol(v) if (ngbc < nv) { v <- cbind(v[,(nv-ngbc+1):nv], v, v[,1:ngbc]) } else { stop('horizontal neighbourhood is too big') } } else { add <- matrix(padValue, ncol=ngbc, nrow=nrow(v)) v <- cbind(add, v, add) } v <- .focal_get(as.vector(t(v)), as.integer(dim(v)), as.integer(ngb)) m <- matrix(v, nrow=nrows*nc, byrow=TRUE) if (names) { rownames(m) <- cellFromRowCol(xx, row, 1):cellFromRowCol(xx, row+nrows-1,nc) colnames(m) <- paste('r', rep(1:ngb[1], each=ngb[2]), 'c', rep(1:ngb[2], ngb[1]), sep='') } if (mask) { m <- m[,mask,drop=FALSE] } if (nl == 1) { return(m) } else { mm[[i]] <- m } } if (array) { if (names) { dnms <- list(rownames(mm[[1]]), colnames(mm[[1]]), names(x)) } else { dnms <- list(NULL, NULL, names(x)) } mm <- array(unlist(mm, use.names = FALSE), c(nrow(mm[[1]]), ncol(mm[[1]]), length(mm)), dimnames=dnms ) } else { names(mm) <- names(x) } return(mm) } ) raster/R/blockSize.R0000644000176200001440000000170314160021141014012 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 blockSize <- function(x, chunksize, n=nlayers(x), minblocks=4, minrows=1) { n <- max(n, 1) if (missing(chunksize)) { bs <- .chunk() } else { bs <- chunksize } blockrows <- try(methods::slot(x@file, 'blockrows'), silent=TRUE) if (class(blockrows)[1] == 'try-error') { blockrows <- 1 } blockrows <- max(blockrows, 1) nr <- nrow(x) size <- min(nr, max(1, floor(bs / (ncol(x) * n * 8)))) # min number of chunks if (size > 1) { minblocks <- min(nr, max(1, minblocks)) size <- min(ceiling(nr/minblocks), size) } size <- min(max(size, minrows), nr) size <- max(minrows, blockrows * round(size / blockrows)) nb <- ceiling(nr / size) row <- (0:(nb-1))*size + 1 nrows <- rep(size, length(row)) dif = nb * size - nr nrows[length(nrows)] = nrows[length(nrows)] - dif return(list(row=row, nrows=nrows, n=nb)) } raster/R/focal.R0000644000176200001440000002016614160021141013155 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2011 # Version 1.0 # Licence GPL v3 .checkngb <- function(ngb, mustBeOdd=FALSE) { ngb <- as.integer(round(ngb)) if (length(ngb) == 1) { ngb <- c(ngb, ngb) } else if (length(ngb) > 2) { stop('ngb should be a single value or two values') } if (min(ngb) < 1) { stop("ngb should be larger than 1") } if (mustBeOdd) { if (any(ngb %% 2 == 0)) { stop('neighborhood size must be an odd number') } } return(ngb) } .wwarn <- function() { if (! isTRUE(options('rasterFocalWarningGiven'))) { warning('the computation of the weights matrix has changed in version 2.1-35. The sum of weights is now 1') options(rasterFocalWarningGiven=TRUE) } } .getW <- function(w) { if (length(w) == 1) { w <- round(w) stopifnot(w > 0) w <- matrix(1, ncol=w, nrow=w) w <- w / sum(w) .wwarn() } else if (length(w) == 2) { w <- round(w) w <- matrix(1, ncol=w[1], nrow=w[2]) w <- w / sum(w) .wwarn() } if (! is.matrix(w) ) { stop('w should be a single number, two numbers, or a matrix') } return(w) } setMethod('focal', signature(x='RasterLayer'), function(x, w, fun, filename='', na.rm=FALSE, pad=FALSE, padValue=NA, NAonly=FALSE, ...) { stopifnot(hasValues(x)) # mistakes because of differences with old focal and old focalFilter dots <- list(...) if (!is.null(dots$filter)) { warning('argument "filter" is ignored!') } if (!is.null(dots$ngb)) { warning('argument "ngb" is ignored!') } # w <- .getW(w) stopifnot(is.matrix(w)) d <- dim(w) if (prod(d) == 0) { stop('ncol and nrow of w must be > 0') } if (min(d %% 2) == 0) { stop('w must have uneven sides') } # to get the weights in the (by row) order for the C routine # but keeping nrow and ncol as-is w[] <- as.vector(t(w)) out <- raster(x) filename <- trim(filename) padrows <- FALSE if (pad) { padrows <- TRUE } gll <- as.integer(.isGlobalLonLat(out)) if (gll) { pad <- TRUE } # if (NAonly) { # na.rm <- TRUE # } dofun <- TRUE domean <- FALSE if (missing(fun)) { dofun <- FALSE domean <- FALSE } else { fun2 <- .makeTextFun(fun) if (is.character(fun2)) { if (fun2=='mean') { domean <- TRUE dofun <- FALSE } else if (fun2 == 'sum') { dofun <- FALSE } } } if (dofun) { if (na.rm) { runfun <- function(x) as.double( fun(x, na.rm=TRUE) ) } else { runfun <- function(x) as.double( fun(x) ) } } NAonly <- as.integer(NAonly) narm <- as.integer(na.rm) domean <- as.integer(domean) if (canProcessInMemory(out)) { if (pad) { # this should be done in C, but for now.... f <- floor(d / 2) v <- as.matrix(x) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) } else { if (dofun) { v <- .focal_fun(values(x), w, as.integer(dim(out)), runfun, NAonly) } else { v <- .focal_sum( values(x), w, as.integer(dim(out)), narm, NAonly, domean) } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } } else { out <- writeStart(out, filename,...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label='focal', ...) addr <- floor(nrow(w) / 2) addc <- floor(ncol(w) / 2) nc <- ncol(out) nc1 <- 1:(nc * addc) if (pad) { f <- floor(d / 2) v <- getValues(x, row=1, nrows=tr$nrows[1]+addr) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[ , -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v, 1) pbStep(pb) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr)) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } i <- tr$n v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } else { v <- getValues(x, row=1, nrows=tr$nrows[1]+addr) if (dofun) { v <- .focal_fun(v, w, as.integer(c(tr$nrows[1]+addr, nc)), runfun, NAonly) } else { v <- .focal_sum( v, w, as.integer(c(tr$nrows[1]+addr, nc)), narm, NAonly, domean) } out <- writeValues(out, v, 1) pbStep(pb) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr)) if (dofun) { v <- .focal_fun(v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), runfun, NAonly) } else { v <- .focal_sum( v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), narm, NAonly, domean) } out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } i <- tr$n v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr) if (dofun) { v <- .focal_fun(v, w, as.integer(c(tr$nrows[i]+addr, nc)), runfun, NAonly) } else { v <- .focal_sum( v, w, as.integer(c(tr$nrows[i]+addr, nc)), narm, NAonly, domean) } out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/rasterOptions.R0000644000176200001440000003735314160021141014753 0ustar liggesusers# Author: Robert J. Hijmans # September 2009 # Version 1.0 # Licence GPL v3 rasterOptions <- function(format, overwrite, datatype, tmpdir, tmptime, progress, timer, chunksize, maxmemory, memfrac, todisk, setfileext, tolerance, standardnames, depracatedwarnings, addheader, default=FALSE) { setFiletype <- function(format) { if (.isSupportedFormat(format)) { options(rasterFiletype = format) } else { warning(paste('Cannot set filetype to unknown or unsupported file format:', format, '. See writeFormats()')) } } setOverwrite <- function(overwrite) { if (is.logical(overwrite)) { options(rasterOverwrite = overwrite) } else { warning(paste('Could not set overwrite. It must be a logical value')) } } setDataType <- function(datatype) { if (datatype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT4U', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S')) { options(rasterDatatype = datatype) } else { warning(paste('Cannot set datatype to unknown type:',datatype)) } } setTmpdir <- function(tmpdir) { if (!missing(tmpdir)) { tmpdir <- trim(tmpdir) if (tmpdir != '') { lastchar = substr(tmpdir, nchar(tmpdir), nchar(tmpdir)) if (lastchar != "/" & lastchar != '\\') { tmpdir <- paste(tmpdir, '/', sep='') } #res <- file.exists(substr(tmpdir, 1, nchar(tmpdir)-1)) #if (!res) { # res <- dir.create(tmpdir, recursive=TRUE, showWarnings = FALSE) #} #if (res) { options(rasterTmpDir = tmpdir) #} else { # warning(paste('could not create tmpdir:', tmpdir)) #} } } } setTmpTime <- function(tmptime) { if (is.numeric(tmptime)) { if (tmptime > 1) { options(rasterTmpTime = tmptime) } else { warning(paste('Could not set tmptime. It must be > 1')) } } else { warning(paste('Could not set tmptime. It must be a numerical value')) } } setProgress <- function(progress) { if (is.character(progress)) { progress <- tolower(trim(progress)) if (progress %in% c('window', 'tcltk', 'windows')) { progress <- 'window' } if (! progress %in% c('text', 'window', '')) { warning('invalid value for progress. Should be "window", "text", or ""') } else { options(rasterProgress = progress ) } } else { warning('progress must be a character value') } } setTimer <- function(timer) { if (is.logical(timer)) { options(rasterTimer = timer ) } else { warning(paste('timer must be a logical value')) } } setToDisk <- function(todisk) { if (is.logical(todisk)) { options(rasterToDisk = todisk ) } else { warning(paste('todisk argument must be a logical value')) } } setChunksize <- function(chunksize) { chunksize <- max(1, round(chunksize[1])) #chunksize <- min(chunksize, 10^7) options(rasterChunkSize = chunksize ) } setFileExt <- function(setfileext) { options(rasterSetFileExt = as.logical(setfileext) ) } setMaxMemorySize <- function(maxmemory) { maxmemory = max(10000, round(maxmemory[1])) options(rasterMaxMemory = maxmemory ) } setMemfrac <- function(memfrac) { if (memfrac >= 0.1 & memfrac <= 0.9) { options(rasterMemfrac = memfrac ) } else { warning(paste('memfrac argument must be a value between 0.1 and 0.9')) } } setTolerance <- function(x) { x <- max(0.000000001, min(x, 0.5)) options(rasterTolerance = x) } setStandardNames <- function(x) { if (is.logical(x)) { if (is.na(x)) { x <- TRUE } options(rasterStandardNames = x) } } depracatedWarnings <- function(x) { if (is.logical(x)) { if (is.na(x)) { x <- TRUE } options(rasterDepracatedWarnings = x) } } addHeader <- function(x) { x <- x[1] if (is.character(x)) { x <- toupper(trim(x)) if (nchar(x) < 3) { x <- '' } options(rasterAddHeader = x) } } cnt <- 0 if (default) { cnt <- 1 options(rasterFiletype = 'raster') options(rasterOverwrite = FALSE) options(rasterDatatype = 'FLT4S') options(rasterProgress = 'none') options(rasterTimer = FALSE) options(rasterTmpDir = tmpDir(create=FALSE)) options(rasterTmpTime = 24*7) options(rasterToDisk = FALSE) options(rasterSetFileExt = TRUE) options(rasterChunkSize = 10^9) options(rasterChunk = 10^9) options(rasterMaxMemory = 2e+10) options(rasterMemfrac = 0.6) options(rasterTolerance = 0.1) options(rasterStandardNames = TRUE) options(rasterDepracatedWarnings = TRUE) options(rasterAddHeader = '') v <- utils::packageDescription('raster')[["Version"]] # fn <- paste(options('startup.working.directory'), '/rasterOptions_', v, sep='') # if (file.exists(fn)) { file.remove(fn) } } if (!missing(format)) { setFiletype(format); cnt <- cnt+1 } if (!missing(overwrite)) { setOverwrite(overwrite); cnt <- cnt+1 } if (!missing(datatype)) { setDataType(datatype); cnt <- cnt+1 } if (!missing(progress)) { setProgress(progress); cnt <- cnt+1 } if (!missing(timer)) { setTimer(timer); cnt <- cnt+1 } if (!missing(tmpdir)) { setTmpdir(tmpdir); cnt <- cnt+1 } if (!missing(tmptime)) { setTmpTime(tmptime); cnt <- cnt+1 } if (!missing(todisk)) { setToDisk(todisk); cnt <- cnt+1 } if (!missing(setfileext)) { setFileExt(setfileext); cnt <- cnt+1 } if (!missing(maxmemory)) { setMaxMemorySize(maxmemory); cnt <- cnt+1 } if (!missing(memfrac)) { setMemfrac(memfrac); cnt <- cnt+1 } if (!missing(chunksize)) { setChunksize(chunksize); cnt <- cnt+1 } if (!missing(tolerance)) { setTolerance(tolerance); cnt <- cnt+1 } if (!missing(standardnames)) { setStandardNames(standardnames); cnt <- cnt+1 } if (!missing(depracatedwarnings)) { depracatedWarnings(depracatedwarnings); cnt <- cnt+1 } if (!missing(addheader)) {addHeader(addheader) ; cnt <- cnt+1 } lst <- list( format=.filetype(), overwrite=.overwrite(), datatype=.datatype(), tmpdir= tmpDir(create=FALSE), tmptime=.tmptime(), progress=.progress(), timer=.timer(), chunksize=.chunksize(), maxmemory=.maxmemory(), memfrac = .memfrac(), todisk=.toDisk(), setfileext=.setfileext(), tolerance=.tolerance(), standardnames=.standardnames(), depwarning=.depracatedwarnings(), addheader=.addHeader() ) save <- FALSE if (save) { v <- utils::packageDescription('raster')[["Version"]] fn <- paste(options('startup.working.directory'), '/rasterOptions_', v, sep='') oplst <- NULL oplst <- c(oplst, paste("rasterFiletype='", lst$format, "'", sep='')) oplst <- c(oplst, paste("rasterOverwrite=", lst$overwrite, sep='')) oplst <- c(oplst, paste("rasterDatatype='", lst$datatype, "'", sep='')) oplst <- c(oplst, paste("rasterTmpDir='", lst$tmpdir, "'", sep='')) oplst <- c(oplst, paste("rasterTmpTime='", lst$tmptime, "'", sep='')) oplst <- c(oplst, paste("rasterProgress='", lst$progress, "'", sep='')) oplst <- c(oplst, paste("rasterTimer=", lst$timer, sep='')) oplst <- c(oplst, paste("rasterChunkSize=", lst$chunksize, sep='')) oplst <- c(oplst, paste("rasterMaxMemory=", lst$maxmemory, sep='')) oplst <- c(oplst, paste("rasterMemfrac=", lst$memfrac, sep='')) oplst <- c(oplst, paste("rasterSetFileExt=", lst$setfileext, sep='')) oplst <- c(oplst, paste("rasterTolerance=", lst$tolerance, sep='')) oplst <- c(oplst, paste("rasterStandardNames=", lst$standardnames, sep='')) oplst <- c(oplst, paste("rasterDepracatedWarnings=", lst$depwarning, sep='')) oplst <- c(oplst, paste("rasterAddHeader=", lst$addheader, sep='')) r <- try( write(unlist(oplst), fn), silent = TRUE ) cnt <- 1 } if (cnt == 0) { cat('format :', lst$format, '\n' ) cat('datatype :', lst$datatype, '\n') cat('overwrite :', lst$overwrite, '\n') cat('progress :', lst$progress, '\n') cat('timer :', lst$timer, '\n') cat('chunksize :', lst$chunksize, '\n') cat('maxmemory :', lst$maxmemory, '\n') cat('memfrac :', lst$memfrac, '\n') cat('tmpdir :', lst$tmpdir, '\n') cat('tmptime :', lst$tmptime, '\n') cat('setfileext :', lst$setfileext, '\n') cat('tolerance :', lst$tolerance, '\n') cat('standardnames :', lst$standardnames, '\n') cat('warn depracat.:', lst$depwarning, '\n') if (lst$addheader == '') { cat('header : none\n') } else { cat('header :', lst$addheader, '\n') } if (lst$todisk) { cat('todisk : TRUE\n') } } invisible(lst) } .loadOptions <- function(f) { if (file.exists(f)) { dd <- readLines(f) for (d in dd) { try(eval(parse(text=paste("options(", d, ")")))) } } } .addHeader <- function() { d <- getOption('rasterAddHeader') if (is.null(d)) { return( '' ) } else { return(trim(d)) } } .depracatedwarnings <- function() { d <- getOption('rasterDepracatedWarnings') if (is.null(d)) { return( TRUE ) } else { return(as.logical(d)) } } .dataloc <- function() { d <- getOption('rasterDataDir') if (is.null(d) ) { d <- getwd() } else { d <- trim(d) if (d=='') { d <- getwd() } } return(d) } .tmpdir <- function(...) { tmpDir(...) } tmpDir <- function(create=TRUE) { d <- getOption('rasterTmpDir') if (is.null(d)) { d <- .tmppath() } #lastchar <- substr(d, nchar(d), nchar(d)) # if (lastchar == '/' | lastchar == '\\') { # d <- substr( d, 1, nchar(d)-1 ) #} if (!file.exists(d) & create) { dir.create( d, recursive=TRUE, showWarnings=FALSE ) } return(d) } .setfileext <- function() { d <- getOption('rasterSetFileExt') if (is.null(d)) { return( TRUE ) } return(as.logical(d)) } .tmptime <- function() { d <- getOption('rasterTmpTime') if (is.null(d)) { d <- 24 * 7 } else { d <- as.numeric(d) if (d < 0) { d <- 24 * 7 } } return(d) } .memfrac <- function() { default <- 0.6 d <- getOption('rasterMemfrac') if (is.null(d)) { return( default ) } else { return(d) } } .maxmemory <- function() { default <- 5e+9 d <- getOption('rasterMaxMemory') if (is.null(d)) { return( default ) } d <- round(as.numeric(d[1])) if (is.na(d) | d < 1e+6) { d <- 1e+6 } return(d) } .chunksize <- function(){ default <- 10^8 d <- getOption('rasterChunkSize') if (is.null(d)) { return( default ) } d <- round(as.numeric(d[1])) if (is.na(d) | d < 10000) { d <- default } return(d) } .chunk <- function(){ d <- getOption('rasterChunk') if (is.null(d)) { return( .chunksize() ) } if (is.na(d) | d < 10000) { return( .chunksize() ) } return(d) } .tolerance <- function() { d <- getOption('rasterTolerance') if (is.null(d)) { d <- 0.1 } else { d <- max(0.000000001, min(d, 0.5)) } return(d) } .overwrite <- function(..., overwrite) { if (missing(overwrite)) { overwrite <- getOption('rasterOverwrite') if (is.null(overwrite)) { return(FALSE) } else { if (is.logical(overwrite)) { return(overwrite) } else { return(FALSE) } } } else { if (is.logical(overwrite)) { return(overwrite) } else { return(FALSE) } } } .datatype <- function(..., datatype, dataType) { if (missing(datatype) && !missing(dataType)) { warning('argument "datatype" misspelled as "dataType"') datatype <- dataType } else if (missing(datatype)) { datatype <- getOption('rasterDatatype') if (is.null(datatype)) { return('FLT4S') } } if (! datatype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'INT4U', 'FLT4S', 'FLT8S')) { warning(datatype, ' is an invalid datatype value, changed to "FLT4S"') datatype <- 'FLT4S' } return(datatype) } .getFormat <- function(filename) { ext <- tolower(extension(filename, maxchar=5)) if (nchar(ext) < 3) { return('') } else { if (ext == '.tif' | ext == '.tiff') { return('GTiff') } else if (ext == '.grd') { return('raster') } else if (ext == '.asc') { return('ascii') } else if (ext == '.nc' | ext == '.cdf' | ext == '.ncdf') { return('CDF') } else if (ext == '.kml') { return('KML') } else if (ext == '.kmz') { return('KML') # } else if (ext == '.big') { return('big.matrix') } else if (ext == '.sgrd') { return('SAGA') } else if (ext == '.sdat') { return('SAGA') } else if (ext == '.bil') { return('BIL') } else if (ext == '.bsq') { return('BSQ') } else if (ext == '.bip') { return('BIP') } else if (ext == '.bmp') { return('BMP') } else if (ext == '.gen') { return('ADRG') } else if (ext == '.bt') { return('BT') } else if (ext == '.envi') { return('ENVI') } else if (ext == '.ers') { return('ERS') } else if (ext == '.img') { return( 'HFA') } else if (ext == '.rst') { return('RST') } else if (ext == '.mpr') { return('ILWIS') } else if (ext == '.rsw') { return('RMF') } else if (ext == '.flt') { return('EHdr') } else { warning('extension ', ext, ' is unknown. Using default format.') return('') } } } .filetype <- function(format, filename='', ...) { if (missing(format)) { format <- .getFormat(filename) if (format != '') { return(format) } format <- getOption('rasterFiletype') if (is.null(format)) { return('raster') } else { return(format) } } else { return(format) } } .progress <- function(..., progress) { if (missing(progress)) { progress <- getOption('rasterProgress') if (is.null(progress)) { return('none') } else { if (is.character(progress)) { if (progress[1] %in% c('text', 'window', 'tcltk', 'windows')) { return(progress[1]) } else { return('none') } } else { return('none') } } } else { if (is.character(progress)) { if (progress[1] %in% c('text', 'window', 'tcltk', 'windows')) { return(progress[1]) } else { return('none') } } else { return('none') } } } .timer <- function(..., timer) { if (missing(timer)) { timer <- getOption('rasterTimer') if (is.null(timer)) { return(FALSE) } else { return( as.logical(timer) ) } } else { return(as.logical(timer)) } } .standardnames <- function(..., standardnames) { if (missing(standardnames)) { standardnames <- getOption('rasterStandardNames') if (is.null(standardnames)) { return(TRUE) # the default } else { try (todisk <- as.logical(standardnames)) if (is.logical(standardnames)) { return(standardnames) } else { return(TRUE) } } } else { if (is.logical(todisk)) { return(todisk) } else { return(TRUE) } } } .toDisk <- function(..., todisk) { if (missing(todisk)) { todisk <- getOption('rasterToDisk') if (is.null(todisk)) { return(FALSE) # the default } else { try (todisk <- as.logical(todisk)) if (is.logical(todisk)) { return(todisk) } else { return(FALSE) } } } else { if (is.logical(todisk)) { return(todisk) } else { return(FALSE) } } } .usecluster <- function(...) { usecluster <- list(...)$usecluster if (is.null(usecluster)) { usecluster <- getOption('rasterUseCluster') if (is.null(usecluster)) { return(FALSE) # the default } else { try (usecluster <- as.logical(usecluster), silent=TRUE) if (isTRUE(usecluster)) { return(TRUE) } else { return(FALSE) } } } else { if (is.logical(usecluster)) { return(usecluster) } else { return(FALSE) } } } .removeRasterOptions <- function(x) { y <- list() for (i in seq(along.with=x)) { if (!trim(x[[i]]) == "# Options for the 'raster' package" & !substr(trim(x[[i]]),1,14) == 'options(raster') { y <- c(y, x[[i]]) } } return(y) } .tmppath <- function() { file.path(tempdir(), 'raster', '/') } raster/R/plotRaster.R0000644000176200001440000000404214160021141014223 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 0.9 # Licence GPL v3 .plotraster <- function(object, col=rev(terrain.colors(25)), maxpixels=100000, axes=TRUE, xlab='', ylab='', ext=NULL, asp, xlim, ylim, add=FALSE, addfun=NULL, main, ...) { if (missing(asp)) { if (couldBeLonLat(object, warnings=FALSE)) { # ym <- mean(object@extent@ymax + object@extent@ymin) # asp <- min(5, 1/cos((ym * pi)/180)) asp = NA } else { asp = 1 } } if (missing(main)) { main <- '' #names(object)[1] } if ( ! inMemory(object) ) { if ( ! fromDisk(object) ) { stop('no values associated with this RasterLayer') } } maxpixels <- max(1, maxpixels) if (is.null(ext)) { e <- extent(object) } else { e <- ext <- intersect(extent(object), ext) } if (! missing(xlim) | ! missing(ylim )) { if (!missing(xlim)) { if (xlim[1] >= xlim[2]) stop('invalid xlim') if (xlim[1] < e@xmax) e@xmin <- xlim[1] if (xlim[2] > e@xmin) e@xmax <- xlim[2] } if (!missing(ylim)) { if (ylim[1] >= ylim[2]) stop('invalid ylim') if (ylim[1] < e@ymax) e@ymin <- ylim[1] if (ylim[2] > e@ymin) e@ymax <- ylim[2] } } leg <- object@legend object <- sampleRegular(object, size=maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) x <- (0:ncol(object)) * xres(object) + xmin(object) y <- (0:nrow(object)) * yres(object) + ymin(object) if (length(leg@color) > 0) { breaks <- leg@values object <- cut(object, breaks) col <- leg@color lab.breaks <- as.character(breaks) } z <- t(as.matrix(object)[object@nrows:1,]) if (nrow(z) == 1 | ncol(z) == 1) z <- t(z) z[is.infinite(z)] <- NA if (length(leg@color) > 0) { .imageplot(x, y, z, col=col, axes=axes, xlab=xlab, ylab=ylab, asp=asp, breaks=breaks, lab.breaks=lab.breaks, add=add, main=main, ...) } else { .imageplot(x, y, z, col=col, axes=axes, xlab=xlab, ylab=ylab, asp=asp, add=add, main=main, ...) } if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } } raster/R/union_sp.R0000644000176200001440000000433114160214755013736 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod('union', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) x <- sp::spChFIDs(x, as.character(1:length(x))) y <- sp::spChFIDs(y, as.character(1:length(y))) prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- .CRS(as.character(NA)) y@proj4string <- .CRS(as.character(NA)) subs <- rgeos::gIntersects(x, y, byid=TRUE) if (!any(subs)) { x <- bind(x, y) } else { xdata <-.hasSlot(x, 'data') ydata <-.hasSlot(y, 'data') if (xdata & ydata) { nms <- .goodNames(c(colnames(x@data), colnames(y@data))) colnames(x@data) <- nms[1:ncol(x@data)] colnames(y@data) <- nms[(ncol(x@data)+1):length(nms)] } dif1 <- erase(x, y) dif2 <- erase(y, x) x <- intersect(x, y) x <- list(dif1, dif2, x) x <- x[!sapply(x, is.null)] i <- sapply(x, length) > 0 x <- x[ i ] if (length(x) > 1) { x <- do.call(bind, x) } else { x <- x[[1]] } } if (inherits(x, "Spatial")) { x@proj4string <- prj } x } ) setMethod('union', signature(x='SpatialPolygons', y='missing'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) n <- length(x) if (n < 2) { return(x) } prj <- x@proj4string x@proj4string <- .CRS(as.character(NA)) #if (!rgeos::gIntersects(x)) { # this is a useful test, but returned topologyerrors # return(x) #} if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPolygons') } x <- sp::spChFIDs(x, as.character(1:length(x))) x <- sp::SpatialPolygonsDataFrame(x, data.frame(ID=1:n)) u <- x[1,] names(u) <- 'ID.1' for (i in 2:n) { z <- x[i, ] names(z) <- paste('ID.', i, sep='') u <- union(u, z) } u@data[!is.na(u@data)] <- 1 u@data[is.na(u@data)] <- 0 u$count <- rowSums(u@data) u@proj4string <- prj u } ) setMethod('union', signature(x='SpatialPoints', y='SpatialPoints'), function(x, y) { bind(x,y) }) setMethod('union', signature(x='SpatialLines', y='SpatialLines'), function(x, y) { bind(x,y) }) raster/R/AAAClasses.R0000644000176200001440000001243714160021141013773 0ustar liggesusers# R classes for raster (grid) type spatial data # Robert J. Hijmans # November 2008 # Version 1.0 # Licence GPL v3 setClass("Extent", representation ( xmin = "numeric", xmax = "numeric", ymin = "numeric", ymax = "numeric" ), prototype ( xmin = 0, xmax = 1, ymin = 0, ymax = 1 ), validity = function(object) { c1 <- (object@xmin <= object@xmax) c2 <- (object@ymin <= object@ymax) # fix to not break dependencies if (is.na(c1)) c1 <- TRUE if (is.na(c2)) c2 <- TRUE if (!c1) { stop("invalid extent: xmin >= xmax") } if (!c2) { stop("invalid extent: ymin >= ymax") } return(c1 & c2) # fix to not break dependencies #v <- c(object@xmin, object@xmax, object@ymin, object@ymax) #c3 <- all(!is.infinite(v)) #if (!c3) { stop("invalid extent: infinite value") } #return(c1 & c2 & c3) } ) setClass(".Rotation", representation ( geotrans = "numeric", transfun = "function" ) ) setClass ("BasicRaster", representation ( title = "character", extent = "Extent", rotated = "logical", rotation = ".Rotation", ncols ="integer", nrows ="integer", crs = "CRS", #srs = "character", #srs = ".RasterSRS", history = "list", #meta = "list", z = "list" ), prototype ( crs = sp::CRS(doCheckCRSArgs=FALSE), rotated = FALSE, ncols= as.integer(1), nrows= as.integer(1), history = list(), #meta = list(), z = list() ), validity = function(object) { methods::validObject(extent(object)) c1 <- (object@ncols > 0) if (!c1) { stop("ncols < 1") } c2 <- (object@nrows > 0) if (!c2) { stop("nrows < 1") } return(c1 & c2) } ) setClass ("Raster", contains = c("BasicRaster", "VIRTUAL") ) setClass(".RasterFile", representation ( name ="character", datanotation="character", byteorder ="character", nodatavalue ="numeric", # on disk, in ram it is NA NAchanged ="logical", nbands ="integer", bandorder ="character", offset="integer", toptobottom="logical", blockrows="integer", blockcols="integer", driver ="character", open = "logical" ), prototype ( name = "", datanotation="FLT4S", byteorder = .Platform$endian, nodatavalue = -Inf, NAchanged = FALSE, nbands = as.integer(1), bandorder = "BIL", offset = as.integer(0), toptobottom = TRUE, blockrows = as.integer(0), blockcols= as.integer(0), driver = "", open = FALSE ), validity = function(object) { c1 <- object@datanotation %in% c("LOG1S", "INT1S", "INT2S", "INT4S", "INT1U", "INT2U", "FLT4S", "FLT8S") return(c1) } ) setClass(".SingleLayerData", representation ( values="vector", offset="numeric", gain="numeric", inmemory="logical", fromdisk="logical", isfactor = "logical", attributes = "list", haveminmax = "logical", min = "vector", max = "vector", band = "integer", unit = "character", names = "vector" ), prototype ( values=vector(), offset=0, gain=1, inmemory=FALSE, fromdisk=FALSE, isfactor = FALSE, attributes = list(), haveminmax = FALSE, min = c(Inf), max = c(-Inf), band = as.integer(1), unit = "", names=c("") ), validity = function(object) { } ) setClass (".RasterLegend", representation ( type = "character", values = "vector", color = "vector", names = "vector", colortable = "vector" ), prototype ( ) ) setClass ("RasterLayer", contains = "Raster", representation ( file = ".RasterFile", data = ".SingleLayerData", legend = ".RasterLegend" ) ) setClass(".MultipleRasterData", representation ( values="matrix", offset="numeric", gain="numeric", inmemory="logical", fromdisk="logical", nlayers="integer", dropped = "vector", isfactor = "logical", attributes = "list", haveminmax = "logical", min = "vector", max = "vector", unit = "vector", names= "vector" ), prototype ( values=matrix(NA,0,0), offset=0, gain=1, #indices =vector(mode="numeric"), inmemory=FALSE, fromdisk=FALSE, nlayers=as.integer(0), dropped=NULL, isfactor = FALSE, attributes = list(), haveminmax = FALSE, min = c(Inf), max = c(-Inf), unit = c(""), names = c("") ), validity = function(object) { } ) setClass ("RasterBrick", contains = "Raster", representation ( file = ".RasterFile", data = ".MultipleRasterData", legend = ".RasterLegend" ) ) setClass ("RasterStack", contains = "Raster", representation ( filename ="character", layers ="list" ), prototype ( filename="", layers = list() ), validity = function(object) { if (length(object@layers) > 1) { cond <- compareRaster(object@layers, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE) } else { cond <- TRUE } return(cond) } ) setClassUnion("RasterStackBrick", c("RasterStack", "RasterBrick")) setClassUnion("SpatialVector", c("SpatialPoints", "SpatialLines", "SpatialPolygons")) setClass (".RasterList", contains = "list", representation (), prototype (), validity = function(object) { s <- sapply(object, function(x) inherits(x, "Raster")) return( sum(s) == length(s)) } ) raster/R/sf.R0000644000176200001440000000124714160021141012500 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2017 # Version 1.0 # Licence GPL v3 .sf2sp <- function(from) { #if (!requireNamespace("sf")) { # stop("package sf is not available") #} # to do #if (from == "GEOMETRYCOLLECTION") { # x <- list() # for (i in 1:3 ) { } # return(x) #} p <- as(from, "Spatial") if (isTRUE(ncol(p) == 0)) { # for the degenerate Spatial*DataFrame that has zero variables if (inherits(p, "SpatialPolygons")) { p <- as(p, "SpatialPolygons") } else if (inherits(p, "SpatialLines")) { p <- as(p, "SpatialLines") } else if (inherits(p, "SpatialPoints")) { p <- as(p, "SpatialPoints") } } p } raster/R/extension.R0000644000176200001440000000534314160021141014105 0ustar liggesusers# return or change file extensions # Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 extension <- function(filename, value=NULL, maxchar=10) { if (!is.null(value)) { extension(filename) <- value return(filename) } lfn <- nchar(filename) ext <- list() for (f in 1:length(filename)) { extstart <- -1 for (i in lfn[f] : 2) { if (substr(filename[f], i, i) == ".") { extstart <- i break } } if (extstart > 0) { ext[f] <- substr(filename[f], extstart, lfn[f]) } else { ext[f] <- "" } } ext <- unlist(ext) ext[nchar(ext) > maxchar] <- '' return(ext) } 'extension<-' <- function(filename, value) { value <- trim(value) if (value != "" & substr(value, 1, 1) != ".") { value <- paste(".", value, sep="") } lfn <- nchar(filename) fname <- list() for (f in 1:length(filename)) { extstart <- -1 for (i in lfn[f] : 2) { if (substr(filename[f], i, i) == ".") { extstart <- i break } } if (extstart > 0 & (lfn[f] - extstart) < 8) { fname[f] <- paste(substr(filename[f], 1, extstart-1), value, sep="") } else { fname[f] <- paste(filename[f], value, sep="") } } return( unlist(fname) ) } .getExtension <- function(f, format) { if (.setfileext()) { def <- .defaultExtension(format, f) if (def != '') { extension(f) <- def } } return(f) } .defaultExtension <- function(format=.filetype(), filename="") { format <- toupper(format) if (format == 'RASTER') { return('.grd') } else if (format == 'GTIFF') { e <- extension(filename) if (tolower(e) %in% c(".tiff", ".tif")) { return (e) } else { return('.tif') } } else if (format == 'CDF') { return('.nc') } else if (format == 'KML') { return('.kml') } else if (format == 'KMZ') { return('.kmz') # } else if (format == 'BIG.MATRIX') { return('.big') } else if (format == 'BIL') { return('.bil') } else if (format == 'BSQ') { return('.bsq') } else if (format == 'BIP') { return('.bip') } else if (format == 'ASCII') { return('.asc') } else if (format == 'RST') { return('.rst') } else if (format == 'ILWIS') { return('.mpr') } else if (format == 'SAGA') { return('.sdat') } else if (format == 'BMP') { return('.bmp') } else if (format == 'ADRG') { return('.gen') } else if (format == 'BT') { return('.bt') } else if (format == 'EHdr') { return('.bil') } else if (format == 'ENVI') { return('.envi') } else if (format == 'ERS') { return('.ers') } else if (format == 'GSBG') { return('.grd') } else if (format == 'HFA') { return( '.img') } else if (format == 'IDA') { return( '.img') } else if (format == 'RMF') { return('.rsw') } else { return('') } } raster/R/as.data.frame.R0000644000176200001440000000530514160021141014473 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2011 # Version 1.0 # Licence GPL v3 .insertColsInDF <- function(x, y, col, combinenames=TRUE) { cnames <- NULL if (combinenames) { if (ncol(y) > 1) { cnames <- paste(colnames(x)[col], '_', colnames(y), sep='') } } if (ncol(y) == 1) { x[, col] <- y return(x) } else if (col==1) { z <- cbind(y, x[, -1, drop=FALSE]) } else if (col==ncol(x)) { z <- cbind(x[, -ncol(x), drop=FALSE], y) } else { z <- cbind(x[,1:(col-1), drop=FALSE], y, x[,(col+1):ncol(x), drop=FALSE]) } if (!is.null(cnames)) { colnames(z)[col:(col+ncol(y)-1)] <- cnames } z } setMethod('as.data.frame', signature(x='Raster'), function(x, row.names = NULL, optional = FALSE, xy=FALSE, na.rm=FALSE, long=FALSE, ...) { if (!canProcessInMemory(x, 4) & na.rm) { r <- raster(x) ncx <- ncol(r) tr <- blockSize(x) pb <- pbCreate(tr$n, label='as.data.frame', ...) x <- readStart(x) v <- NULL for (i in 1:tr$n) { start <- (tr$row[i]-1) * ncx + 1 end <- start + tr$nrows[i] * ncx - 1 vv <- cbind(start:end, getValues(x, row=tr$row[i], nrows=tr$nrows[i])) if (xy) { vv <- cbind(vv, data.frame(xyFromCell(r, start:end))) } vv <- stats::na.omit(vv) v <- rbind(v, vv) pbStep(pb, i) } x <- readStop(x) } else { v <- getValues(x) if (xy) { XY <- data.frame(xyFromCell(x, 1:ncell(x))) v <- cbind(XY, v) } if (na.rm) { v <- stats::na.omit(cbind(1:ncell(x), v)) } } v <- as.data.frame(v, row.names=row.names, optional=optional, ...) if (na.rm) { rownames(v) <- as.character(v[,1]) v <- v[,-1,drop=FALSE] } if (nlayers(x) == 1) { colnames(v)[ncol(v)] <- names(x) # for nlayers = 1 } i <- is.factor(x) if (any(is.factor(x))) { if (ncol(v) == 1) { v <- data.frame( factorValues(x, v[,1], 1)) # j <- which(sapply(v, is.character)) # if (length(j) > 0) { # for (jj in j) { # v[, jj] <- as.factor(v[,jj]) # } # } } else { nl <- nlayers(x) if (ncol(v) > nl) { rnge1 <- 1:(ncol(v)-nl) rnge2 <- (ncol(v)-nl+1):ncol(v) v <- cbind(v[, rnge1], .insertFacts(x, v[, rnge2, drop=FALSE], 1:nl)) } else { v <- .insertFacts(x, v, 1:nl) } } } if (long) { nc <- (ncol(v) - nlayers(x) + 1):ncol(v) times <- getZ(x) timevar <- 'Z' if (is.null(times)) { times <- names(x) timevar <- 'layer' } v <- stats::reshape(v, direction='long', varying=nc, v.names='value', timevar=timevar, times=times) v[ncol(v)] = NULL # id column rownames(v) <- NULL #v$layer <- names(x)[v$layer] } v } ) raster/R/modal.R0000644000176200001440000000272614160021141013167 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011, May 2015 # Version 1.0 # Licence GPL v3 setMethod('modal', signature(x='ANY'), function(x, ..., ties='random', na.rm=FALSE, freq=FALSE) { dots <- list(...) if ( length(dots) > 0 ) { # change fact to char because # c(x, ...) would change it to integers # and levels would a mess too with multiple objects if (is.factor(x)) { x <- as.character(x) dots <- unlist(lapply(dots, as.character)) } x <- c(x, unlist(dots)) } # NA itself cannot be the modal value # perhaps that should be allowed as an option z <- x[!is.na(x)] if (length(z) == 0) { return(NA) } else if (!na.rm & length(z) < length(x)) { return(NA) } if (freq) { if (length(z) == 1) { return(1) } else { return(max( table(z) )) } } ties <- match(ties[1], c('lowest', 'highest', 'first', 'random', 'NA')) - 1 if (is.na(ties)) { stop("the value of 'ties' should be 'lowest', 'highest', 'first', 'random' or 'NA'") } if (length(z) == 1) { return(z) } else if (is.numeric(z)) { w <- .getMode(z, ties=ties) } else if (is.logical(z)) { w <- as.logical(.getMode(z, ties=ties)) } else if (is.factor(z)) { w <- .getMode(z, ties=ties) w <- levels(z)[w] w <- factor(w, levels=levels(z)) } else { # character, perhaps others? z <- as.factor(z) w <- .getMode(z, ties=ties) w <- levels(z)[w] } return(w) } ) raster/R/rasterFromSurferFile.R0000644000176200001440000000640014160021141016177 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 .isSurferFile <- function(filename, version=FALSE) { con <- file(filename, "rb") id <- readBin(con, "character", n=1, size=4) close(con) if (id == 'DSBB') { if (version) { return(6) } else { return (TRUE) } } con <- file(filename, "rb") id <- readBin(con, "numeric", n=1, size=4) close(con) if (id == as.numeric(0x42525344)) { if (version) { return(7) } else { return (TRUE) } } else { return (FALSE) } } .rasterFromSurferFile <- function(filename) { v <- .isSurferFile(filename, TRUE) if (v == 6) { return ( .rasterFromSurfer6(filename) ) } else if (v == 7) { return ( .rasterFromSurfer7(filename) ) } else { stop ('not a (recognized) binary Surfer file') } } .rasterFromSurfer6 <- function(filename) { con <- file(filename, "rb") r <- raster() id <- readBin(con, "character", n=1, size=4) r@ncols <- readBin(con, "int", n=1, size=2) r@rows <- readBin(con, "int", n=1, size=2) r@extent@xmin <- readBin(con, "double", n=1, size=8) r@extent@xmax <- readBin(con, "double", n=1, size=8) r@extent@ymin <- readBin(con, "double", n=1, size=8) r@extent@ymax <- readBin(con, "double", n=1, size=8) r@data@min <- readBin(con, "double", n=1, size=8) r@data@max <- readBin(con, "double", n=1, size=8) close(con) r@file@offset <- 56 r@file@toptobottom <- FALSE dataType(r) <- 'FLT4S' r@data@fromdisk <- TRUE r@file@driver <- "surfer" return(r) } .rasterFromSurfer7 <- function(filename) { # source: http://www.geospatialdesigns.com/surfer7_format.htm con <- file(filename, "rb") r <- raster() id <- readBin(con, "numeric", n=1, size=4) size <- readBin(con, "numeric", n=1, size=4) offset <- size + 8 seek(con, size, origin = "current") id <- readBin(con, "numeric", n=1, size=4) if (id != as.numeric(0x44495247)) { # should be 0x44495247 grid section # get size and skip to the next section stop('file with this section not yet supported') } size <- readBin(con, "numeric", n=1, size=4) offset <- offset + size + 8 r@rows <- as.integer(readBin(con, "numeric", n=1, size=4)) r@cols <- as.integer(readBin(con, "numeric", n=1, size=4)) r@extent@xmin <- readBin(con, "double", n=1, size=8) r@extent@ymin <- readBin(con, "double", n=1, size=8) xr <- readBin(con, "double", n=1, size=8) yr <- readBin(con, "double", n=1, size=8) r@extent@xmax <- r@extent@xmin + xr * r@cols r@extent@ymax <- r@extent@ymin + yr * r@rows r@data@min <- readBin(con, "double", n=1, size=8) r@data@max <- readBin(con, "double", n=1, size=8) rotation <- readBin(con, "double", n=1, size=8) if (rotation != 0) { stop('rotation != 0, cannot use this file') } r@data@max <- readBin(con, "double", n=1, size=8) r@file@nodatavalue <- readBin(con, "double", n=1, size=8) id <- readBin(con, "numeric", n=1, size=4) size <- readBin(con, "numeric", n=1, size=4) close(con) r@file@offset <- offset + 8 r@file@toptobottom <- FALSE if (ncell(r) / size == 4) { dataType(r) <- 'FLT4S' } else if (ncell(r) / size == 8) { dataType(r) <- 'FLT8S' } else { stop('sorry; cannot process this file') } r@file@driver <- "surfer" return(r) } raster/R/focalFun.R0000644000176200001440000000316414160021141013625 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2014 # Version 1.0 # Licence GPL v3 #if ( !isGeneric("focalFun") ) { # setGeneric("focalFun", function(x, ...) # standardGeneric("focalFun")) #} #setMethod('focalFun', signature(x='Raster'), .focalFun <- function(x, fun, ngb=5, filename='', ...) { out <- raster(x) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) if (canProcessInMemory(x)) { v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE) v <- parallel::parApply(cl, v, 1, fun) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='focalFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE) v <- parallel::parApply(cl, v, 1, fun) out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } else { if (canProcessInMemory(x)) { v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE) v <- apply(v, 1, fun) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='focalFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE) v <- apply(v, 1, fun) out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } #) raster/R/pairs.R0000644000176200001440000000212614160021141013203 0ustar liggesusers setMethod('pairs', signature(x='RasterStackBrick'), function(x, hist=TRUE, cor=TRUE, use="pairwise.complete.obs", maxpixels=100000, ...) { panelhist <- function(x,...) { usr <- graphics::par("usr"); on.exit(graphics::par(usr)) graphics::par(usr = c(usr[1:2], 0, 1.5) ) h <- hist(x, plot = FALSE) breaks <- h$breaks nB <- length(breaks) y <- h$counts y <- y/max(y) graphics::rect(breaks[-nB], 0, breaks[-1], y, col="green") } panelcor <- function(x, y,...) { usr <- graphics::par("usr") on.exit(graphics::par(usr)) graphics::par(usr = c(0, 1, 0, 1)) r <- abs(stats::cor(x, y, use=use)) txt <- format(c(r, 0.123456789), digits=2)[1] text(0.5, 0.5, txt, cex = max(0.5, r * 2)) } if (hist) {dp <- panelhist} else {dp <- NULL} if (cor) {up <- panelcor} else {up <- NULL} d <- sampleRegular(x, maxpixels) dots <- list(...) cex <- dots$cex main <- dots$main if (is.null(cex)) cex <- 0.5 if (is.null(main)) main <- '' pairs(d, main=main, cex=cex, upper.panel=up, diag.panel=dp) } ) raster/R/writeAllRaster.R0000644000176200001440000000445014160021141015033 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 ..writeRasterAll <- function(x, filename, NAflag, filetype, ... ) { x@file@driver <- filetype filename <- trim(filename) fnamevals <- .setFileExtensionValues(filename, filetype) fnamehdr <- .setFileExtensionHeader(filename, filetype) if (filetype == 'raster') { filename <- fnamehdr } else { filename <- fnamevals } x@file@name <- filename overwrite <- .overwrite(...) if (!overwrite & (file.exists(fnamehdr) | file.exists(fnamevals))) { stop(paste(filename,"exists. Use 'overwrite=TRUE' if you want to overwrite it")) } na <- is.nan(x@data@values) | is.infinite(x@data@values) if (any(na)) { x@data@values[na] <- NA } x <- setMinMax(x) datatype <- .datatype(...) if (filetype == 'SAGA') { if (datatype == 'FLT8S') { datatype = 'FLT4S' } } dtype <- .shortDataType(datatype) dataType(x) <- datatype if (missing(NAflag) ) { NAflag <- x@file@nodatavalue } mn <- minValue(x) mx <- maxValue(x) if (dtype == 'INT' ) { #datatype <- .checkIntDataType(mn, mx, datatype) dataType(x) <- datatype NAflag <- as.integer(round(NAflag)) if (substr(datatype, 5 , 5) == 'U') { x@data@values[x@data@values < 0] <- NA if (datatype == 'INT4U') { x@data@values[is.na(x@data@values)] <- NAflag #i <- x@data@values > 2147483647 & !is.na( x@data@values ) #x@data@values[i] <- 2147483647 - x@data@values[i] } else { x@data@values[is.na(x@data@values)] <- NAflag } } else { x@data@values[is.na(x@data@values)] <- NAflag } x@data@values <- as.integer(round( x@data@values )) x@data@min <- round(x@data@min) x@data@max <- round(x@data@max) } else if ( dtype =='FLT') { x@data@values <- as.numeric(x@data@values) if (filetype != 'raster') { x@data@values[is.na(x@data@values)] <- NAflag } } else if ( dtype =='LOG') { x@data@values <- as.integer(x@data@values) x@data@values[is.na(x@data@values)] <- as.integer(x@file@nodatavalue) } dsize <- dataSize(x@file@datanotation) filecon <- file(fnamevals, "wb") writeBin(x@data@values , filecon, size = dsize ) close(filecon) x@file@nodatavalue <- NAflag hdr(x, filetype) return(raster(filename, native=TRUE)) } raster/R/getValuesRows.R0000644000176200001440000000454114160021141014702 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='numeric'), function(x, row, nrows) { for (i in 1:nlayers(x)) { if (i==1) { v <- getValues(x@layers[[i]], row, nrows) res <- matrix(ncol=nlayers(x), nrow=length(v)) res[,1] <- v } else { res[,i] <- getValues(x@layers[[i]], row, nrows) } } colnames(res) <- names(x) res } ) setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='numeric'), function(x, row, nrows, format='') { row <- round(row) nrows <- round(nrows) stopifnot(validRow(x, row)) stopifnot(nrows > 0) row <- min(x@nrows, max(1, row)) endrow <- max(min(x@nrows, row+nrows-1), row) nrows <- endrow - row + 1 if (inMemory(x)){ startcell <- cellFromRowCol(x, row, 1) endcell <- cellFromRowCol(x, row+nrows-1, x@ncols) v <- x@data@values[startcell:endcell] } else if ( fromDisk(x) ) { v <- .readRasterLayerValues(x, row, nrows) } else { v <- rep(NA, nrows * x@ncols) } if (format=='matrix') { v <- matrix(v, nrow=nrows, byrow=TRUE) rownames(v) <- row:(row+nrows-1) colnames(v) <- 1:ncol(v) } return(v) } ) setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='numeric'), function(x, row, nrows) { if (! validRow(x, row)) { stop(row, ' is not a valid rownumber') } row <- min(x@nrows, max(1, round(row))) endrow <- max(min(x@nrows, row+round(nrows)-1), row) nrows <- endrow - row + 1 if ( inMemory(x) ){ startcell <- cellFromRowCol(x, row, 1) endcell <- cellFromRowCol(x, row+nrows-1, x@ncols) res <- x@data@values[startcell:endcell, ,drop=FALSE] } else if (fromDisk(x)) { res <- .readRasterBrickValues(x, row, nrows) } else { res <- matrix(NA, nrow=nrows*ncol(x), ncol=nlayers(x)) } colnames(res) <- names(x) res } ) raster/R/symdif.R0000644000176200001440000000136214160241444013373 0ustar liggesusers# Author: Robert J. Hijmans # Date: December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric('symdif')) { setGeneric('symdif', function(x, y, ...) standardGeneric('symdif')) } setMethod('symdif', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ...) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) haswarned <- FALSE yy <- list(y, ...) for (y in yy) { if (! identical( .proj4string(x), .proj4string(y)) ) { if (!haswarned) { warning('non identical crs') haswarned <- TRUE } y@proj4string <- x@proj4string } if (rgeos::gIntersects(x, y)) { part1 <- erase(x, y) part2 <- erase(y, x) x <- bind(part1, part2) } } x } ) raster/R/predict.R0000644000176200001440000001501014160021141013513 0ustar liggesusers# Author: Robert J. Hijmans # Date : August 2009 # Version 0.9 # Licence GPL v3 setMethod('predict', signature(object='Raster'), function(object, model, filename="", fun=predict, ext=NULL, const=NULL, index=1, na.rm=TRUE, inf.rm=FALSE, factors=NULL, format, datatype, overwrite=FALSE, progress="", ...) { filename <- trim(filename) if (missing(format)) { format <- .filetype(filename=filename) } if (missing(datatype)) { datatype <- .datatype() } if ( ! hasValues(object) ) { stop('No values associated with this Raster object') } if (inherits(model, 'DistModel')) { # models defined in package 'dismo' return ( predict(model, object, filename=filename, ext=ext, progress=progress, format=format, overwrite=overwrite, ...) ) } if (length(index) > 1) { predrast <- brick(object, values=FALSE, nl=length(index)) } else { predrast <- raster(object) } if (!is.null(ext)) { predrast <- crop(predrast, extent(ext)) firstrow <- rowFromY(object, yFromRow(predrast, 1)) firstcol <- colFromX(object, xFromCol(predrast, 1)) } else { firstrow <- 1 firstcol <- 1 } ncols <- ncol(predrast) if (ncol(predrast) < ncol(object)) { gvb <- TRUE } else { gvb <- FALSE } lyrnames <- names(object) haveFactor <- FALSE facttest <- TRUE if (!is.null(factors)) { stopifnot(is.list(factors)) f <- names(factors) if (any(trimws(f) == "")) { stop("all factors must be named") } } else { if (inherits(model, "randomForest")) { f <- names(which(sapply(model$forest$xlevels, max) != "0")) if (length(f) > 0) { factors <- model$forest$xlevels[f] } } else if (inherits(model, "gbm")) { dafr <- model$gbm.call$dataframe vars <- model$gbm.call$gbm.x dafr <- dafr[,vars] i <- sapply(dafr, is.factor) if (any(i)) { j <- which(i) factors <- list() for (k in 1:length(j)) { factors[[k]] <- levels(dafr[[ j[k] ]]) } f <- colnames(dafr)[j] } } else { #glm and others try(factors <- model$xlevels, silent=TRUE) f <- names(factors) } } if (length(factors) > 0) { haveFactor <- TRUE lyrnamesc <- c(lyrnames, names(const)) if (!all(f %in% lyrnamesc)) { ff <- f[!(f %in% lyrnamesc)] warning(paste("factor name(s):", paste(ff, collapse=", "), " not in layer names")) f[(f %in% lyrnamesc)] } } constnames <- names(const) if (!canProcessInMemory(predrast) && filename == '') { filename <- rasterTmpFile() } if (filename == "") { v <- matrix(NA, ncol=nlayers(predrast), nrow=ncell(predrast)) } else { predrast <- writeStart(predrast, filename=filename, format=format, datatype=datatype, overwrite=overwrite ) } tr <- blockSize(predrast, n=nlayers(predrast)+3) napred <- matrix(rep(NA, ncol(predrast) * tr$nrows[1] * nlayers(predrast)), ncol=nlayers(predrast)) factres <- FALSE pb <- pbCreate(tr$n, progress=progress, label="predict") for (i in 1:tr$n) { if (i==tr$n) { ablock <- 1:(ncol(object) * tr$nrows[i]) napred <- matrix(rep(NA, ncol(predrast) * tr$nrows[i] * nlayers(predrast)), ncol=nlayers(predrast)) } rr <- firstrow + tr$row[i] - 1 if (gvb) { blockvals <- data.frame(getValuesBlock(object, row=rr, nrows=tr$nrows[i], firstcol, ncols)) } else { blockvals <- data.frame(getValues(object, row=rr, nrows=tr$nrows[i])) # faster } # need to do this if using a single variable colnames(blockvals) <- lyrnames if (! is.null(const)) { blockvals <- cbind(blockvals, const) constnames <- names(const) } if (haveFactor) { for (j in 1:length(f)) { flev <- fvs <- factors[[j]] if (!is.null(const)) { if (!(f[j] %in% constnames)) { if (!is.numeric(fvs)) { flev <- 1:length(flev) } } } fv <- blockvals[, f[j]] # failed with character factors. See #91 #fv[!(fv %in% flev)] <- NA #fv <- factor(fv, levels=flev, labels=fvs) if (is.numeric(fv)) { flev <- as.numeric(flev) if (any(is.na(flev))) stop("cannot process these factors") } fv[!(fv %in% flev)] <- NA fv <- factor(fv, levels=flev, labels=fvs) blockvals[,f[j]] <- fv } } if (na.rm) { if (inf.rm) { blockvals[!is.finite(as.matrix(blockvals))] <- NA } blockvals <- stats::na.omit(blockvals) } nrb <- nrow(blockvals) if (nrb == 0 ) { predv <- napred } else { predv <- fun(model, blockvals, ...) if (class(predv)[1] == 'list') { predv <- unlist(predv, use.names = FALSE) if (length(predv) != nrow(blockvals)) { predv <- matrix(predv, nrow=nrow(blockvals)) } } else if (is.array(predv)) { predv <- as.matrix(predv) } if (isTRUE(dim(predv)[2] > 1)) { predv <- predv[,index, drop=FALSE] for (fi in 1:ncol(predv)) { if (is.factor(predv[,fi])) { predv[,fi] <- as.integer(as.character(predv[,fi])) } } # if data.frame predv <- as.matrix(predv) } else if (is.factor(predv)) { # should keep track of this to return a factor type RasterLayer factres <- TRUE if (facttest) { suppressWarnings(tst <- as.integer(as.character(levels(predv)))) if (any(is.na(tst))) { factaschar = FALSE } else { factaschar = TRUE } levs <- levels(predv) predrast@data@attributes <- list(data.frame(ID=1:length(levs), value=levs)) predrast@data@isfactor <- TRUE facttest <- FALSE } if (factaschar) { predv <- as.integer(as.character(predv)) } else { predv <- as.integer(predv) } } if (na.rm) { naind <- as.vector(attr(blockvals, "na.action")) if (!is.null(naind)) { p <- napred p[-naind,] <- predv predv <- p rm(p) } } } if (filename == '') { cells <- cellFromRowCol(predrast, tr$row[i], 1):cellFromRowCol(predrast, tr$row[i]+tr$nrows[i]-1, ncol(predrast)) v[cells, ] <- predv } else { predrast <- writeValues(predrast, predv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (length(index) > 1) { try(names(predrast) <- colnames(predv), silent=TRUE) } if (filename == '') { predrast <- setValues(predrast, v) # or as.vector } else { predrast <- writeStop(predrast) } return(predrast) } ) raster/R/quantile.R0000644000176200001440000000166614160021141013717 0ustar liggesusers# Author: Robert J. Hijmans # r.hijmans@gmail.com # Date : October 2008 # Licence GPL v3 setMethod('quantile', signature(x='Raster'), function(x, ..., na.rm=TRUE, ncells=NULL) { if (is.null(ncells)) { v <- try ( getValues(x) ) if (inherits(v, "try-error")) { stop('raster too large. You can sample it with argument "ncells"') } } else { if (ncells >= ncell(x)) { v <- try ( getValues(x) ) } else { v <- try ( sampleRandom(x, ncells) ) } if (inherits(v, "try-error")) { stop('ncells too large') } } #if (na.rm) { # v <- stats::na.omit(v) #} if (nlayers(x)==1) { return(quantile(v, ..., na.rm=na.rm)) } else { # t(apply(v, 2, quantile, na.rm=TRUE)) q <- stats::quantile(v[,1], ..., na.rm=na.rm) for (i in 2:nlayers(x)) { q <- rbind(q, stats::quantile(v[,i], ..., na.rm=na.rm)) } rownames(q) <- names(x) return(q) } } ) raster/R/rasterToPoints.R0000644000176200001440000000475614160021141015100 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2009 # Version 0.9 # Licence GPL v3 rasterToPoints <- function(x, fun=NULL, spatial=FALSE, ...) { nl <- nlayers(x) if (nl > 1) { if (! is.null(fun)) { stop('you can only supply a fun argument if "x" has a single layer') } } if (! inherits(x, 'RasterStack' )) { if ( ! fromDisk(x) & ! inMemory(x) ) { if (spatial) { return(sp::SpatialPoints(coords=xyFromCell(x, 1:ncell(x)), proj4string=x@crs) ) } else { return(xyFromCell(x, 1:ncell(x))) } } } laynam <- names(x) if (canProcessInMemory(x, 3)) { xyv <- cbind(xyFromCell(x, 1:ncell(x)), getValues(x)) if (nl > 1) { notna <- apply(xyv[,3:ncol(xyv), drop=FALSE], 1, function(x){ sum(is.na(x)) < length(x) }) xyv <- xyv[notna, ,drop=FALSE] } else { xyv <- stats::na.omit(xyv) attr(xyv, 'na.action') <- NULL } if (!is.null(fun)) { xyv <- subset(xyv, fun(xyv[,3])) } } else { xyv <- matrix(NA, ncol=2+nlayers(x), nrow=0) colnames(xyv) <- c('x', 'y', names(x)) X <- xFromCol(x, 1:ncol(x)) Y <- yFromRow(x, 1:nrow(x)) tr <- blockSize(x) pb <- pbCreate(tr$n, label='rasterize', ...) if (nl > 1) { for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xyvr <- cbind(rep(X, tr$nrows[i]), rep(Y[r], each=ncol(x)), getValues(x, row=tr$row[i], nrows=tr$nrows[i])) notna <- rowSums(is.na(xyvr[ , 3:ncol(xyvr), drop=FALSE])) < (ncol(xyvr)-2) xyvr <- xyvr[notna, ,drop=FALSE] xyv <- rbind(xyv, xyvr) pbStep(pb, i) } } else { # faster for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) xyvr <- cbind(rep(X, tr$nrows[i]), rep(Y[r], each=ncol(x)), v) xyvr <- subset(xyvr, !is.na(v)) if (!is.null(fun)) { xyvr <- subset(xyvr, fun(xyvr[,3])) } xyv <- rbind(xyv, xyvr) pbStep(pb, i) } } pbClose(pb) } if (spatial) { if (nrow(xyv) == 0) { xyv <- rbind(xyv, 0) v <- data.frame(xyv[ ,-c(1:2), drop=FALSE]) colnames(v) <- laynam s <- sp::SpatialPointsDataFrame(coords=xyv[,1:2,drop=FALSE], data=v, proj4string=x@crs ) return(s[0,]) } else { v <- data.frame(xyv[ ,-c(1:2), drop=FALSE]) colnames(v) <- laynam return( sp::SpatialPointsDataFrame(coords=xyv[,1:2,drop=FALSE], data=v, proj4string=x@crs ) ) } } else { colnames(xyv)[3:ncol(xyv)] <- laynam return(xyv) } } raster/R/readCells.R0000644000176200001440000001223714160021141013767 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 #read data on the raster for cell numbers .readCells <- function(x, cells, layers) { if (length(cells) < 1) { # cat(cells,"\n") # utils::flush.console() return(NULL) } cells <- round(cells) cells <- cbind(1:length(cells), cells) cells <- cells[order(cells[,2]), ,drop=FALSE] uniquecells <- sort(stats::na.omit(unique(cells[,2]))) uniquecells <- uniquecells[(uniquecells > 0) & (uniquecells <= ncell(x))] if (length(uniquecells) == 0) { return( matrix(NA, nrow=nrow(cells), ncol=length(layers)) ) } # creates problems with large integers # perhaps not needed (or causes problems with merge?) # uniquecells <- as.integer(uniquecells) # now using round (above) adjust <- TRUE if (length(uniquecells) > 0) { if ( inMemory(x) ) { vals <- getValues(x)[uniquecells] adjust <- FALSE } else if ( fromDisk(x) ) { driver <- x@file@driver if (length(uniquecells) > 250 & canProcessInMemory(x, 4)) { vals <- getValues(x) if (length(layers) > 1) { vals <- vals[uniquecells, layers, drop=FALSE] } else { vals <- vals[uniquecells] } adjust <- FALSE } else if (driver == 'gdal') { vals <- .readCellsGDAL(x, uniquecells, layers) } else if ( .isNativeDriver( driver) ) { # raster, BIL, .. vals <- .readCellsRaster(x, uniquecells, layers) # } else if ( driver == 'big.matrix') { # vals <- .readBigMatrixCells(x, uniquecells) } else if ( driver == 'netcdf') { vals <- .readRasterCellsNetCDF(x, uniquecells) } else if ( driver == 'ascii') { # can only have one layer vals <- .readCellsAscii(x, uniquecells) } else { stop('I did not expect the code to get here. Please report') } } else { stop('no data on disk or in memory') } } else { return(rep(NA, times=length(cells[,1]))) } if (is.null(dim(vals))) { vals <- matrix(vals, ncol=length(layers)) colnames(vals) <- names(x)[layers] } vals <- cbind(uniquecells, vals) vals <- merge(x=cells[,2], y=vals, by=1, all=TRUE) vals <- as.matrix(cbind(cells[,1], vals[,2:ncol(vals)])) # vals <- vals[order(cells[,1]), 2, drop=FALSE] vals <- vals[order(vals[,1]), 2:ncol(vals)] if (adjust) { if (x@data@gain != 1 | x@data@offset != 0) { vals <- vals * x@data@gain + x@data@offset } } # if NAvalue() has been used..... if (.naChanged(x)) { if (x@file@nodatavalue < 0) { vals[vals <= x@file@nodatavalue] <- NA } else { vals[vals == x@file@nodatavalue] <- NA } } return(vals) } .readBigMatrixCells <- function(x, cells, layers) { b <- attr(x@file, 'big.matrix') if (inherits(x, 'RasterLayer')) { colrow <- matrix(ncol=3, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow[,3] <- NA rows <- sort(unique(colrow[,2])) nc <- x@ncols for (i in 1:length(rows)) { v <- b[rows[i], ] thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } colrow[, 3] } else { b[cells, layers] } } .readCellsRaster <- function(x, cells, layers=1) { nl <- length(layers) res <- vector(length=length(cells)*nl) res[] <- NA if (! x@file@toptobottom) { rows <- rowFromCell(x, cells) cols <- colFromCell(x, cells) rows <- nrow(x) - rows + 1 cells <- cellFromRowCol(x, rows, cols) } cells <- cells + x@file@offset if (nbands(x) > 1) { if (inherits(x, 'RasterLayer')) { if (.bandOrder(x) == 'BIL') { cells <- cells + (rowFromCell(x, cells)-1) * x@ncols * (nbands(x)-1) + (bandnr(x)-1) * x@ncols } else if (.bandOrder(x) == 'BIP') { cells <- (cells - 1) * nbands(x) + bandnr(x) } else if (.bandOrder(x) == 'BSQ') { cells <- cells + (bandnr(x)-1) * ncell(x) } } else { if (.bandOrder(x) == 'BIL') { cells <- rep(cells + (rowFromCell(x, cells)-1) * x@ncols * (nbands(x)-1) , each=nl) + (layers-1) * x@ncols } else if (.bandOrder(x) == 'BIP') { cells <- rep((cells - 1) * nbands(x), each=nl) + layers } else if (.bandOrder(x) == 'BSQ') { cells <- rep(cells, each=nl) + (layers-1) * ncell(x) } } } byteord <- x@file@byteorder dsize <- dataSize(x@file@datanotation) if (.shortDataType(x@file@datanotation) == "FLT") { dtype <- "numeric" } else { dtype <- "integer" } cells <- (cells-1) * dsize signed <- dataSigned(x@file@datanotation) if (dsize > 2) { signed <- TRUE } is.open <- x@file@open if (!is.open) { x <- readStart(x) } for (i in seq(along.with=cells)) { seek(x@file@con, cells[i]) res[i] <- readBin(x@file@con, what=dtype, n=1, size=dsize, endian=byteord, signed=signed) } if (!is.open) { x <- readStop(x) } if (x@file@datanotation == 'INT4U') { i <- !is.na(res) & res < 0 res[i] <- 2147483647 - res[i] } if (dtype == "numeric") { res[is.nan(res)] <- NA res[res <= x@file@nodatavalue] <- NA } else { res[res == x@file@nodatavalue] <- NA } if (nl > 1) { res <- t(matrix(res, nrow=nl)) colnames(res) <- names(x)[layers] } return(res) } raster/R/distanceRows.R0000644000176200001440000000367714160021141014546 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 .distanceRows <- function(object, filename, progress='', ...) { filename <- trim(filename) overwrite <- .overwrite(...) if( (!overwrite) & file.exists(filename)) { stop('file exists; use overwrite=TRUE to overwrite it') } if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE } e <- boundaries(object, classes=FALSE, type='inner', asNA=TRUE) r <- raster(object) tr <- blockSize(r, n=3) tmp = rasterTmpFile() extension(tmp) = '.tif' .requireRgdal() r <- writeStart(r, filename=tmp, format='GTiff') pb <- pbCreate(tr$n, progress=progress) xx <- xFromCol( r, 1:ncol(r) ) hasWritten=FALSE for (i in 1:tr$n) { # get the from points for a block v <- getValuesBlock(e, row=tr$row[i], nrows=tr$nrows[i]) x <- rep(xx, tr$nrows[i]) y <- yFromRow(r, tr$row[i]) - (0:(tr$nrows[i]-1)) * yres(r) y <- rep(y, each=ncol(r)) xyv <- cbind(x,y,v) from <- stats::na.omit(xyv)[,1:2] if (isTRUE(nrow(from)==0)) { pbStep(pb, i) next } for (j in 1:tr$n) { # distance to these points for all blocks x <- rep(xx, tr$nrows[j]) y <- yFromRow(r, tr$row[j]) - (0:(tr$nrows[j]-1)) * yres(r) y <- rep(y, each=ncol(r)) v <- getValuesBlock(object, row=tr$row[j], nrows=tr$nrows[j]) xyv <- cbind(x,y,v) to <- xyv[is.na(xyv[,3]), 1:2] v[] = 0 if ( isTRUE(nrow(to) > 0) ) { v[is.na(xyv[,3])] <- .Call('_raster_distanceToNearestPoint', to, from, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') } if (hasWritten) { # after the first round, compare new values with previously written values v <- pmin(v, .getTransientRows(r, tr$row[j], n=tr$nrows[j])) } r <- writeValues(r, v, tr$row[j]) } hasWritten = TRUE pbStep(pb, i) } r <- writeStop(r) pbClose(pb) r <- writeRaster(r, filename=filename, ...) return(r) } raster/R/blend.R0000644000176200001440000000630514160021141013154 0ustar liggesusers# Authors: Rafael Wueest, WSL Birmensdorf, Switzerland, rafael.wueest@wsl.ch, # Etienne B. Racine, Robert J. Hijmans # Date : November 2012 # Version 1.0 # Licence GPL v3 # needs to be generalized to n input rasters and to multi-layer objects .old_blend <- function(r1, r2) { i <- intersect(raster(r1), raster(r2)) j <- extend(i, c(1,1)) a <- crop(r1, j) b <- crop(r2, j) values(a) <- 1 values(b) <- 2 ab <- merge(a, b) ba <- merge(b, a) p1 <- rasterToPoints(ab, function(x) x==2) p2 <- rasterToPoints(ba, function(x) x==1) d1 <- distanceFromPoints(i, p1[,1:2]) d2 <- distanceFromPoints(i, p2[,1:2]) dsum <- d1 + d2 z1 <- d1 * crop(r1, d1) / dsum z2 <- d2 * crop(r2, d2) / dsum merge(z1 + z2, r1, r2) } .blend <- function(x, y, logistic=FALSE, filename='', ...) { # check for difference in extent stopifnot( extent(x) != extent(y)) # define logistic function if (logistic) { G <- 1 f <- 0.001 k <- log(G/f-1)/(0.5*G) logfun <- function(x) { G /(1+exp(-k*G*x)*(G/f-1)) } } # create intersection rasters i <- intersect(raster(x), raster(y)) j <- extend(i, c(1,1)) # is one of the rasters nested within the other? ex <- extent(x) ey <- extent(y) exy <- union(ex, ey) if (exy==ex | exy==ey){ # the nested case # which raster has the smaller extent? if (extent(x) < extent(y)){ rlarge <- y rsmall <- x } else { rlarge <- x rsmall <- y } # create points around nested raster a <- crop(rlarge, j) a <- setValues(a, 1) b <- crop(rsmall, j) b <- setValues(b, 2) ba <- merge(b, a) p <- rasterToPoints(ba, function(x) x==1) # calculate distances to points in nested raster d <- distanceFromPoints(i, p[,1:2]) # standardize these distances dmin <- cellStats(d,'min') d.sc <- (d - dmin + 1e-9) / (cellStats(d,'max') - dmin) # the logistic case if(logistic){ d.sc<-logfun(d.sc) } # create distance weighted rasters z1 <- d.sc * crop(rsmall, d.sc) z2 <- abs(1-d.sc) * crop(rlarge, d.sc) # merge rasters m <- merge(z1 + z2, rsmall, rlarge, filename=filename, ...) } else { # the overlapping case # create points around ovelapping area a <- crop(x, j) a <- setValues(a, 1) b <- crop(y, j) b <- setValues(b, 2) ab <- merge(a, b) ba <- merge(b, a) p1 <- rasterToPoints(ab, function(x) x==2) p2 <- rasterToPoints(ba, function(x) x==1) # calculate distances to points in overlapping area d1 <- distanceFromPoints(i, p1[,1:2]) d2 <- distanceFromPoints(i, p2[,1:2]) # the logistic case if(logistic){ d1min <- cellStats(d1,'min') d2min <- cellStats(d2,'min') d1 <- logfun((d1 - d1min + 1e-9)/(cellStats(d1,'max') - d1min)) d2 <- logfun((d2 - d2min + 1e-9)/(cellStats(d2,'max') - d2min)) } # sum distance rasters dsum <- d1 + d2 # create distance weighted rasters z1 <- d1 * crop(x, d1) / dsum z2 <- d2 * crop(y, d2) / dsum z <- sum(z1, z2) # merge rasters m <- merge(z, x, y, filename=filename, ...) } m } raster/R/slopeAspect.R0000644000176200001440000000460714160021141014355 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2011 # Version 1.0 # Licence GPL v3 slopeAspect <- function(dem, filename='', out=c('slope', 'aspect'), unit='radians', neighbors=8, flatAspect, ...) { warning('this function is deprecated. Please use function "terrain" instead') stopifnot(neighbors %in% c(4, 8)) stopifnot(! is.na(projection(dem)) ) unit <- trim(tolower(unit)) stopifnot(unit %in% c('degrees', 'radians')) filename <- trim(filename) out <- trim(tolower(out)) stopifnot(all(out %in% c('slope', 'aspect'))) if (length(out) == 1) { type <- out } else { type <- 'both' } res <- res(dem) dx <- res[1] dy <- res[2] if (neighbors == 8) { fX <- matrix(c(-1,-2,-1,0,0,0,1,2,1) / -8, nrow=3) fY <- matrix(c(-1,0,1,-2,0,2,-1,0,1) / 8, nrow=3) } else { # neighbors == 4 fX <- matrix(c(0,-1,0,0,0,0,0,1,0) / -2, nrow=3) fY <- matrix(c(0,0,0,-1,0,1,0,0,0) / 2, nrow=3) } lonlat <- isLonLat(dem) if (!lonlat & couldBeLonLat(dem)) { warning('assuming crs is longitude/latitude') lonlat <- TRUE } if (lonlat) { dy <- pointDistance(cbind(0,0), cbind(0, dy), lonlat=TRUE) fY <- fY / dy zy <- focal(dem, w=fY) zx <- focal(dem, w=fX) y <- yFromRow(dem, 1:nrow(dem)) dx <- .geodist(-dx, y, dx, y) / 2 zx <- t( t(zx) / dx) } else { fX <- fX / dx fY <- fY / dy zx <- focal(dem, w=fX) zy <- focal(dem, w=fY) } if (type == 'slope') { x <- atan( sqrt( zy^2 + zx^2 ) ) if (unit == 'degrees') { x <- x * (180 / pi) } names(x) <- 'slope' } else if (type == 'aspect') { x <- atan2(zy, zx) x <- ((0.5*pi)-x) %% (2*pi) if (unit == 'degrees') { x <- x * (180/pi) } if (!missing (flatAspect)) { slope <- sqrt( zy^2 + zx^2 ) aspect <- overlay(x, slope, fun=function(x, y) { x[y==0] <- flatAspect; return(x) } ) } names(x) <- 'aspect' } else { x <- atan( sqrt( zy^2 + zx^2 ) ) aspect <- atan2(zy, zx) aspect <- ((0.5*pi)-aspect) %% (2*pi) if (unit == 'degrees') { x <- x * (180/pi) aspect <- aspect * (180/pi) } if (!missing (flatAspect)) { aspect <- overlay(aspect, x, fun=function(x, y) { x[y==0] <- flatAspect; return(x) } ) } names(x) <- 'slope' names(aspect) <- 'aspect' x <- stack(x, aspect) } if (filename != "") { x <- writeRaster(x, filename, ...) } return(x) } raster/R/Geary.R0000644000176200001440000000327214160021141013137 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 .getFilter <- function(w, warn=TRUE) { if (!is.matrix(w)) { w <- .checkngb(w) w <- matrix(1, nrow=w[1], ncol=(w[2])) w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0 } else { if (w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] != 0) { if (warn) { warning('central cell of weights matrix (filter) was set to zero') } w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0 } stopifnot(all(w >= 0)) } if (min(dim(w) %% 2)==0) { stop('dimensions of weights matrix (filter) must be uneven') } w } Geary <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3)) { w <- .getFilter(w, warn=FALSE) i <- trunc(length(w)/2)+1 n <- ncell(x) - cellStats(x, 'countNA') fun <- function(x,...) sum(w*(x-x[i])^2, ...) w2 <- w w2[] <- 1 Eij <- cellStats(focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE), sum) if (sum(! unique(w) %in% 0:1) > 0) { xx <- calc(x, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal(xx, w=w, na.rm=TRUE, pad=TRUE ) } else { w[w==0] <- NA W <- focal(x, w=w, fun=function(x, ...){ sum(!is.na(x)) }, pad=TRUE ) } z <- 2 * cellStats(W, sum) * cellStats((x - cellStats(x, mean))^2, sum) (n-1)*Eij/z } GearyLocal <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3)) { w <- .getFilter(w) i <- trunc(length(w)/2)+1 fun <- function(x,...) sum(w*(x-x[i])^2, ...) w2 <- w w2[] <- 1 Eij <- focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE) s2 <- cellStats(x, 'sd')^2 if (ncell(x) < 1000000) { n <- ncell(x) - cellStats(x, 'countNA' ) } else { n <- ncell(x) } #s2 <- (s2 * (n-1)) / n Eij / s2 } raster/R/setFileExt.R0000644000176200001440000000234114160021141014140 0ustar liggesusers# raster package # Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .setFileExtensionValues <- function(fname, type='raster') { if (type == 'raster') { extension(fname) <- ".gri" } else if (type == 'SAGA') { extension(fname) <- ".sdat" } else if (type == 'IDRISI') { extension(fname) <- ".rst" } else if (type == 'IDRISIold') { extension(fname) <- ".img" } else if (type == 'BIL') { extension(fname) <- ".bil" } else if (type == 'BIP') { extension(fname) <- ".bip" } else if (type == 'BSQ') { extension(fname) <- ".bsq" # } else if (type == 'big.matrix') { # extension(fname) <- ".big" } else { stop('unknown file format') } return(fname) } .setFileExtensionHeader <- function(fname, type='raster') { if (type == 'raster') { extension(fname) <- ".grd" } else if (type == 'SAGA') { extension(fname) <- "sgrd" } else if (type == 'IDRISI') { extension(fname) <- ".rdc" } else if (type == 'IDRISIold') { extension(fname) <- ".doc" } else if (type %in% c('BIL', 'BSQ', 'BIP')) { extension(fname) <- ".hdr" } else if (type == 'big.matrix') { extension(fname) <- ".brd" } else { stop('unknown file format') } return(fname) } raster/R/randomize.R0000644000176200001440000000044314160021141014055 0ustar liggesusers .randomize <- function(x, ...) { if (!hasValues(x)) { return(x) } nl <- nlayers(x) if (nl > 1) { y <- brick(x, values=FALSE) for (i in 1:nl) { y <- setValues(y, sample(getValues(x[[i]])), layer=i) } y } else { setValues(x, sample(getValues(x))) } } raster/R/focalWeight.R0000644000176200001440000000454514160021141014330 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2013 # Version 1.0 # Licence GPL v3 .circular.weight <- function(rs, d, fillNA=FALSE) { nx <- 1 + 2 * floor(d/rs[1]) ny <- 1 + 2 * floor(d/rs[2]) w <- matrix(ncol=nx, nrow=ny) w[ceiling(ny/2), ceiling(nx/2)] <- 1 if ((nx != 1) || (ny != 1)) { x <- raster(w, xmn=0, xmx=nx*rs[1], ymn=0, ymx=ny*rs[2], crs="+proj=utm +zone=1 +datum=WGS84") d <- as.matrix(distance(x)) <= d w <- d / sum(d) } if (fillNA) { w[w <= 0] <- NA } w } .Gauss.weight <- function(rs, sigma) { if (length(sigma) == 1) { d <- 3 * sigma } else { d <- sigma[2] sigma <- sigma[1] } nx <- 1 + 2 * floor(d/rs[1]) ny <- 1 + 2 * floor(d/rs[2]) m <- matrix(ncol=nx, nrow=ny) xr <- (nx * rs[1]) / 2 yr <- (ny * rs[2]) / 2 r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs="+proj=utm +zone=1 +datum=WGS84") p <- xyFromCell(r, 1:ncell(r))^2 # according to http://en.wikipedia.org/wiki/Gaussian_filter m <- 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2)) m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE) # sum of weights should add up to 1 m / sum(m) } .rectangle.weight <- function(rs, d) { d <- rep(d, length.out=2) nx <- 1 + 2 * floor(d[1]/rs[1]) ny <- 1 + 2 * floor(d[2]/rs[2]) m <- matrix(1, ncol=nx, nrow=ny) m / sum(m) } focalWeight <- function(x, d, type=c('circle', 'Gauss', 'rectangle'), fillNA=FALSE) { type <- match.arg(type) x <- res(x) if (type == 'circle') { .circular.weight(x, d[1], fillNA) } else if (type == 'Gauss') { if (!length(d) %in% 1:2) { stop("If type=Gauss, d should be a vector of length 1 or 2") } .Gauss.weight(x, d) } else { .rectangle.weight(x, d) } } ..simple.circular.weight <- function(radius) { # based on a function provided by Thomas Cornulier x <- -radius:radius n <- length(x) d <- sqrt(rep(x, n)^2 + rep(x, each=n)^2) <= radius matrix(d + 0, n, n) / sum(d) } ..simple.Gauss.weight <- function(n, sigma) { # need to adjust for non-square cells to distance.... m <- matrix(ncol=n, nrow=n) col <- rep(1:n, n) row <- rep(1:n, each=n) x <- col - ceiling(n/2) y <- row - ceiling(n/2) # according to http://en.wikipedia.org/wiki/Gaussian_filter m[cbind(row, col)] <- 1/(2*pi*sigma^2) * exp(-(x^2+y^2)/(2*sigma^2)) # sum of weights should add up to 1 m / sum(m) } raster/R/overlay.R0000644000176200001440000001165614160021141013556 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 # version 1, April 2012 setMethod('overlay', signature(x='Raster', y='Raster'), function(x, y, ..., fun, filename="", recycle=TRUE, forcefun=FALSE){ if (missing(fun)) { stop("you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum'") } lst <- list(...) isRast <- sapply(lst, function(x) inherits(x, 'Raster')) if (sum(unlist(isRast)) > 0) { x <- c(x, y, lst[isRast]) lst <- lst[! isRast ] } else { x <- list(x, y) } lst$fun <- fun lst$filename <- filename lst$recycle <- recycle lst$forcefun <- forcefun lst$x <- x do.call(.overlayList, lst) } ) setMethod('overlay', signature(x='Raster', y='missing'), function(x, y, ..., fun, filename="", unstack=TRUE, forcefun=FALSE){ if (missing(fun)) { stop("you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum'") } x <- .makeRasterList(x, unstack=unstack) .overlayList(x, fun=fun, filename=filename, forcefun=forcefun, ...) } ) .overlayList <- function(x, fun, filename="", recycle=TRUE, forcefun=FALSE, ...){ ln <- length(x) if (ln < 1) { stop('no Rasters') } if (ln > 1) { compareRaster(x) } nl <- sapply(x, nlayers) maxnl <- max(nl) filename <- trim(filename) testmat <- NULL testlst <- vector(length=length(x), mode='list') w <- getOption('warn') options('warn'=-1) for (i in 1:length(testlst)) { v <- extract(x[[i]], 1:5) testmat <- cbind(testmat, as.vector(v)) testlst[[i]] <- v } options('warn'= w) test1 <- try ( apply(testmat, 1, fun) , silent=TRUE ) if ((!inherits(test1, "try-error")) & (!forcefun)) { doapply <- TRUE if (! is.null(dim(test1))) { test1 <- t(test1) } else { test1 <- matrix(test1, ncol=maxnl) } nlout <- NCOL(test1) } else { doapply <- FALSE dovec <- FALSE test2 <- try ( do.call(fun, testlst), silent=TRUE ) nlout <- length(test2)/5 if ((inherits(test2, "try-error")) | length(test2) < 5) { dovec <- TRUE testlst <- lapply(testlst, as.vector) test3 <- try ( do.call(fun, testlst), silent=TRUE ) nlout <- length(test3)/5 if ((inherits(test3, "try-error")) | length(test3) < 5) { stop('cannot use this formula, probably because it is not vectorized') } } } if (nlout == 1) { out <- raster(x[[1]]) } else { out <- brick(x[[1]], values=FALSE, nl=nlout) } if ( canProcessInMemory(out, sum(nl)+maxnl) ) { pb <- pbCreate(3, label='overlay', ...) pbStep(pb, 1) if (doapply) { valmat <- matrix(nrow=ncell(out)*maxnl, ncol=length(x)) for (i in 1:length(x)) { if (ncell(x[[i]]) < nrow(valmat)) { options('warn'=-1) valmat[,i] <- as.vector(getValues(x[[i]])) * rep(1, nrow(valmat)) options('warn'= w) } else { valmat[,i] <- as.vector(getValues(x[[i]])) } } pbStep(pb, 2) vals <- apply(valmat, 1, fun) if (! is.null(dim(vals))) { vals <- t(vals) } vals <- matrix(vals, nrow=ncell(out)) } else { for (i in 1:length(x)) { x[[i]] <- getValues(x[[i]]) } if (dovec) { x <- lapply(x, as.vector) } pbStep(pb, 2) vals <- do.call(fun, x) vals <- matrix(vals, nrow=ncell(out)) } pbStep(pb, 3) out <- setValues(out, vals) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } pbClose(pb) return(out) } else { if (filename == "") { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=sum(nl)+maxnl) pb <- pbCreate(tr$n, label='overlay', ...) if (doapply) { valmat = matrix(nrow=tr$nrows[1]*ncol(out)*maxnl, ncol=length(x)) for (i in 1:tr$n) { if (i == tr$n) { valmat = matrix(nrow=tr$nrows[i]*ncol(out)*maxnl , ncol=length(x)) } for (j in 1:length(x)) { v <- as.vector(getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i])) if (length(v) < nrow(valmat)) { options('warn'=-1) valmat[,j] <- v * rep(1, nrow(valmat)) options('warn'=w) } else { valmat[,j] <- v } } vv <- apply(valmat, 1, fun) if (! is.null(dim(vv))) { vals <- t(vv) } vv <- matrix(vv, ncol=nlout) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } } else { vallist <- list() for (i in 1:tr$n) { if (dovec) { for (j in 1:length(x)) { vallist[[j]] <- as.vector( getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) ) } } else { for (j in 1:length(x)) { vallist[[j]] <- getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) } } vv <- do.call(fun, vallist) vv <- matrix(vv, ncol=nlout) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) } return(out) } raster/R/boundaries.R0000644000176200001440000000626214160021141014225 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 # name overlap with igraph setMethod('boundaries', signature(x='RasterLayer'), function(x, type='inner', classes=FALSE, directions=8, asNA=FALSE, filename="", ...) { stopifnot( nlayers(x) == 1 ) stopifnot( hasValues(x) ) filename <- trim(filename) out <- raster(x) gll <- as.integer( .isGlobalLonLat(out) ) type <- tolower(type) if (! type %in% c('inner', 'outer')) { stop("type must be 'inner', or 'outer'") } if (type=='inner') { type <- FALSE } else { type <- TRUE } classes <- as.logical(classes) directions <- as.integer(directions) stopifnot(directions %in% c(4,8)) # asZero <- as.integer(as.logical(asZero)) datatype <- list(...)$datatype if (is.null(datatype)) { datatype <- 'INT2S' } if (canProcessInMemory(out, 4)) { x <- as.matrix(x) if (gll) { x <- cbind(x[, ncol(x)], x, x[, 1]) } else { x <- cbind(x[, 1], x, x[, ncol(x)]) } x <- rbind(x[1,], x, x[nrow(x),]) paddim <- as.integer(dim(x)) x <- .edge(round(t(x)), paddim, classes[1], type[1], directions[1]) if (asNA) { x[x==0] <- as.integer(NA) } x <- matrix(x, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) x <- x[2:(nrow(x)-1), 2:(ncol(x)-1)] x <- setValues(out, as.vector(t(x))) if (filename != '') { x <- writeRaster(x, filename, datatype=datatype, ...) } return(x) } else { out <- writeStart(out, filename, datatype=datatype, ...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label='boundaries', ...) nc <- ncol(out)+2 v <- getValues(x, row=1, nrows=tr$nrows[1]+1) v <- matrix(v, ncol=tr$nrows[1]+1) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- round(cbind(v[,1], v)) v <- .edge(v, as.integer(c(tr$nrows[1]+2, nc)), classes, type, directions) if (asNA) { v[v==0] <- as.integer(NA) } v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, 1) pbStep(pb, 1) if (tr$n > 2) { for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+2) v <- matrix(v, ncol=tr$nrows[1]+2) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- .edge(round(v), as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions) v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } i <- tr$n v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+1) v <- matrix(v, ncol=tr$nrows[i]+1) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- round(cbind(v, v[,ncol(v)])) v <- .edge(v, as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions) v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, tr$row[i]) pbStep(pb, tr$n) out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/click.R0000644000176200001440000001071414160021141013154 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 - December 2011 # Version 1.0 # Licence GPL v3 .getClicks <- function(...) { res <- list() while(TRUE) { loc <- graphics::locator(1, ...) if (is.null(loc)) break res <- c(res, loc) } matrix(res, ncol=2, byrow=TRUE) } .getCellFromClick <- function(x, n, type, id, ...) { loc <- graphics::locator(n, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=1:n) } cells <- cellFromXY(x, xyCoords) cells <- unique(stats::na.omit(cells)) if (length(cells) == 0 ) { stop('no valid cells selected') } cells } setMethod('click', signature(x='missing'), function(x, n=1, type="n", ...) { loc <- graphics::locator(n, type, ...) cbind(x=loc$x, y=loc$y) } ) setMethod('click', signature(x='SpatialGrid'), function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) { r <- raster(x) cells <- .getCellFromClick(r, n, type, id, ...) if (.hasSlot(x, 'data')) { value <- x@data[cells, ,drop=FALSE] } else { value <- NULL } if (cell) { value <- data.frame(cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } ) setMethod('click', signature(x='SpatialPixels'), function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) { r <- raster(x) cells <- .getCellFromClick(r, n, type, id, ...) if (.hasSlot(x, 'data')) { value <- x@data[cells, ,drop=FALSE] } else { value <- NULL } if (cell) { value <- data.frame(cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } ) .oldclick <- function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) { cells <- .getCellFromClick(x, n, type, id, ...) value <- .cellValues(x, cells) if (is.null(dim(value))) { value <- matrix(value) colnames(value) <- names(x) } if (cell) { value <- data.frame(cell=cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } setMethod('click', signature(x='Raster'), function(x, n=Inf, id=FALSE, xy=FALSE, cell=FALSE, type="n", show=TRUE, ...) { values <- NULL i <- 0 n <- max(n, 1) while (i < n) { i <- i + 1 loc <- graphics::locator(1, type, ...) if (is.null(loc)) break xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=i) } cells <- stats::na.omit(cellFromXY(x, xyCoords)) if (length(cells) == 0) break value <- extract(x, cells) if (cell) { value <- data.frame(cell=cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } if (show) { print(value) utils::flush.console() } if (is.null(dim(value))) { value <- matrix(value) colnames(value) <- names(x) } values <- rbind(values, value) } if (show) { invisible(values) } else { values } return(values) }) setMethod('click', signature(x='SpatialPolygons'), function(x, n=1, id=FALSE, xy=FALSE, type="n", ...) { loc <- graphics::locator(n, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=1:n) } xyCoords <- sp::SpatialPoints(xyCoords) xyCoords@proj4string <- x@proj4string i <- which(!is.na(sp::over(x, xyCoords))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } if (xy) { x <- cbind(xyCoords, x) } return(x) } ) setMethod('click', signature(x='SpatialLines'), function(x, ...) { e <- as(drawExtent(), 'SpatialPolygons') e@proj4string <- x@proj4string i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } x } ) setMethod('click', signature(x='SpatialPoints'), function(x, ...) { e <- as(drawExtent(), 'SpatialPolygons') e@proj4string <- x@proj4string i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } x } ) raster/R/sampleRandom.R0000644000176200001440000000752114160021141014513 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('sampleRandom', signature(x='Raster'), function(x, size, na.rm=TRUE, ext=NULL, cells=FALSE, rowcol=FALSE, xy=FALSE, sp=FALSE, asRaster=FALSE, ...) { if (!hasValues(x)) { stop('No values associated with the Raster object') } size <- round(size) stopifnot(size > 0) r <- raster(x) if (asRaster) { if (! is.null(ext)) { x <- crop(x, ext) } if (size >= ncell(x)) { return(x) } if (na.rm) { x <- sampleRandom(x, min(ncell(r), size), cells=TRUE, na.rm=TRUE) r <- rasterize(xyFromCell(r, x[,1]), r, x[,-1], ...) } else { cells <- sample(ncell(r), size) x <- extract(x, cells) r <- rasterize(xyFromCell(r, cells), r, x, ...) } return(r) } stopifnot(size <= ncell(x)) nc <- ncell(r) layn <- names(x) removeCells <- FALSE if (sp | rowcol | xy) { removeCells <- ! cells cells <- TRUE } if ( canProcessInMemory(x) ) { if (is.null(ext)) { x <- getValues(x) } else { x <- crop(x, ext) rc <- raster(x) x <- getValues(x) } if (cells) { if (is.null(ext)) { x <- cbind(cell=1:nc, value=x) } else { XY <- xyFromCell(rc, 1:ncell(rc)) cell <- cellFromXY(r, XY) x <- cbind(cell=cell, x) } } if (na.rm) { x <- stats::na.omit(x) } if (is.matrix(x)) { # get rid of omit attributes d <- dim(x) x <- matrix(as.vector(x), d[1], d[2]) if ( nrow(x) > size) { s <- sampleInt(nrow(x), size) x <- x[s, ,drop=FALSE] } } else { # get rid of omit attributes x <- as.vector(x) s <- sampleInt(length(x), size) x <- x[s] } } else { if (! is.null(ext)) { xx <- crop(x, ext) nc <- ncell(xx) if (size > nc) { size <- nc warning('size set to the number of cells within "ext": ', size) } } if (size >= nc) { if (is.null(ext)) { x <- getValues(x) } else { r <- raster(x) x <- getValues(xx) } if (cells) { if (is.null(ext)) { x <- cbind(cell=1:nc, value=x) } else { XY <- xyFromCell(xx, 1:ncell(xx)) cell <- cellFromXY(r, XY) x <- cbind(cell, x) } } if (na.rm) { x <- stats::na.omit(x) # get rid of omit attributes if (is.matrix(x)) { d <- dim(x) x <- matrix(as.vector(x), d[1], d[2]) } else { x <- as.vector(x) } } } else { if (na.rm) { N <- 4 * size } else { N <- size } N <- min(N, nc) rcells <- sampleInt(nc, N) if (!is.null(ext)) { XY <- xyFromCell(xx, rcells) rcells <- cellFromXY(r, XY) } x <- .cellValues(x, rcells) if (cells) { x <- cbind(cell=rcells, value=x) } if (na.rm) { x <- stats::na.omit(x) if (is.matrix(x)) { d <- dim(x) x <- matrix(as.vector(x), d[1], d[2]) if (nrow(x) > size) { x <- x[1:size, ] } } else { x <- as.vector(x) if ( length(x) > size ) { x <- x[1:size] } } } } } if (is.matrix(x)) { if (cells) { colnames(x) <- c('cell', layn) if (xy) { XY <- xyFromCell(r, x[,1]) x <- cbind(x[,1,drop=FALSE], XY, x[,2:ncol(x),drop=FALSE]) } if (rowcol) { rc <- cbind(row=rowFromCell(r, x[,1]), col=colFromCell(r, x[,1])) x <- cbind(x[ , 1, drop=FALSE], rc, x[ , 2:ncol(x), drop=FALSE]) } if (sp) { if (!xy) { XY <- data.frame(xyFromCell(r, x[,1])) } if (removeCells) { x <- x[,-1,drop=FALSE] } x <- sp::SpatialPointsDataFrame(XY, data=data.frame(x), proj4string=.getCRS((r))) } else if (removeCells) { x <- x[,-1,drop=FALSE] } } else { colnames(x) <- layn } } return(x) } ) raster/R/as.raster.R0000644000176200001440000000134114160021141013765 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2011 # Version 0.9 # Licence GPL v3 # Note: these functions create a _r_aster object (small r) (grDevices) for use with the rasterImage function # _NOT_ a Raster* object as defined in this package setMethod('as.raster', signature(x='RasterLayer'), function(x, maxpixels=50000, col=rev(terrain.colors(255)), ...) { x <- as.matrix(sampleRegular(x, maxpixels, asRaster=TRUE)) r <- range(x, na.rm=TRUE) x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) x[] <- col[x] as.raster(x) } ) #e <- as.vector(t(bbox(extent(r)))) #a <- as.raster(r) #plot(e[1:2], e[3:4], type = "n", xlab="", ylab="") #graphics::rasterImage(a, e[1], e[3], e[2], e[4]) raster/R/intDataType.R0000644000176200001440000000417614160021141014322 0ustar liggesusers# raster package # Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 .checkIntDataType <- function(mn, mx, dtype) { mn <- round(mn) mx <- round(mx) ok <- TRUE if (dtype == 'INT') { return(.getIntDataType(mn, mx) ) } else if (dtype == 'INT1S') { if (mn < -127 | mx > 128) { ok <- FALSE } } else if (dtype == 'INT1U') { if (mn < 0 | mx > 256) { ok <- FALSE } } else if (dtype == 'INT2S') { if (mn < -32767 | mx > 32768) { ok <- FALSE } } else if (dtype == 'INT2U') { if (mn <= 0 | mx > 65534 ) { ok <- FALSE } } else if (dtype == 'INT4S') { if (mn < -2147483647 | mx > 2147483648 ) { ok <- FALSE } } else if (dtype == 'INT4U') { if (mn < 0 | mx > 2^32 ) { ok <- FALSE } # } else if (dtype == 'INT8S') { # if (mn < -2^63/2 | mx > 2^64/2) { # ok <- FALSE # } } else { stop('unknown integer type:', dtype) } if (!ok) { dtype <- .getIntDataType(mn, mx) warning('changed INT data type to: ', dtype) } return(dtype) } .getIntDataType <- function(mn, mx) { # optimize the number of bytes within the datatype if (mn > -128 & mx < 128) { datatype <- 'INT1S' } else if (mn >=0 & mx < 256) { datatype <- 'INT1U' } else if (mn > -32767 & mx < 32768) { datatype <- 'INT2S' } else if (mn >= 0 & mx < 65534 ) { datatype <- 'INT2U' } else if (mn > -2147483647 & mx < 2147483648 ) { datatype <- 'INT4S' } else if (mn > 0 & mx < 2^32 ) { datatype <- 'INT4U' ## } else if (mn > -(2^63/2) & mx < (2^64/2)) { # datatype <- 'INT8S' } else { stop('these values are too large to be saved as integers') } return(datatype) } ..intSetNA <- function(v, dtype) { if (dtype == 'INT1S') { v[v < -127 | v > 128] <- NA } else if (dtype == 'INT1U') { v[v <=0 | v > 256] <- NA } else if (dtype == 'INT2S') { v[v < -32767 | v > 32768] <- NA } else if (dtype == 'INT2U') { v[v <= 0 | v > 65534] <- NA } else if (dtype == 'INT4S') { v[v < -2147483647 | v > 2147483648] <- NA } else if (dtype == 'INT8S') { v[v < -2^63/2 | v > 2^64/2] <- NA } return(v) } raster/R/destair.R0000644000176200001440000000177514160021141013531 0ustar liggesusers .destair <- function(x, keepExtent=TRUE) { pts <- data.frame(geom(as(x, 'SpatialPolygons'))) if (keepExtent) { bb <- sp::bbox(x) ptsx1 <- pts[,5] == bb[1,1] ptsx2 <- pts[,5] == bb[1,2] ptsy1 <- pts[,6] == bb[2,1] ptsy2 <- pts[,6] == bb[2,2] } u <- unique(pts$cump) for (j in u) { k <- pts$cump==j p <- pts[k, 5:6] p <- rbind(p[(nrow(p)-1), ,drop=FALSE], p, p[2,,drop=FALSE]) dx <- diff(p$x) dy <- diff(p$y) tf1 <- rowSums( cbind(dx[-length(dx)], dy[-1]) ) tf2 <- rowSums( cbind(dx[-1], dy[-length(dy)]) ) i <- which(tf1==0 | tf2==0) + 1 p[i, ] <- (p[i-1, ] + p[i+1, ] + 2 * p[i, ]) / 4 pts[k, 5:6] <- p[-c(1, nrow(p)),] } if (keepExtent) { pts[ptsx1,5] <- bb[1,1] pts[ptsx2,5] <- bb[1,2] pts[ptsy1,6] <- bb[2,1] pts[ptsy2,6] <- bb[2,2] } r <- as(pts, 'SpatialPolygons') row.names(r) <- row.names(x) crs(r) <- .getCRS(x) if (.hasSlot(x, 'data')) { r <- sp::SpatialPolygonsDataFrame(r, x@data) } r } raster/R/cv.R0000644000176200001440000000331114160021141012472 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008-2011 # Version 1.0 # Licence GPL v3 setGeneric("cv", function(x, ..., aszero=FALSE, na.rm=FALSE) standardGeneric("cv")) setMethod('cv', signature(x='ANY'), function(x, ..., aszero=FALSE, na.rm=FALSE) { # R function to compute the coefficient of variation (expressed as a percentage) # if there is only a single value, stats::sd = NA. However, one could argue that cv =0. # and NA may break the code that receives it. #The function returns NA if(aszero=FALSE) else a value of 0 is returned. x <- c(x, ...) z <- x[!is.na(x)] if (length(z) == 0) { return(NA) } else if (na.rm == FALSE & (length(z) < length(x))) { return(NA) } else if (length(z) == 1 & aszero) { return(0) } else { # abs to avoid very small (or zero) mean with e.g. -5:5 x <- mean(abs(z)) if (x == 0) {# all values are 0 return(0) } else { return(100 * stats::sd(z) / x) } } } ) setMethod("cv", signature(x='Raster'), function(x, ..., aszero=FALSE, na.rm=FALSE){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- .addArgs(...) } else { add <- NULL } out <- raster(x) if (canProcessInMemory(x)) { x <- cbind(getValues(x), add) x <- setValues(out, apply(x, 1, cv, aszero=aszero, na.rm=na.rm)) return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n) out <- writeStart(out, filename="") for (i in 1:tr$n) { v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add) v <- apply(v, 1, cv, aszero=aszero, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) writeStop(out) } ) raster/R/read.R0000644000176200001440000000353014160021141013000 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("readAll")) { setGeneric("readAll", function(object) standardGeneric("readAll")) } setMethod('readAll', signature(object='RasterLayer'), function(object){ if (! object@data@fromdisk) { warning('cannot read values; there is no file associated with this RasterLayer') return(object) } object@data@values <- .readRasterLayerValues(object, 1, object@nrows) suppressWarnings(object@data@min <- as.vector( min(object@data@values, na.rm=TRUE ) )) suppressWarnings(object@data@max <- as.vector( max(object@data@values, na.rm=TRUE ) )) object@data@haveminmax <- TRUE object@data@inmemory <- TRUE object@data@fromdisk <- FALSE object@file@name <- "" return(object) } ) setMethod('readAll', signature(object='RasterStack'), function(object){ for (i in seq(nlayers(object))) { if (! object@layers[[i]]@data@inmemory ) { object@layers[[i]] <- readAll(object@layers[[i]]) # object@layers[[i]]@data@values <- .readRasterLayerValues(object@layers[[i]], 1, object@nrows) } } return(object) } ) setMethod('readAll', signature(object='RasterBrick'), function(object){ if (! object@data@fromdisk) { warning('cannot read values; there is no file associated with this RasterBrick') return(object) } object@data@values <- .readRasterBrickValues(object, 1, object@nrows) w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) rge <- apply(object@data@values, 2, FUN=function(x){ range(x, na.rm=TRUE) } ) object@data@min <- as.vector(rge[1,]) object@data@max <- as.vector(rge[2,]) object@data@haveminmax <- TRUE object@data@inmemory <- TRUE object@data@fromdisk <- FALSE object@file@name <- "" return(object) } ) raster/R/approxNA.R0000644000176200001440000000654514160021141013626 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2012 # Version 1.0 # Licence GPL v3 setMethod('approxNA', signature(x='RasterStackBrick'), function(x, filename="", method="linear", yleft, yright, rule=1, f=0, ties=mean, z=NULL, NArule=1, ...) { filename <- trim(filename) out <- brick(x, values=FALSE) nl <- nlayers(out) if (nl < 2) { warning('cannot interpolate with a single layer') return(x) } if (is.null(z)) { xout <- getZ(x) if (is.null(xout)) { xout <- 1:nl } else if (length(xout)!= nl) { stop('length of values returned by getZ(x) does not match the number of layers of x') } } else { if (length(z)!= nl) { stop('length of z does not match the number of layers of x') } xout <- z } ifelse((missing(yleft) & missing(yright)), ylr <- 0L, ifelse(missing(yleft), ylr <- 1L, ifelse(missing(yright), ylr <- 2L, ylr <- 3L))) if (canProcessInMemory(x)) { x <- getValues(x) s <- rowSums(is.na(x)) if (isTRUE(NArule==1)) { j <- s == (nl-1) # one non-NA only if (length(j) > 0 ) { x[j, ] <- apply(x[j, ,drop=FALSE], 1, max, na.rm=TRUE) } } i <- s < (nl-1) # at least two if (length(i) > 0 ) { if (ylr==0) { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y )) } else if (ylr==1) { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y )) } else if (ylr==2) { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y )) } else { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y )) } } else { warning('no NA values to approximate') } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename=filename, ...) } return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n, label='approxNA', ...) out <- writeStart(out, filename=filename, ...) nc <- ncol(out) for (j in 1:tr$n) { v <- getValues(x, row=tr$row[j], nrows=tr$nrows[j]) s <- .rowSums(is.na(v), nrow(v), nl) if (isTRUE(NArule==1)) { j <- s == (nl-1) # one non-NA only if (length(j) > 0 ) { v[j, ] <- apply(v[j,,drop=FALSE ], 1, max, na.rm=TRUE) } } i <- (s < nl-1) # need at least two if (length(i) > 0 ) { if (ylr==0) { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y ) ) } else if (ylr==1) { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y ) ) } else if (ylr==2) { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y ) ) } else { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y ) ) } } out <- writeValues(out, v, tr$row[j]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) raster/R/newPLot.R0000644000176200001440000001322314160021141013455 0ustar liggesusers# The functions below here were adapted from the functions in the fields package! (image.plot and subroutines) # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html # Adaptations for the raster package: # Author: Robert J. Hijmans # Date : May 2010 # Version 1.0 # Licence GPL v3 .plotSpace <- function(asp=1, legend.mar = 3.1, legend.width = 0.5, legend.shrink = 0.5) { pars <- graphics::par() char.size <- pars$cin[1] / pars$din[1] offset <- char.size * pars$mar[4] legend.width <- char.size * legend.width legend.mar <- legend.mar * char.size legendPlot <- pars$plt legendPlot[2] <- 1 - legend.mar legendPlot[1] <- legendPlot[2] - legend.width pr <- (legendPlot[4] - legendPlot[3]) * ((1 - legend.shrink)/2) legendPlot[4] <- legendPlot[4] - pr legendPlot[3] <- legendPlot[3] + pr bp <- pars$plt bp[2] <- min(bp[2], legendPlot[1] - offset) aspbp = (bp[4]-bp[3]) / (bp[2]-bp[1]) adj = aspbp / asp if (adj < 1) { adjust = (bp[4]-bp[3]) - ((bp[4]-bp[3]) * adj) } else { adjust = (bp[4]-bp[3]) / adj - ((bp[4]-bp[3])) } adjust <- adjust / 2 bp[3] <- bp[3] + adjust bp[4] <- bp[4] - adjust dp <- legendPlot[2] - legendPlot[1] legendPlot[1] <- min(bp[2] + 0.5 * offset, legendPlot[1]) legendPlot[2] <- legendPlot[1] + dp return(list(legendPlot = legendPlot, mainPlot = bp)) } .plotLegend <- function(z, col, legend.at='classic', lab.breaks = NULL, axis.args = NULL, legend.lab = NULL, legend.args = NULL, ...) { horizontal=FALSE ix <- 1 zlim <- range(z, na.rm = TRUE, finite=TRUE) zrange <- zlim[2]-zlim[1] if (zrange > 10) { decs <- 0 } else if (zrange > 1) { decs <- 1 } else { decs <- ceiling(abs(log10(zrange)) + 1) } pow <- 10^decs minz <- floor(zlim[1] * pow) / pow maxz <- ceiling(zlim[2] * pow) / pow zrange <- maxz - minz nlevel = length(col) binwidth <- c(0, 1:nlevel * (1/nlevel)) iy <- minz + zrange * binwidth # binwidth <- 1 + (maxz - minz)/nlevel # iy <- seq(minz, maxz, by = binwidth) iz <- matrix(iy, nrow = 1, ncol = length(iy)) breaks <- list(...)$breaks if (!is.null(breaks) & !is.null(lab.breaks)) { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { if (legend.at == 'quantile') { z <- z[is.finite(z)] at = stats::quantile(z, names=F, na.rm=TRUE) axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args) # at <- c(0, 1:5 * (1/5)) # at <- minz + zrange * at } else { at <- graphics::axTicks(2, c(minz, maxz, 4)) } at <- round(at, decs) axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args) } if (!horizontal) { if (is.null(breaks)) { image(ix, iy, iz, xaxt="n", yaxt="n", xlab = "", ylab = "", col = col) } else { image(ix, iy, iz, xaxt="n", yaxt="n", xlab = "", ylab = "", col = col, breaks = breaks) } } else { if (is.null(breaks)) { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col) } else { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, breaks = breaks) } } axis.args = c(axis.args, cex.axis=0.75, tcl=-0.15, list(mgp=c(3, 0.4, 0)) ) do.call("axis", axis.args) #graphics::axis(axis.args$side, at=min(iz), las=ifelse(horizontal, 0, 2)) graphics::box() # title(main = list(legend.lab, cex=1, font=1)) if (!is.null(legend.lab)) { # graphics::mtext(legend.lab, side=3, line=0.75) #legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) legend.args <- list(text = legend.lab, side=3, line=0.75) } if (!is.null(legend.args)) { #do.call(graphics::mtext, legend.args) } } .plot2 <- function(x, maxpixels=100000, col=rev(terrain.colors(25)), xlab='', ylab='', asp, box=TRUE, add=FALSE, legend=TRUE, legend.at='', ...) { if (!add & missing(asp)) { if (couldBeLonLat(x)) { ym <- mean(x@extent@ymax + x@extent@ymin) asp <- min(5, 1/cos((ym * pi)/180)) } else { asp = 1 } } plotArea <- .plotSpace(asp) x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) xticks <- graphics::axTicks(1, c(xmin(x), xmax(x), 4)) yticks <- graphics::axTicks(2, c(ymin(x), ymax(x), 4)) if (xres(x) %% 1 == 0) xticks = round(xticks) if (yres(x) %% 1 == 0) yticks = round(yticks) y <- yFromRow(x, nrow(x):1) z <- t((getValues(x, format='matrix'))[nrow(x):1,]) x <- xFromCol(x,1:ncol(x)) if (add) { image(x=x, y=y, z=z, col=col, axes=FALSE, xlab=xlab, ylab=ylab, add=TRUE, ...) } else { if (legend) { graphics::par(pty = "m", plt=plotArea$legendPlot, err = -1) .plotLegend(z, col, legend.at=legend.at, ...) graphics::par(new=TRUE, plt=plotArea$mainPlot) } image(x=x, y=y, z=z, col=col, axes=FALSE, xlab=xlab, ylab=ylab, asp=asp, ...) graphics::axis(1, at=xticks, cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.25, 0)) las = ifelse(max(nchar(as.character(yticks)))> 5, 0, 1) graphics::axis(2, at=yticks, las = las, cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.75, 0) ) #graphics::axis(3, at=xticks, labels=FALSE, lwd.ticks=0) #graphics::axis(4, at=yticks, labels=FALSE, lwd.ticks=0) if (box) graphics::box() } } #.plot2(r, legend=T) # .plot2(r, legend.at='quantile') # plot(wrld_simpl, add=T) raster/R/connection.R0000644000176200001440000000405114160021141014223 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('readStart', signature(x='Raster'), function(x, ...) { if ( fromDisk(x) ) { return (.openConnection(x, ...)) } else { return(x) } } ) setMethod('readStart', signature(x='RasterStack'), function(x, ..., maxopen=100) { fd <- sapply(x@layers, fromDisk) ld <- sum(fd) if (isTRUE( ld > 0 & ld <= maxopen)) { d <- which(fd) for (i in d) { x@layers[[i]] <- readStart(x@layers[[i]], con.check=103, ...) } } x } ) .openConnection <- function(x, silent=TRUE, con.check=Inf, ...) { fn <- trim(x@file@name) driver <- .driver(x) if (driver == "gdal") { attr(x@file, "con") <- rgdal::GDAL.open(fn, silent=silent) x@file@open <- TRUE } else if (.isNativeDriver(driver)) { # R has a max of 128 connections if (length(getAllConnections()) < con.check) { fn <- .setFileExtensionValues(fn, driver) attr(x@file, "con") <- file(fn, "rb") x@file@open <- TRUE } } else if (driver == 'netcdf') { attr(x@file, 'con') <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) x@file@open <- TRUE # } else if (driver == 'ascii') { # cannot be opened } x } setMethod('readStop', signature(x='Raster'), function(x) { if ( fromDisk(x) ) { return (.closeConnection(x)) } else { return(x) } } ) setMethod('readStop', signature(x='RasterStack'), function(x) { d <- which(sapply(x@layers, fromDisk)) if (length(d) > 0) { for (i in d) { x@layers[[i]] <- readStop(x@layers[[i]]) } } x } ) .closeConnection <- function(x) { driver <- .driver(x) if (driver == "gdal") { try( rgdal::closeDataset(x@file@con), silent = TRUE ) } else if (.isNativeDriver(driver)) { try( close(x@file@con), silent = TRUE ) } else if (driver == 'netcdf') { try( ncdf4::nc_close(x@file@con), silent=TRUE) } #else if (driver == 'ascii') { } x@file@open <- FALSE attr(x@file, 'con') <- NULL x # attr(x@file, "con" <- "") } raster/R/drivers.R0000644000176200001440000000234314160021141013544 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 0.9 # Licence GPL v3 .nativeDrivers <- function() { return( c("raster", "SAGA", "IDRISI", "IDRISIold", "BIL", "BSQ", "BIP") ) } .nativeDriversLong <- function() { return( c("R-raster", "SAGA GIS", "IDRISI", "IDRISI (img/doc)", "Band by Line", "Band Sequential", "Band by Pixel") ) } .isNativeDriver <- function(d) { return( d %in% .nativeDrivers() ) } writeFormats <- function() { if ( .requireRgdal(FALSE) ) { gd <- .gdalWriteFormats() short <- c(.nativeDrivers(), 'ascii', 'CDF', as.vector(gd[,1])) long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', as.vector(gd[,2])) # short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', as.vector(gd[,1])) # long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', 'big.matrix', as.vector(gd[,2])) } else { short <- c(.nativeDrivers(), 'ascii', 'CDF', "") long <- c(.nativeDriversLong(), "Arc ASCII", "NetCDF", "", "rgdal not installed") # short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', "") # long <- c(.nativeDriversLong(), "Arc ASCII", "NetCDF", "big.matrix", "", "rgdal not installed") } m <- cbind(short, long) colnames(m) <- c("name", "long_name") return(m) } raster/R/extend.R0000644000176200001440000000746714160021141013371 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Licence GPL v3 # revised November 2011 # version 1.0 setMethod('extend', signature(x='Extent'), # function by Etienne B. Racine function(x, y, ...) { if (length(y) == 1) { y <- rep(y, 4) } else if (length(y) == 2) { y <- rep(y, each=2) } else if (! length(y) == 4 ) { stop('argument "y" should be a vector of 1, 2, or 4 elements') } x@xmin <- x@xmin - y[1] x@xmax <- x@xmax + y[2] x@ymin <- x@ymin - y[3] x@ymax <- x@ymax + y[4] methods::validObject(x) x } ) setMethod('extend', signature(x='Raster'), function(x, y, value=NA, snap='near', filename='', ...) { if (is.vector(y)) { if (length(y) <= 2) { adj <- abs(y) * rev(res(x)) y <- extent(x) y@ymin <- y@ymin - adj[1] y@ymax <- y@ymax + adj[1] y@xmin <- y@xmin - adj[2] y@xmax <- y@xmax + adj[2] } } test <- try ( y <- extent(y), silent=TRUE ) if (inherits(test, "try-error")) { stop('Cannot get an Extent object from argument y') } filename <- trim(filename) y <- alignExtent(y, x, snap=snap) # only expanding here, not cropping y <- union(y, extent(x)) if (nlayers(x) <= 1) { out <- raster(x) leg <- x@legend } else { out <- brick(x, values=FALSE) leg <- methods::new('.RasterLegend') } out@data@names <- names(x) out <- setExtent(out, y, keepres=TRUE) if (any(is.factor(x))) { # if (is.na(value)) { perhaps need to check if value is a level levels(out) <- levels(x) } if (nrow(x) == nrow(out) & ncol(x) == ncol(out)) { # nothing to do. return(x) } if (! hasValues(x) ) { return(out) } dtp <- FALSE datatype <- list(...)$datatype if (is.null(datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } dtp <- TRUE } if (canProcessInMemory(out)) { d <- matrix(value, nrow=ncell(out), ncol=nlayers(x)) d[cellsFromExtent(out, extent(x)), ] <- getValues(x) x <- setValues(out, d) if (filename != '') { if (dtp) { x <- writeRaster(x, filename=filename, datatype=datatype, ...) } else { x <- writeRaster(x, filename=filename, ...) } } return(x) } else { tr <- blockSize(out) tr$old <- rep(TRUE, tr$n) startrow <- rowFromY(out, yFromRow(x, 1)) endrow <- rowFromY(out, yFromRow(x, nrow(x))) if (endrow < nrow(out) | startrow > 1) { if (nrow(out) > endrow) { continuerow <- endrow + 1 } else { continuerow <- NULL } tr$row <- sort(unique(c(tr$row, startrow, continuerow))) tr$nrows <- c(tr$row[-1], nrow(out)+1) - tr$row tr$n <- length(tr$row) tr$old <- (tr$row <= endrow) & ((tr$row+tr$nrows-1) >= startrow) } startcol <- colFromX(out, xFromCol(x, 1)) endcol <- colFromX(out, xFromCol(x, ncol(x))) pb <- pbCreate(tr$n, label='extend', ...) if (dtp) { out <- writeStart(out, filename=filename, datatype=datatype, ... ) } else { out <- writeStart(out, filename=filename, ... ) } if ((startcol == 1) & endcol == ncol(out)) { # to make it faster for this case for (i in 1:tr$n) { if (tr$old[i]) { d <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) } else { d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) } out <- writeValues(out, d, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) if (tr$old[i]) { cells <- startcol:endcol + rep((0:(tr$nrows[i]-1)) * ncol(out), each=endcol-startcol+1) d[cells, ] <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) } out <- writeValues(out, d, tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) return(out) } } ) raster/R/nsidcICE.R0000644000176200001440000000412014160021141013502 0ustar liggesusers.rasterFromNSIDCFile <- function(x) { ## check name structure ## "nt_19781119_f07_v01_s.bin" bx <- basename(x) ## test that we can get a date from this ## (as POSIXct so that Z-comparisons are more natural) dts <- as.POSIXct(basename(x), format = "nt_%Y%m%d", tz = "UTC") ## test that we see _f and _v fyes <- tolower(substr(bx, 13L, 13L)) %in% c("f", "n") vyes <- tolower(substr(bx, 17L, 17L)) %in% c("v", "n") ## finally, it's north or south hemi <- tolower(substr(bx, 21L, 21L)) hyes <- hemi %in% c("s", "n") if(!(!is.na(dts) & fyes & vyes & hyes)) return(NULL) ## NSIDC projection and grid size ## https://nsidc.org/data/polar_stereo/ps_grids.html ## http://spatialreference.org/ref/?search=nsidc ## Hughes 1980 ellipsoid, True Scale Lat is +/-70 if (hemi == "s") { prj <- "+proj=stere +lat_0=-90 +lat_ts=-70 +lon_0=0 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs" dims <- c(316L, 332L) ext <- c(-3950000, 3950000, -3950000, 4350000) } else { ## northern hemisphere prj <- "+proj=stere +lat_0=90 +lat_ts=70 +lon_0=-45 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs" dims <- c(304, 448) ext <- c(-3837500, 3762500, -5362500, 5837500) } on.exit(close(con)) con <- file(x, open = "rb") ## chuck the header try1 <- try(trash <- readBin(con, "integer", size = 1, n = 300)) ## TODO: warnings that we thought it was NSIDC, but it did not work? if (inherits(try1, "try-error")) return(NULL) dat <- try(readBin(con, "integer", size = 1, n = prod(dims), endian = "little", signed = FALSE)) if (inherits(dat, "try-error")) return(NULL) r100 <- dat > 250 r0 <- dat < 1 ## if (rescale) { dat <- dat/2.5 ## rescale back to 100 ## } ## if (setNA) { dat[r100] <- NA ## dat[r0] <- NA ## } r <- raster(t(matrix(dat, dims[1])), xmn=ext[1], xmx=ext[2], ymn=ext[3], ymx=ext[4], crs=prj) setZ(r, dts, name = "time") } raster/R/arith.R0000644000176200001440000002242514160021141013200 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setMethod("Arith", signature(e1='Raster', e2='missing'), function(e1, e2){ methods::callGeneric(0, e1) } ) setMethod("Arith", signature(e1='Raster', e2='Raster'), function(e1, e2){ if (!hasValues(e1)) { stop('first Raster object has no values') } if (!hasValues(e2)) { stop('second Raster object has no values') } nl1 <- nlayers(e1) nl2 <- nlayers(e2) nl <- max(nl1, nl2) proj1 <-.getCRS(e1) proj2 <-.getCRS(e2) if ( ! compareRaster(e1, e2, crs=FALSE, stopiffalse=FALSE) ) { if ( compareRaster(e1, e2, extent=FALSE, rowcol=FALSE, crs=TRUE, res=TRUE, orig=TRUE, stopiffalse=TRUE) ) { ie <- intersect(extent(e1), extent(e2)) if (is.null(ie)) { stop() } warning('Raster objects have different extents. Result for their intersection is returned') e1 <- crop(e1, ie) e2 <- crop(e2, ie) } else { stop() # stops anyway because compareRaster returned FALSE } } if (nl > 1) { r <- brick(e1, values=FALSE, nl=nl) } else { r <- raster(e1) } if (canProcessInMemory(r, 4 * nlayers(e2))) { if (nl1 == nl2 ) { return( setValues(r, values=methods::callGeneric( getValues(e1), getValues(e2))) ) } else { return( setValues(r, matrix(methods::callGeneric( as.vector(getValues(e1)), as.vector(getValues(e2))), ncol=nl)) ) } } else { tr <- blockSize(e1) pb <- pbCreate(tr$n, label='arith') e1 <- readStart(e1) e2 <- readStart(e2) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) if (nl1 == nl2 ) { for (i in 1:tr$n) { v1 <- getValues(e1, row=tr$row[i], nrows=tr$nrows[i]) v2 <- getValues(e2, row=tr$row[i], nrows=tr$nrows[i]) v <- methods::callGeneric( v1, v2 ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v1 <- as.vector(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])) v2 <- as.vector(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) v <- matrix(methods::callGeneric( v1, v2 ), ncol=nl) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e1 <- readStop(e1) e2 <- readStop(e2) pbClose(pb) return(r) } } ) setMethod("Arith", signature(e1='RasterLayer', e2='numeric'), function(e1, e2){ if (!hasValues(e1)) { stop('RasterLayer has no values') } r <- raster(e1) names(r) <- names(e1) if (canProcessInMemory(e1, 4)) { if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } return ( setValues(r, methods::callGeneric(as.numeric(getValues(e1)), e2) ) ) } else { tr <- blockSize(e1) pb <- pbCreate(tr$n, label='arith') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) e1 <- readStart(e1) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2 ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e1 <- readStop(e1) pbClose(pb) return(r) } } ) setMethod("Arith", signature(e1='numeric', e2='RasterLayer'), function(e1, e2){ stopifnot(hasValues(e2)) r <- raster(e2) names(r) <- names(e2) if (canProcessInMemory(e2, 4)) { if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } return ( setValues(r, methods::callGeneric(e1, getValues(e2)) ) ) } else { tr <- blockSize(e2) pb <- pbCreate(tr$n, label='arith') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) e2 <- readStart(e2) if (length(e1) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- methods::callGeneric(e, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e2 <- readStop(e2) pbClose(pb) return(r) } } ) setMethod("Arith", signature(e1='RasterLayer', e2='logical'), function(e1, e2){ e2 <- as.integer(e2) methods::callGeneric(e1, e2) } ) setMethod("Arith", signature(e1='logical', e2='RasterLayer'), function(e1, e2){ e1 <- as.integer(e1) methods::callGeneric(e1, e2) } ) setMethod("Arith", signature(e1='RasterStackBrick', e2='numeric'), function(e1, e2) { if (length(e2) > 1) { nl <- nlayers(e1) if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } b <- brick(e1, values=FALSE) names(b) <- names(e1) if (canProcessInMemory(e1, 4)) { return( setValues(b, t(methods::callGeneric( t(getValues(e1)), e2))) ) } tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile(), bandorder='BIL') e1 <- readStart(e1) for (i in 1:tr$n) { v <- t (methods::callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2) ) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e1 <- readStop(e1) pbClose(pb) return(b) } # else: b <- brick(e1, values=FALSE) names(b) <- names(e1) if (canProcessInMemory(e1, 4)) { return ( setValues(b, methods::callGeneric(getValues(e1), e2) ) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile()) e1 <- readStart(e1) for (i in 1:tr$n) { v <- methods::callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e1 <- readStop(e1) pbClose(pb) return(b) } } ) setMethod("Arith", signature(e1='numeric', e2='RasterStackBrick'), function(e1, e2) { if (length(e1) > 1) { nl <- nlayers(e2) if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } b <- brick(e2, values=FALSE) names(b) <- names(e2) if (canProcessInMemory(e2, 4)) { return( setValues(b, t(methods::callGeneric( e1, t(getValues(e2))))) ) } tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') e2 <- readStart(e2) b <- writeStart(b, filename=rasterTmpFile()) for (i in 1:tr$n) { v <- t (methods::callGeneric( e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) ) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e2 <- readStop(e2) pbClose(pb) return(b) } # else: b <- brick(e2, values=FALSE) names(b) <- names(e2) if (canProcessInMemory(e2, 4)) { return ( setValues(b, methods::callGeneric(e1, getValues(e2)) ) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile()) e2 <- readStart(e2) for (i in 1:tr$n) { v <- methods::callGeneric( e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e2 <- readStop(e2) pbClose(pb) return(b) } } ) setMethod("Arith", signature(e1='RasterStackBrick', e2='logical'), # for Arith with NA function(e1, e2){ e2 <- as.integer(e2) methods::callGeneric(e1, e2) } ) setMethod("Arith", signature(e1='logical', e2='RasterStackBrick'), function(e1, e2){ e1 <- as.integer(e1) methods::callGeneric(e1, e2) } ) .getE2 <- function(e2) { n <- length(e2) if (n == 1) { e2 <- rep(e2, 4) } else if (n == 2) { e2 <- rep(e2, each=2) } else if (n != 4) { stop('use 1, 2, or 4 numbers in arithmetic operations with an Extent') } e2 } .multiply_Extent <- function(e1, e2) { e2 <- abs(e2) if (length(e2) == 4) { return(extent(as.vector(e1) * e2)) } e2 <- rep_len(e2, length.out=2) rx <- e1@xmax - e1@xmin ry <- e1@ymax - e1@ymin dx <- (rx * e2[1] - rx) / 2 dy <- (ry * e2[2] - ry) / 2 e1@xmax <- e1@xmax + dx e1@xmin <- e1@xmin - dx e1@ymax <- e1@ymax + dy e1@ymin <- e1@ymin - dy return(e1) } .add_Extent <- function(e1, e2, g) { if (length(e2) == 4) { return(extent(as.vector(e1) + e2)) } e2 <- rep_len(e2, length.out=2) dx <- e2[1] / 2 dy <- e2[2] / 2 e1@xmax <- e1@xmax + dx e1@xmin <- e1@xmin - dx e1@ymax <- e1@ymax + dy e1@ymin <- e1@ymin - dy return(e1) } setMethod("Arith", signature(e1='Extent', e2='numeric'), function(e1, e2){ g <- as.vector(.Generic) if (g %in% c("/", "*")) { if (g == '/') { e2 <- 1 / e2 } return( .multiply_Extent(e1, e2) ) } else if (g %in% c("+", "-")) { if (g == '-') { e2 <- -1 * e2 } return( .add_Extent(e1, e2) ) } extent(methods::callGeneric(as.vector(e1), .getE2(e2))) } ) setMethod("Arith", signature(e1='numeric', e2='Extent'), function(e1, e2){ methods::callGeneric(e2,e1) } ) raster/R/cellsFromExtent.R0000644000176200001440000000255214160021141015206 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 cellsFromExtent <- function(object, extent, expand=FALSE) { object <- raster(object) extent <- alignExtent(extent(extent), object) innerBox <- intersect(extent(object), extent) if (is.null(innerBox)) { return(NULL) } srow <- rowFromY(object, innerBox@ymax - 0.5 * yres(object)) erow <- rowFromY(object, innerBox@ymin + 0.5 * yres(object)) scol <- colFromX(object, innerBox@xmin + 0.5 * xres(object)) ecol <- colFromX(object, innerBox@xmax - 0.5 * xres(object)) if (expand) { srow <- srow - round((extent@ymax - innerBox@ymax) / yres(object)) erow <- erow + round((innerBox@ymin - extent@ymin) / yres(object)) scol <- scol - round((innerBox@xmin - extent@xmin) / xres(object)) ecol <- ecol + round((extent@xmax - innerBox@xmax) / xres(object)) } return(cellFromRowColCombine(object, srow:erow, scol:ecol)) } # By Mike Sumner extentFromCells <- function (object, cells) { cells <- stats::na.omit(unique(round(cells))) cells <- cells[cells > 0 & cells <= ncell(object)] if (length(cells) < 1) { stop('no valid cells') } r <- res(object) dx <- r[1] * c(-0.5, 0.5) dy <- r[2] * c(-0.5, 0.5) extent(range(xFromCell(object, cells)) + dx, range(yFromCell(object, cells)) + dy) } raster/R/xyMinMax.R0000644000176200001440000000220414160021141013634 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod('xmin', signature(x='BasicRaster'), function(x) { return(extent(x)@xmin) }) setMethod('xmax', signature(x='BasicRaster'), function(x) { return(extent(x)@xmax) }) setMethod('ymin', signature(x='BasicRaster'), function(x) { return(extent(x)@ymin) }) setMethod('ymax', signature(x='BasicRaster'), function(x) { return(extent(x)@ymax) }) setMethod('xmin', signature(x='Extent'), function(x) { return(x@xmin) }) setMethod('xmax', signature(x='Extent'), function(x) { return(x@xmax) }) setMethod('ymin', signature(x='Extent'), function(x) { return(x@ymin) }) setMethod('ymax', signature(x='Extent'), function(x) { return(x@ymax) }) setMethod('xmin', signature(x='Spatial'), function(x) { return(extent(x)@xmin) }) setMethod('xmax', signature(x='Spatial'), function(x) { return(extent(x)@xmax) }) setMethod('ymin', signature(x='Spatial'), function(x) { return(extent(x)@ymin) }) setMethod('ymax', signature(x='Spatial'), function(x) { return(extent(x)@ymax) }) raster/R/stackApply.R0000644000176200001440000000434614160021141014206 0ustar liggesusers# Author: Robert J. Hijmans # Date: August 2010 # Version 1 # Licence GPL v3 stackApply <- function(x, indices, fun, filename='', na.rm=TRUE, ...) { nl <- nlayers(x) if (nl == 1) { makemat <- TRUE } else { makemat <- FALSE } fnames <- FALSE if (is.factor(indices)) { nms <- levels(indices) indices <- as.integer(indices) fnames <- TRUE } ind <- vector(length=nl) # perhaps we need recycling: ind[] <- indices uin <- unique(ind) if (fnames) { layernames <- paste0('level_', nms[uin]) } else { layernames <- paste0('index_', uin) } nlout <- length(uin) if (nlout > 1) { out <- brick(x, values=FALSE) out@data@nlayers <- nlout } else { out <- raster(x) } names(out) <- layernames filename <- trim(filename) rowcalc <- FALSE fun <- .makeTextFun(fun) if (class(fun)[1] == 'character') { rowcalc <- TRUE fun <- .getRowFun(fun) } if (canProcessInMemory(out, nl+nlout)) { x <- getValues(x) if (makemat) { x <- matrix(x, ncol=1) } pb <- pbCreate(3, label='stackApply', ...) pbStep(pb) if (rowcalc) { v <- lapply(uin, function(i) fun(x[, ind==i, drop=FALSE], na.rm=na.rm)) } else { v <- lapply(uin, function(i, ...) apply(x[, ind==i, drop=FALSE], 1, fun, na.rm=na.rm)) } pbStep(pb) v <- do.call(cbind, v) out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } if (filename == '') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=nl+nlout) pb <- pbCreate(tr$n, label='stackApply', ...) for (i in 1:tr$n) { a <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (makemat) { a <- matrix(a, ncol=1) } if (rowcalc) { v <- lapply(uin, function(i) fun(a[, ind==i, drop=FALSE], na.rm=na.rm)) } else { v <- lapply(uin, function(i, ...) apply(a[, ind==i, drop=FALSE], 1, fun, na.rm=na.rm)) } v <- do.call(cbind, v) out <- writeValues(out, v, tr$row[i]) pbStep(pb) } out <- writeStop(out) # only raster format stores layer names names(out) <- layernames pbClose(pb) return(out) } raster/R/setCV.R0000644000176200001440000000213514160021141013111 0ustar liggesusers .setCV <- function(x, v, col) { stopifnot(length(v) == (length(col)+1)) v <- as.numeric(v) x@legend@values <- v x@legend@color <- col x@legend@colortable <- vector() x } #val <- c(-1, -0.3, -0.2, 0, 0.1, 0.3, 0.4, 0.6, 0.8, 1, 10) #ct <- c(grDevices::col2rgb("white"),grDevices::col2rgb("blue"),grDevices::rgb(205,193,173, maxColorValue = 255), grDevices::rgb(150,150,150, maxColorValue = 255), grDevices::rgb(120,100,51, maxColorValue = 255), grDevices::rgb(120,200,100, maxColorValue = 255), grDevices::rgb(28,144,3, maxColorValue = 255), grDevices::rgb(6,55,0, maxColorValue = 255), grDevices::rgb(10,30,25, maxColorValue = 255), grDevices::rgb(6,27,7, maxColorValue = 255)) .setCT <- function(x, v, col, na='white') { v <- as.numeric(v) na <- which(is.na(v)) if (length(na)==0) { v <- c(NA, v) col <- c('white', col) } else { v <- c(v[na], v[-na]) col <- c(col[na], col[-na]) } notrgb <- which(substr(col, 1, 1) != '#') col[notrgb] <- grDevices::rgb(t(grDevices::col2rgb(col[notrgb])), maxColorValue=255) x@legend@values <- v x@legend@color <- col x } raster/R/terrain.R0000644000176200001440000000735514160021141013542 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2011 # Version 1.0 # Licence GPL v3 setMethod("terrain", signature(x="RasterLayer"), function(x, opt="slope", unit="radians", neighbors=8, filename="", ...) { # if (nlayers(x) > 1) { # warning("first layer of x is used") # x <- subset(x, 1) # } stopifnot(hasValues(x)) stopifnot(is.character(filename)) filename <- trim(filename) stopifnot(is.character(opt)) opt <- unique(trim(tolower(opt))) i <- which(! opt %in% c("tri", "tpi", "roughness","slope", "aspect", "flowdir")) if (length(i) > 0) { stop('invalid value in "opt", choose from:\n "tri", "tpi", "roughness", "slope", "aspect", "flowdir"') } stopifnot(length(opt) > 0 ) nopt <- rep(0, 8) if ("tri" %in% opt) { nopt[1] <- 1 } if ("tpi" %in% opt) { nopt[2] <- 1 } if ("roughness" %in% opt) { nopt[3] <- 1 } if ("slope" %in% opt) { if (neighbors == 4) { nopt[4] <- 1 } else { nopt[6] <- 1 } } if ("aspect" %in% opt) { if (neighbors == 4) { nopt[5] <- 1 } else { nopt[7] <- 1 } } if ("flowdir" %in% opt) { nopt[8] <- 1 } nopt <- as.integer(nopt) nl <- sum(nopt) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE, nl=nl) } names(out) <- c("tri", "tpi", "roughness","slope", "aspect", "slope", "aspect", "flowdir")[as.logical(nopt)] rs <- as.double(res(out)) un <- as.integer(1) lonlat <- FALSE if ("slope" %in% opt | "aspect" %in% opt | "flowdir" %in% opt) { stopifnot(is.character(unit)) unit <- trim(tolower(unit)) stopifnot(unit %in% c("degrees", "radians", "tangent")) if (unit=="degrees") { un <- as.integer(0) } else if (unit=="tangent") { un <- as.integer(2) } stopifnot(neighbors %in% c(4, 8)) stopifnot(! is.na(projection(x)) ) lonlat <- isLonLat(out) if (!lonlat & couldBeLonLat(out)) { warning("assuming crs is longitude/latitude") lonlat <- TRUE } if (lonlat) { rs[2] <- pointDistance(cbind(0,0), cbind(0, rs[2]), longlat=TRUE) } } lonlat <- as.integer(lonlat) if (canProcessInMemory(out)) { if (lonlat) { y <- yFromRow(x, 1:nrow(x)) } else { y <- 0 } v <- .terrain(as.double(values(x)), as.integer(dim(out)), rs, un, nopt, lonlat, y) out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename, ...) } } else { out <- writeStart(out, filename, ...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label="terrain", ...) nc <- ncol(out) buf <- 1:nc v <- getValues(x, row=1, nrows=tr$nrows[1]+1) y <- 0 if (lonlat) { y <- yFromRow(out, 1:(tr$nrows[1]+1)) } v <- .terrain(as.double(v), as.integer(c(tr$nrows[1]+1, nc)), rs, un, nopt, lonlat, y) out <- writeValues(out, matrix(v, ncol=nl), 1) pbStep(pb, 1) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+2) if (lonlat) { y <- yFromRow(out, (tr$row[i]-1) : (tr$row[i]+tr$nrows[i])) } v <- .terrain(as.double(v), as.integer(c(tr$nrows[i]+2, nc)), rs, un, nopt, lonlat, y) v <- matrix(v, ncol=nl)[-buf,] out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } i <- tr$n v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+1) if (lonlat) { y <- yFromRow(out, (tr$row[i]-1) : (tr$row[i]+tr$nrows[i]-1)) } v <- .terrain(as.double(v), as.integer(c(tr$nrows[i]+1, nc)), rs, un, nopt, lonlat, y) v <- matrix(v, ncol=nl)[-buf,] out <- writeValues(out, v, tr$row[i]) pbStep(pb, tr$n) out <- writeStop(out) pbClose(pb) } return(out) } ) # x <- terrain(utm, out="tri") raster/R/moran.R0000644000176200001440000000341614160021141013204 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 ..moran <- function(x, directions=8) { stopifnot(directions %in% c(4,8)) # not memory safe adj <- adjacent(x, 1:ncell(x), target=1:ncell(x), directions=8, pairs=TRUE) z <- x - cellStats(x, mean) wZiZj <- stats::na.omit(z[adj[,1]] * z[adj[,2]]) z2 <- cellStats(z*z, sum) NS0 <- (ncell(z)-cellStats(z, 'countNA')) / length(wZiZj) mI <- NS0 * sum(wZiZj) / z2 return(mI) } Moran <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3) ) { z <- x - cellStats(x, mean) wZiZj <- focal(z, w=w, fun='sum', na.rm=TRUE, pad=TRUE) wZiZj <- overlay(wZiZj, z, fun=function(x,y){ x * y }) wZiZj <- cellStats(wZiZj, sum) z2 <- cellStats(z*z, sum) n <- ncell(z) - cellStats(z, 'countNA') # weights if (sum(! unique(w) %in% 0:1) > 0) { zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal( zz, w=w, fun='sum', na.rm=TRUE, pad=TRUE) } else { w2 <- w w2[w2==0] <- NA W <- focal( z, w=w2, fun=function(x, ...){ as.double(sum(!is.na(x))) }, pad=TRUE) } NS0 <- n / cellStats(W, sum) mI <- NS0 * wZiZj / z2 return(mI) } MoranLocal <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3)) { z <- x - cellStats(x, mean) #weights #w <- .getFilter(w) if (sum(! unique(w) %in% 0:1) > 0) { zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal( zz, w=w, na.rm=TRUE, pad=TRUE) } else { w2 <- w w2[w2==0] <- NA W <- focal( z, w=w2, fun=function(x, ...){ sum(!is.na(x)) }, na.rm=TRUE, pad=TRUE) } lz <- focal(z, w=w, na.rm=TRUE, pad=TRUE) / W n <- ncell(x) - cellStats(x, 'countNA') s2 <- cellStats(x, 'sd')^2 # adjust variance denominator from n-1 to n #s2 <- (s2 * (n-1)) / n (z / s2) * lz } raster/R/writeRaster.R0000644000176200001440000001413714160021141014405 0ustar liggesusers# Author: Robert J. Hijmans # Date: September 2009 # Version 1.0 # Licence GPL v3 setMethod('writeRaster', signature(x='RasterLayer', filename='character'), function(x, filename, format, ...) { if (!hasValues(x)) { warning('all cell values are NA') } filename <- trim(filename) if (filename == '') { stop('provide a filename') } filename <- .fullFilename(filename, expand=TRUE) if (!file.exists(dirname(filename))) { stop("Attempting to write a file to a path that does not exist:\n ", dirname(filename)) } filetype <- .filetype(format=format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype == 'KML') { KML(x, filename, ...) return(invisible(x)) } verylarge <- ncell(x) > 1000000000 # to simplify we could treat all cases as !inMemory if (! inMemory(x) | verylarge ) { if ( toupper(x@file@name) == toupper(filename) ) { stop('filenames of source and target should be different') } tr <- blockSize(x) pb <- pbCreate(tr$n, ...) # use x to keep layer name r <- writeStart(x, filename=filename, format=filetype, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } if (isTRUE(any(is.factor(x)))) { levels(r) <- levels(x) } #r <- setZ(r, getZ(x)) r <- writeStop(r) pbClose(pb) return(invisible(r)) } if (.isNativeDriver(filetype)) { out <- raster(x) names(out) <- names(x) try( out@history <- x@history, silent=TRUE) levels(out) <- levels(x) out@legend@colortable <- colortable(x) dots <- list(...) if (is.integer(x[1]) & is.null(dots$dataype)) { out <- .startRasterWriting(out, filename, format=filetype, dataytpe="INT4S", ...) } else { out <- .startRasterWriting(out, filename, format=filetype, ...) } out <- writeValues(out, x@data@values, 1) return( .stopRasterWriting(out) ) } else if (filetype=='ascii') { x <- .writeAscii(x, filename=filename,...) # } else if (filetype=='big.matrix') { # x <- .writeBigMatrix(x, filename=filename,...) } else if (filetype=='CDF') { x <- .startWriteCDF(x, filename=filename, ...) x <- .writeValuesCDF(x, x@data@values) return( .stopWriteCDF(x) ) } else { x <- .writeGDALall(x, filename=filename, format=filetype, ...) } return(invisible(x)) } ) setMethod('writeRaster', signature(x='RasterStackBrick', filename='character'), function(x, filename, format, bylayer=FALSE, suffix='numbers', ...) { if (!hasValues(x)) { warning('all cell values are NA') } filename <- trim(filename) if (bylayer) { nl <- nlayers(x) if (length(filename) > 1) { if (length(filename) != nlayers(x) ) { stop('the number of filenames is > 1 but not equal to the number of layers') } filename <- .fullFilename(filename, expand=TRUE) filetype <- .filetype(format, filename=filename[1]) filename <- .getExtension(filename, filetype) } else { if (filename == '') { stop('provide a filename') } filename <- .fullFilename(filename, expand=TRUE) filetype <- .filetype(format, filename=filename) filename <- .getExtension(filename, filetype) ext <- extension(filename) filename <- extension(filename, '') if (suffix[1] == 'numbers') { filename <- paste(filename, '_', 1:nl, ext, sep='') } else if (suffix[1] == 'names') { filename <- paste(filename, '_', names(x), ext, sep='') } else if (length(suffix) == nl) { filename <- paste(filename, '_', suffix, ext, sep='') } else { stop('invalid "suffix" argument') } } if (filetype == 'KML') { layers <- lapply(1:nl, function(i) KML(x[[i]], filename=filename[i], ...)) return(invisible(x)) } if (inherits(x, 'RasterBrick')) { x <- stack(x) } layers <- lapply(1:nl, function(i) writeRaster(x[[i]], filename=filename[i], format=filetype, ...)) return(invisible(stack(layers))) } if (filename == '') { stop('provide a filename') } filename <- .fullFilename(filename, expand=TRUE) filetype <- .filetype(format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype == "ascii") { stop('this file format does not support multi-layer files') } if (filetype == 'KML') { KML(x, filename, ...) return(invisible(x)) } verylarge <- (ncell(x) * nlayers(x)) > 1000000000 if (.isNativeDriver(filetype)) { if (! filetype %in% c("raster", "BIL", "BSQ", "BIP") ) { stop('this file format does not support multi-band files') } out <- brick(x, values=FALSE) names(out) <- names(x) z <- getZ(x) if (!is.null(z)) { out <- setZ(out, z) } out <- writeStart(out, filename, format=filetype, ...) if (inMemory(x) & (!verylarge)) { out <- writeValues(out, values(x), 1) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { out <- writeValues(out, getValues(x, tr$row[i], tr$nrows[i]), tr$row[i]) pbStep(pb, i) } pbClose(pb) } out <- .stopRasterWriting(out) return( invisible(out) ) } # else if ( inMemory(x) & (!verylarge)) { if (filetype=='CDF') { b <- brick(x, values=FALSE) b@z <- x@z b <- .startWriteCDF(b, filename=filename, ...) b <- .writeValuesBrickCDF(b, values(x)) x <- .stopWriteCDF(b) } else { x <- .writeGDALall(x, filename=filename, format=filetype, ...) } return(invisible(x)) } else { if ( toupper(filename(x)) == toupper(filename) ) { stop('filenames of source and destination should be different') } b <- brick(x, values=FALSE) if (filetype=='CDF') { b@z <- x@z } tr <- blockSize(b) pb <- pbCreate(tr$n, ...) x <- readStart(x, ...) b <- writeStart(b, filename=filename, format=filetype, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) x <- readStop(x) pbClose(pb) return(invisible(b)) } } ) raster/R/sampleInt.R0000644000176200001440000000177014160021141014025 0ustar liggesusers# Author: Robert J. Hijmans # Date : Febrary 2009 # Version 0.9 # Licence GPL v3 sampleInt <- function(n, size, replace=FALSE) { n <- round(n[1]) size <- round(size[1]) stopifnot(n > 0) stopifnot(size > 0) if (!replace) { switched <- FALSE done <- FALSE if (size > (0.66 * n)) { if (size > n ) { warning('size changed to n because it cannot be larger than n when replace is FALSE') size <- n } if (size == n) { done <- TRUE } switched <- TRUE size <- n - size } samp <- NULL while (! done) { f <- ceiling(stats::runif(size * 1.1) * n) samp <- unique(c(samp, f)) if (length(samp) >= size) { samp <- samp[1:size] done <- TRUE } } if (switched) { if (!is.null(samp)) { samp <- (1:n)[-samp] lsp <- length(samp) samp <- samp[sample.int(lsp)] } else { samp <- sample.int(n) } } } else { samp <- ceiling(stats::runif( size ) * n) } return( samp ) } raster/R/intersect.R0000644000176200001440000000211414160021141014062 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 setMethod('intersect', signature(x='Raster', y='ANY'), function(x, y) { y <- extent(y) crop(x, y) } ) setMethod('intersect', signature(x='Extent', y='ANY'), function(x, y) { y <- extent(y) x@xmin <- max(x@xmin, y@xmin) x@xmax <- min(x@xmax, y@xmax) x@ymin <- max(x@ymin, y@ymin) x@ymax <- min(x@ymax, y@ymax) if ((x@xmax <= x@xmin) | (x@ymax <= x@ymin) ) { #warning('Objects do not overlap') return(NULL) } return(x) } ) .intersectExtent <- function(x, ..., validate=TRUE) { objects <- c(x, list(...)) if (length(objects) == 1) { return(extent(x)) } e <- extent(objects[[1]]) for (i in 2:length(objects)) { e2 <- extent(objects[[i]]) e@xmin <- max(e@xmin, e2@xmin) e@xmax <- min(e@xmax, e2@xmax) e@ymin <- max(e@ymin, e2@ymin) e@ymax <- min(e@ymax, e2@ymax) } if ((e@xmax <= e@xmin) | (e@ymax <= e@ymin) ) { if (validate) { stop('Objects do not intersect') } else { return(NULL) } } return(e) } raster/R/extractPoints.R0000644000176200001440000000661714160021141014745 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='matrix'), function(x, y, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, ...){ .xyValues(x, y, method=method, buffer=buffer, small=small, cellnumbers=cellnumbers, fun=fun, na.rm=na.rm, layer=layer, nl=nl, df=df, factors=factors, ...) }) setMethod('extract', signature(x='Raster', y='data.frame'), function(x, y, ...){ return( .xyValues(x, as.matrix(y), ...)) }) setMethod('extract', signature(x='Raster', y='SpatialPoints'), function(x, y, ..., df=FALSE, sp=FALSE){ #px <-.getCRS(x, asText=FALSE) px <-.getCRS(x) comp <- compareCRS(px,.getCRS(y), unknown=TRUE) if (!comp) { if (!.requireRgdal()) { warning('CRS of SpatialPoints and rater do not match') } else { warning('Transforming SpatialPoints to the crs of the Raster') y <- sp::spTransform(y, px) } } if (sp) { v <- .xyValues(x, sp::coordinates(y)[,1:2,drop=FALSE], ..., df=TRUE) if (!.hasSlot(y, 'data')) { y <- sp::SpatialPointsDataFrame(y, v[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, v[, -1, drop=FALSE]) } return(y) } else { .xyValues(x, sp::coordinates(y)[,1:2,drop=FALSE], ..., df=df) } }) .xyValues <- function(object, xy, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, sp=FALSE, ...) { nlyrs <- nlayers(object) if (nlyrs > 1) { if (missing(layer)) { layer <- 1 } if (missing(nl)) { nl <- nlyrs } layer <- min(max(1, round(layer)), nlyrs) nl <- min(max(1, round(nl)), nlyrs-layer+1) } else { layer <- 1 nl <- 1 } if (dim(xy)[2] != 2) { stop('xy should have 2 columns only.\nFound these dimensions: ', paste(dim(xy), collapse=', ') ) } if (! is.null(buffer)) { if (method != 'simple') { warning('method argument is ignored when a buffer is used') } res <- .xyvBuf(object, xy, buffer, fun, na.rm, layer=layer, nl=nl, cellnumbers=cellnumbers, small=small) } else if (method == 'bilinear') { res <- .bilinearValue(object, xy, layer=layer, n=nl) if (cellnumbers) { warning("'cellnumbers' does not apply for bilinear values") cellnumbers = FALSE } } else if (method=='simple') { cells <- cellFromXY(object, xy) res <- .cellValues(object, cells, layer=layer, nl=nl) if (cellnumbers) { res <- cbind(cells, res) if (ncol(res) == 2) { colnames(res)[2] <- names(object)[layer] } } } else { stop('invalid "method" argument. Should be simple or bilinear.') } if (df) { if (is.list(res)) { res <- lapply(1:length(res), function(x) if (length(res[[x]]) > 0) cbind(ID=x, res[[x]])) res <- do.call(rbind, res) rownames(res) <- NULL } else { res <- data.frame(cbind(ID=1:NROW(res), res)) } lyrs <- layer:(layer-1+nl) if (cellnumbers) { cn <- c('ID', 'cells', names(object)[lyrs]) } else { cn <- c('ID', names(object)[lyrs]) } colnames(res) <- cn if (any(is.factor(object)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(object, v[,1], layer)) } else { v <- .insertFacts(object, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } res } raster/R/hdrVRT.R0000644000176200001440000000517114164674677013301 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 .writeHdrVRT <- function(x) { fn <- fname <- x@file@name if (tolower(extension(fn)) == '.vrt') { stop('cannot (over)write a vrt header for a vrt file') } if (tolower(extension(fn)) == '.grd') { extension(fn) <- '.gri' } extension(fname) <- 'vrt' pixsize <- dataSize(x@file@datanotation) nbands <- nlayers(x) bandorder <- x@file@bandorder if (bandorder == 'BIL') { pixoff <- pixsize lineoff <- pixsize * x@ncols * nbands imgoff <- ((1:nbands)-1) * x@ncols * pixsize } else if (bandorder == 'BSQ') { pixoff <- pixsize lineoff <- pixsize * x@ncols imgoff <- ((1:nbands)-1) * ncell(x) * pixsize } else if (bandorder == 'BIP') { pixoff <- pixsize * nbands lineoff <- pixsize * x@ncols * nbands imgoff <- (1:nbands)-1 } datatype <- .getGdalDType(x@file@datanotation) if (x@file@byteorder == "little") { byteorder <- "LSB" } else { byteorder <- "MSB" } if (! x@file@toptobottom) { rotation <- 180 } else { rotation <- 0 } e <- x@extent r <- res(x) prj <- proj4string(x) f <- file(fname, "w") cat('\n' , sep = "", file = f) if (rotated(r)) { cat('', paste(x@rotation@geotrans, collapse=', '), '\n', sep = "", file = f) } else { cat('', e@xmin, ', ', r[1], ', ', rotation, ', ', e@ymax, ', ', 0.0, ', ', -1*r[2], '\n', sep = "", file = f) } if (! is.na(prj) ) { cat('', prj ,'\n', sep = "", file = f) } for (i in 1:nlayers(x)) { cat('\t\n', sep = "" , file = f) cat('\t\t', names(x), '\n', sep = "", file = f) cat('\t\t', basename(fn), '\n', sep = "", file = f) cat('\t\t', imgoff[i], '\n', sep = "", file = f) cat('\t\t', pixoff, '\n', sep = "", file = f) cat('\t\t', lineoff, '\n', sep = "", file = f) cat('\t\t', byteorder, '\n', sep = "", file = f) cat('\t\t', x@file@nodatavalue, '\n', sep = "", file = f) cat('\t\t', x@data@offset, '\n', sep = "", file = f) cat('\t\t', x@data@gain, '\n', sep = "", file = f) cat('\t\n', sep = "", file = f) } cat('\n', sep = "", file = f) close(f) return( invisible(TRUE) ) } raster/R/flip.R0000644000176200001440000000756414160021141013032 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('flip', signature(x='RasterLayer'), function(x, direction='y', filename='', ...) { filename <- trim(filename) outRaster <- .copyWithProperties(x) if (direction[1] == 1) { direction <- 'x' } else if (direction[1] == 2) { direction <- 'y' } if (!(direction %in% c('y', 'x'))) { stop('direction should be "y" or "x"') } if (!canProcessInMemory(outRaster, 2) && filename == '') { filename <- rasterTmpFile() inmemory = FALSE } else { inmemory = TRUE } if ( inmemory ) { x <- getValues(x, format='matrix') if (direction == 'y') { x <- x[nrow(x):1,] } else { x <- x[,ncol(x):1] } outRaster <- setValues(outRaster, as.vector(t(x))) if (filename != '') { outRaster = writeRaster(outRaster, filename=filename, ...) } } else { tr <- blockSize(outRaster) pb <- pbCreate(tr$n, label='flip', ...) outRaster <- writeStart(outRaster, filename=filename, datatype=dataType(x), ... ) if (direction == 'y') { nr <- nrow(outRaster) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- matrix(v, ncol=ncol(x), byrow=TRUE) v <- as.vector(t(v[nrow(v):1, ])) rownr <- nr - tr$row[i] - tr$nrows[i] + 2 outRaster <- writeValues(outRaster, v, rownr) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- matrix(v, ncol=ncol(x), byrow=TRUE) v <- as.vector(t(v[, ncol(v):1])) outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } } outRaster <- writeStop(outRaster) pbClose(pb) } return(outRaster) } ) setMethod('flip', signature(x='RasterStackBrick'), function(x, direction='y', filename='', ...) { filename <- trim(filename) outRaster <- brick(x, values=FALSE) if (direction[1] == 1) { direction <- 'x' } else if (direction[1] == 2) { direction <- 'y' } if (!(direction %in% c('y', 'x'))) { stop('directions should be y or x') } if (!canProcessInMemory(outRaster, 2) && filename == '') { filename <- rasterTmpFile() inmemory = FALSE } else { inmemory = TRUE } nc <- outRaster@ncols if ( inmemory ) { x <- getValues(x) for (i in 1:NCOL(x)) { v <- matrix(x[,i], ncol=nc, byrow=TRUE) if (direction == 'y') { v <- v[nrow(v):1,] } else { v <- v[,ncol(v):1] } x[,i] <- as.vector(t(v)) } outRaster <- setValues(outRaster, x) if (filename != '') { outRaster = writeRaster(outRaster, filename=filename, ...) } } else { tr <- blockSize(outRaster) pb <- pbCreate(tr$n, label='flip', ...) if (inherits(x, 'RasterStack')) { dtype <- 'FLT4S' } else { dtype <- dataType(x) } outRaster <- writeStart(outRaster, filename=filename, datatype=dtype, ... ) if (direction == 'y') { trinv <- tr trinv$row <- rev(trinv$row) trinv$nrows <- rev(trinv$nrows) trinv$newrows <- cumsum(c(1,trinv$nrows))[1:length(trinv$nrows)] for (i in 1:tr$n) { vv <- getValues(x, row=trinv$row[i], nrows=trinv$nrows[i]) for (j in 1:NCOL(vv)) { v <- matrix(vv[,j], nrow=nc) vv[,j] <- as.vector(v[, ncol(v):1]) } outRaster <- writeValues(outRaster, vv, trinv$newrows[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { vv = getValues(x, row=tr$row[i], nrows=tr$nrows[i]) for (j in 1:NCOL(vv)) { v <- matrix(vv[,j], nrow=nc) vv[,j] <- as.vector(v[nrow(v):1, ]) } outRaster <- writeValues(outRaster, vv, tr$row[i]) pbStep(pb, i) } } outRaster <- writeStop(outRaster) pbClose(pb) } return(outRaster) } ) raster/R/shift.R0000644000176200001440000000275514160021141013212 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod('shift', signature(x='Raster'), function(x, dx=0, dy=0, filename='', ...) { dx <- as.numeric(dx[1]) dy <- as.numeric(dy[1]) stopifnot(!is.na(dx) | !is.na(dy)) e <- x@extent e@xmin <- e@xmin + dx e@ymin <- e@ymin + dy e@xmax <- e@xmax + dx e@ymax <- e@ymax + dy x@extent <- e if (filename != '') { x <- writeRaster(x, filename=filename, ...) } if (inherits(x, 'RasterStack')) { x@layers <- sapply(x@layers, function(i){ extent(i) <- e; i}) } return(x) } ) setMethod('shift', signature(x='SpatialPolygons'), function(x, dx=0, dy=0, ...) { a <- data.frame(geom(x)) a$x <- a$x + dx a$y <- a$y + dy a <- as(a, 'SpatialPolygons') crs(a) <- crs(x) if (inherits(x, 'SpatialPolygonsDataFrame')) { a <- sp::SpatialPolygonsDataFrame(a, x@data, match.ID = FALSE) } return(a) } ) setMethod('shift', signature(x='SpatialLines'), function(x, dx=0, dy=0, ...) { a <- data.frame(geom(x)) a$x <- a$x + dx a$y <- a$y + dy a <- as(a, 'SpatialLines') crs(a) <- crs(x) if (inherits(x, 'SpatialLinesDataFrame')) { a <- sp::SpatialLinesDataFrame(a, x@data, match.ID = FALSE) } return(a) } ) setMethod('shift', signature(x='SpatialPoints'), function(x, dx=0, dy=0, ...) { x@coords[,1] <- x@coords[,1] + dx x@coords[,2] <- x@coords[,2] + dy return(x) } ) raster/R/persp.R0000644000176200001440000000125414160021141013217 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod("persp", signature(x='RasterLayer'), function(x, maxpixels=100000, ext=NULL, ...) { x <- sampleRegular(x, size=maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) value <- t((getValues(x, format='matrix'))[nrow(x):1,]) y <- yFromRow(x, nrow(x):1) x <- xFromCol(x,1:ncol(x)) persp(x=x, y=y, z=value, ...) } ) setMethod("persp", signature(x='RasterStackBrick'), function(x, y=1, maxpixels=10000, ext=NULL, ...) { if (y < 1) { y <- 1 } if (y > nlayers(x)) { y <- nlayers(x) } x <- raster(x, y) persp(x=x, maxpixels=maxpixels, ext=ext, ...) } ) raster/R/layerStats.R0000644000176200001440000000530314160021141014220 0ustar liggesusers# Jonathan Greenberg and Robert Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 # Computation of the weighted covariance and (optionally) weighted means of bands in an Raster. # based on code by Mort Canty layerStats <- function(x, stat, w, asSample=TRUE, na.rm=FALSE, ...) { stat <- tolower(stat) stopifnot(stat %in% c('cov', 'weighted.cov', 'pearson')) stopifnot(is.logical(asSample) & !is.na(asSample)) nl <- nlayers(x) n <- ncell(x) mat <- matrix(NA, nrow=nl, ncol=nl) colnames(mat) <- rownames(mat) <- names(x) pb <- pbCreate(nl^2, label='layerStats', ...) if (stat == 'weighted.cov') { if (missing(w)) { stop('to compute weighted covariance a weights layer should be provided') } stopifnot( nlayers(w) == 1 ) if (na.rm) { # a cell is set to NA if it is NA in any layer. That is not ideal, but easier and quicker nas <- calc(x, function(i) sum(i)) * w x <- mask(x, nas) w <- mask(w, nas) } sumw <- cellStats(w, stat='sum', na.rm=na.rm) means <- cellStats(x * w, stat='sum', na.rm=na.rm) / sumw sumw <- sumw - asSample x <- (x - means) * sqrt(w) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x,layer=j) v <- cellStats(r, stat='sum', na.rm=na.rm) / sumw mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) cov.w <- list(mat, means) names(cov.w) <- c("weigthed covariance", "weighted mean") return(cov.w) } else if (stat == 'cov') { means <- cellStats(x, stat='mean', na.rm=na.rm) x <- (x - means) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x, layer=j) if (na.rm) { v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - cellStats(r, stat='countNA') - asSample) } else { v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - asSample) } mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) covar <- list(mat, means) names(covar) <- c("covariance", "mean") return(covar) } else if (stat == 'pearson') { means <- cellStats(x, stat='mean', na.rm=na.rm) sds <- cellStats(x, stat='sd', na.rm=na.rm) x <- (x - means) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x, layer=j) if (na.rm) { v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - cellStats(r, stat='countNA') - asSample) * sds[i] * sds[j]) } else { v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - asSample) * sds[i] * sds[j]) } mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) covar <- list(mat, means) names(covar) <- c("pearson correlation coefficient", "mean") return(covar) } } raster/R/rasterizePolygons.R0000644000176200001440000004500614160021141015634 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 2.0 # Licence GPL v3 .getPutVals <- function(obj, field, n, mask) { if (mask) { return( data.frame(v=rep(1, length=n)) ) } else if (missing(field)) { if (.hasSlot(obj, 'data')) { putvals <- obj@data cn <- validNames(c('ID', colnames(putvals))) cn[1] <- 'ID' putvals <- data.frame(ID=1:nrow(putvals), putvals) colnames(putvals) <- cn } else { putvals <- data.frame(v=as.integer(1:n)) } return(putvals) } else if (isTRUE (is.na(field))) { return( data.frame(v=rep(NA, n)) ) } else if (is.character(field) ) { if (.hasSlot(obj, 'data')) { nms <- names(obj) if (length(field) <= length(nms)) { m <- match(field, nms) if (!all(is.na(m))) { m <- stats::na.omit(m) return(obj@data[, m, drop=FALSE]) } } } } if (NROW(field) == n) { if (is.null(nrow(field))) { return(data.frame(field, stringsAsFactors=FALSE)) } else { return(field) } } if (is.numeric(field)) { putvals <- rep(field, length.out=n) return(data.frame(field=putvals)) } stop('invalid value for field') } .intersectSegments <- function(x1, y1, x2, y2, x3, y3, x4, y4) { # Translated by RH from LISP code by Paul Reiners # http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/linesegments.lisp # Which was translated from the algorithm by Paul Bourke given here: http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ denom <- ((y4 - y3) * (x2 - x1)) - ((x4 - x3) * (y2 - y1)) ua_num <- ((x4 - x3) *(y1 - y3)) - ((y4 - y3) * (x1 - x3)) ub_num <- ((x2 - x1) *(y1 - y3)) - ((y2 - y1) * (x1 - x3)) # If the denominator and numerator for the equations for ua and ub are 0 then the two lines are coincident. if ( denom == 0 ) { if (ua_num == 0 & ub_num == 0) { xmin <- max(x1, x3) if (xmin==x1) {ymin <- y1} else {ymin <- y3} xmax <- min(x2, x4) if (xmax==x2) {ymax <- y2} else {ymax <- y4} # RH: for coincident line (segments) returning two intersections : start and end return(rbind(c(xmin, ymin), c(xmax, ymax))) } #else { # If the denominator for the equations for ua and ub is 0 then the two lines are parallel. # return(c(NA, NA)) # } } else { ua <- round(ua_num / denom, 12) ub <- round(ub_num / denom, 12) if ((ua >= 0 & ua <= 1) & (ub >= 0 & ub <= 1) ) { x <- x1 + ua * (x2 - x1) y <- y1 + ua * (y2 - y1) return(c(x, y)) } } return(c(NA, NA)) } .intersectLinePolygon <- function(line, poly) { resxy <- matrix(NA, ncol=2, nrow=0) miny <- min(line[,2]) maxy <- max(line[,2]) xyxy <- cbind(poly, rbind(poly[-1,], poly[1,])) xyxy <- subset(xyxy, !( (xyxy[,2] > maxy & xyxy[,4] > maxy ) | (xyxy[,2] < miny & xyxy[,4] < miny)) ) if (nrow(xyxy) == 0) { return(resxy) } for (i in 1:nrow(xyxy)) { xy <- .intersectSegments(xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4], line[1,1], line[1,2], line[2,1], line[2,2] ) if (!is.na(xy[1])) { resxy <- rbind(resxy, xy) } } return((resxy)) } .polygonsToRaster <- function(p, rstr, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue="all", getCover=FALSE, filename="", silent=TRUE, faster=TRUE, ...) { npol <- length(p@polygons) pvals <- .getPutVals(p, field, npol, mask) putvals <- pvals[,1] if (ncol(pvals) > 1) { rstr@data@isfactor <- TRUE rstr@data@attributes <- list(pvals) if (!is.character(fun)) { stop('when rasterizing multiple fields you must use "fun=first" or "fun=last"') } else if (!(fun %in% c('first', 'last'))) { stop('when rasterizing multiple fields you must use "fun=first" or "fun=last"') } } if (getCover) { nc <- ncell(rstr) # high precision for possibly small polygons #https://stackoverflow.com/questions/53854910/issue-with-estimating-weighted-mean-from-raster-for-a-polygon-shape-in-r/ fctr <- ifelse(nc < 5, 100, ifelse(nc < 17, 20, 10)) rstr <- disaggregate(raster(rstr), fctr) r <- .fasterize(p, rstr, rep(1, npol), background=0, datatype="INT1U") return( aggregate(r, fctr, mean, na.rm=TRUE, filename=filename, ...) ) } ### new code if (is.character(fun) && (ncol(pvals) == 1) && faster) { if (fun == "last") { if (mask || update) { if (mask && update) stop("either use 'mask' OR 'update'") background = NA r <- .fasterize(p, rstr, pvals[,1], background) if (! hasValues(r)) { if (mask) { warning('there are no values to mask') } else { warning('there are no values to update') } return(r) } if (mask) { r <- mask(rstr, r) } else { if (updateValue[1]=="all") { r <- cover(r, rstr) } else if (updateValue[1]=="NA") { r <- cover(rstr, r, ...) } else if (updateValue[1]=="!NA") { r <- mask(cover(r, rstr), rstr, ...) } else { s <- stack(r, rstr) r <- overlay(rstr, r, fun=function(x,y){ i = (x %in% updateValue & !is.na(y)); x[i] <- y[i]; x }, ... ) } } return(r) } else { return( .fasterize(p, rstr, pvals[,1], background, filename, ...) ) } } } ### end new code leftColFromX <- function ( object, x ) { colnr <- (x - xmin(object)) / xres(object) i <- colnr %% 1 == 0 colnr[!i] <- trunc(colnr[!i]) + 1 colnr[colnr <= 0] <- 1 colnr } rightColFromX <- function ( object, x ) { colnr <- trunc((x - xmin(object)) / xres(object)) + 1 colnr[ colnr > ncol(object) ] <- object@ncols colnr } if (! inherits(p, 'SpatialPolygons') ) { stop('The first argument should be an object of the "SpatialPolygons*" lineage') } filename <- trim(filename) if (!canProcessInMemory(rstr, 3) && filename == '') { filename <- rasterTmpFile() } if (mask & update) { stop('use either "mask" OR "update"') } else if (mask) { oldraster <- rstr #update <- TRUE } else if (update) { oldraster <- rstr if (!is.numeric(updateValue)) { if (is.na(updateValue)) { updateValue <- 'NA' } else if (!(updateValue == 'NA' | updateValue == '!NA' | updateValue == 'all')) { stop('updateValue should be either "all", "NA", "!NA"') } } } rstr <- raster(rstr) if (!is.na(projection(p))) { projection(rstr) <-.getCRS(p) } # check if bbox of raster and p overlap spbb <- sp::bbox(p) rsbb <- bbox(rstr) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # instead of a warning return( init(rstr, function(x) NA) ) # so that clusterR can use this function (overlap with some chunks might be NULL) } npol <- length(p@polygons) pvals <- .getPutVals(p, field, npol, mask) putvals <- pvals[,1] if (ncol(pvals) > 1) { rstr@data@isfactor <- TRUE rstr@data@attributes <- list(pvals) if (!is.character(fun)) { stop('when rasterizing multiple values you must use "fun=first" or "fun=last"') } else if (!(fun %in% c('first', 'last'))) { stop('when rasterizing multiple values you must use "fun=first" or "fun=last"') } } if (is.character(fun)) { if (fun=='first') { fun <- function(x, ...){ stats::na.omit(x)[1] } } else if (fun=='last') { fun <- function(x, ...){ rev(stats::na.omit(x))[1] } } else if (fun == 'count') { fun <- function(x, ...){ sum(!is.na(x)) } field <- 1 } } polinfo <- data.frame(matrix(NA, nrow=npol * 2, ncol=6)) colnames(polinfo) <- c('part', 'miny', 'maxy', 'value', 'hole', 'object') addpol <- polinfo[rep(1, 500), ] rownames(addpol) <- NULL pollist <- list() cnt <- 0 for (i in 1:npol) { nsubpol <- length(p@polygons[[i]]@Polygons) for (j in 1:nsubpol) { cnt <- cnt + 1 if (cnt > dim(polinfo)[1]) { polinfo <- rbind(polinfo, addpol) } polinfo[cnt, 1] <- cnt polinfo[cnt, 2] <- min(p@polygons[[i]]@Polygons[[j]]@coords[,2]) polinfo[cnt, 3] <- max(p@polygons[[i]]@Polygons[[j]]@coords[,2]) polinfo[cnt, 4] <- putvals[i] if ( p@polygons[[i]]@Polygons[[j]]@hole ) { polinfo[cnt, 5] <- 1 } else { polinfo[cnt, 5] <- 0 } polinfo[cnt, 6] <- i pollist[[cnt]] <- p@polygons[[i]]@Polygons[[j]] } } if (! silent) { message('Found ', npol, ' region(s) and ', cnt, ' polygon(s)') } polinfo <- subset(polinfo, polinfo[,1] <= cnt, drop=FALSE) # polinfo <- polinfo[order(polinfo[,1]),] # rm(p) lxmin <- min(spbb[1,1], rsbb[1,1]) - xres(rstr) lxmax <- max(spbb[1,2], rsbb[1,2]) + xres(rstr) # if (getCover) { # return (.polygoncover(rstr, filename, polinfo, lxmin, lxmax, pollist, ...)) # } adj <- 0.5 * xres(rstr) if (filename == "") { v <- matrix(NA, ncol=nrow(rstr), nrow=ncol(rstr)) } else { rstr <- writeStart(rstr, filename=filename, ...) } rxmn <- xmin(rstr) rxmx <- xmax(rstr) rv1 <- rep(NA, ncol(rstr)) holes1 <- rep(0, ncol(rstr)) pb <- pbCreate(nrow(rstr), label='rasterize', ...) for (r in 1:nrow(rstr)) { vals <- NULL holes <- holes1 ly <- yFromRow(rstr, r) myline <- rbind(c(lxmin,ly), c(lxmax,ly)) subpol <- subset(polinfo, !(polinfo[,2] > ly | polinfo[,3] < ly), drop=FALSE) if (length(subpol[,1]) > 0) { updateHoles <- FALSE lastpolnr <- subpol[1,6] rvtmp <- rv1 for (i in 1:nrow(subpol)) { if (i == nrow(subpol)) { updateHoles <- TRUE } else if (subpol[i+1,6] > lastpolnr) { # new polygon updateHoles <- TRUE lastpolnr <- subpol[i+1,6] } mypoly <- pollist[[subpol[i,1]]] intersection <- .intersectLinePolygon(myline, mypoly@coords) #if (nrow(intersection) %% 2 == 1) { # this is a bit speculative # not OK! # intersection <- unique(intersection) #} x <- sort(intersection[,1]) if (length(x) > 0) { if ((nrow(intersection) %% 2 == 1) || ( sum(x[-length(x)] == x[-1]) > 0 )) { # uneven number or duplicates # e.g. single node intersection going out of polygon .... spPnts <- sp::SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr)))) spPol <- sp::SpatialPolygons(list(sp::Polygons(list(mypoly), 1))) over <- sp::over(spPnts, spPol) if ( subpol[i, 5] == 1 ) { holes[!is.na(over)] <- holes[!is.na(over)] - 1 } else { rvtmp[!is.na(over)] <- subpol[i,4] holes[!is.na(over)] <- holes[!is.na(over)] + 1 } # print(paste('exit node intersection on row:', r)) } else { for (k in 1:round(nrow(intersection)/2)) { l <- (k * 2) - 1 x1 <- x[l] x2 <- x[l+1] #if (is.na(x2)) { # txt <- paste('something funny at row:', r, 'polygon:',j) # stop(txt) #} # if (x1 > rxmx) { next } # if (x2 < rxmn) { next } # adjust to skip first cell if the center is not covered by this polygon x1a <- x1 + adj x2a <- x2 - adj if (x1a > rxmx) { next } if (x2a < rxmn) { next } x1a <- min(rxmx, max(rxmn, x1a)) x2a <- min(rxmx, max(rxmn, x2a)) col1 <- leftColFromX(rstr, x1a) col2 <- rightColFromX(rstr, x2a) if (col1 > col2) { spPnts <- sp::SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr)))) spPol <- sp::SpatialPolygons(list(sp::Polygons(list(mypoly), 1))) over <- sp::over(spPnts, spPol) if ( subpol[i, 5] == 1 ) { holes[!is.na(over)] <- holes[!is.na(over)] - 1 } else { rvtmp[!is.na(over)] <- subpol[i,4] holes[!is.na(over)] <- holes[!is.na(over)] + 1 } next } if ( subpol[i, 5] == 1 ) { holes[col1:col2] <- holes[col1:col2] - 1 } else { rvtmp[col1:col2] <- subpol[i,4] holes[col1:col2] <- holes[col1:col2] + 1 } } } } if (updateHoles) { updateHoles <- FALSE rvtmp[holes < 1] <- NA vals <- cbind(vals, rvtmp) rvtmp <- rv1 holes <- holes1 } } } #print(vals) rrv <- rv1 if (!is.null(vals)) { u <- which(rowSums(is.na(vals)) < ncol(vals)) if (length(u) > 0) { if (mask) { rrv[u] <- 1 } else { rrv[u] <- apply(vals[u, ,drop=FALSE], 1, fun, na.rm=TRUE) } } } if (mask) { oldvals <- getValues(oldraster, r) ind <- which(is.na(rrv)) oldvals[ind] <- NA rrv <- oldvals } else if (update) { oldvals <- getValues(oldraster, r) if (is.numeric(updateValue)) { ind <- which(oldvals == updateValue & !is.na(rrv)) } else if (updateValue == "all") { ind <- which(!is.na(rrv)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { "!NA" ind <- which(!is.na(oldvals) & !is.na(rrv)) } oldvals[ind] <- rrv[ind] rrv <- oldvals } else { rrv[is.na(rrv)] <- background } if (filename == "") { v[,r] <- rrv } else { # print(rrv) rstr <- writeValues(rstr, rrv, r) } pbStep(pb, r) } pbClose(pb) if (filename == "") { rstr <- setValues(rstr, as.vector(v)) } else { rstr <- writeStop(rstr) } return(rstr) } #plot( .polygonsToRaster(p, rstr) ) #...polygoncover <- function(p, x, filename, ...) { # d <- disaggregate(raster(x), 10) # r <- .polygonsToRaster(p, d, filename=filename, field=1, fun='first', background=0, mask=FALSE, update=FALSE, getCover=FALSE, silent=TRUE, ...) # aggregate(r, 10, sum) #} .Old_polygoncover <- function(rstr, filename, polinfo, lxmin, lxmax, pollist, ...) { # percentage cover per grid cell polinfo[, 4] <- 1 bigraster <- raster(rstr) rxmn <- xmin(bigraster) rxmx <- xmax(bigraster) f <- 10 adj <- 0.5 * xres(bigraster)/f nc <- ncol(bigraster) * f rv1 <- rep(0, nc) holes1 <- rep(0, nc) prj <-.getCRS(bigraster) hr <- 0.5 * yres(bigraster) vv <- matrix(ncol=f, nrow=nc) if (filename == "") { v <- matrix(NA, ncol=nrow(bigraster), nrow=ncol(bigraster)) } else { bigraster <- writeStart(bigraster, filename=filename, ...) } pb <- pbCreate(nrow(bigraster), label='rasterize', ...) for (rr in 1:nrow(bigraster)) { y <- yFromRow(bigraster, rr) yn <- y - hr yx <- y + hr rstr <- raster(xmn=rxmn, xmx=rxmx, ymn=yn, ymx=yx, ncols=nc, nrows=f, crs=prj) subpol <- subset(polinfo, !(polinfo[,2] > yx | polinfo[,3] < yn), drop=FALSE) for (r in 1:f) { rv <- rv1 ly <- yFromRow(rstr, r) myline <- rbind(c(lxmin,ly), c(lxmax,ly)) holes <- holes1 if (length(subpol[,1]) > 0) { updateHoles <- FALSE lastpolnr <- subpol[1,6] rvtmp <- rv1 for (i in 1:length(subpol[,1])) { if (i == length(subpol[,1])) { updateHoles <- TRUE } else if (subpol[i+1,6] > lastpolnr) { updateHoles <- TRUE lastpolnr <- subpol[i+1,6] } mypoly <- pollist[[subpol[i,1]]] intersection <- .intersectLinePolygon(myline, mypoly@coords) x <- sort(intersection[,1]) if (length(x) > 0) { #if (length(subpol[,1]) > 3 & i ==2) { # print('4') #} if ( sum(x[-length(x)] == x[-1]) > 0 ) { # single node intersection going out of polygon .... spPnts <- sp::SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr)))) spPol <- sp::SpatialPolygons(list(sp::Polygons(list(mypoly), 1))) over <- sp::over(spPnts, spPol) if ( subpol[i, 5] == 1 ) { holes[!is.na(over)] <- holes[!is.na(over)] - 1 } else { rvtmp[!is.na(over)] <- subpol[i,4] holes[!is.na(over)] <- holes[!is.na(over)] + 1 } } else { for (k in 1:round(nrow(intersection)/2)) { l <- (k * 2) - 1 x1 <- x[l] x2 <- x[l+1] if (x1 > rxmx) { next } if (x2 < rxmn) { next } # adjust to skip first cell if the center is not covered by this polygon x1a <- x1 + adj x2a <- x2 - adj x1a <- min(rxmx, max(rxmn, x1a)) x2a <- min(rxmx, max(rxmn, x2a)) col1 <- colFromX(rstr, x1a) col2 <- colFromX(rstr, x2a) if (col1 > col2) { next } if ( subpol[i, 5] == 1 ) { holes[col1:col2] <- holes[col1:col2] - 1 } else { rvtmp[col1:col2] <- subpol[i,4] holes[col1:col2] <- holes[col1:col2] + 1 } } } if (updateHoles) { holes <- holes < 1 rvtmp[holes] <- 0 holes <- holes1 updateHoles <- FALSE rv <- pmax(rv, rvtmp) } } } } vv[,r] <- rv } av <- colSums( matrix( rowSums(vv), nrow=f) ) if (filename == "") { v[,rr] <- av } else { bigraster <- writeValues(bigraster, av, rr) } pbStep(pb, rr) } pbClose(pb) if (filename == "") { bigraster <- setValues(bigraster, as.vector(v)) } else { bigraster <- writeStop(bigraster) } return(bigraster) } #x = .polygoncover(rstr, "", polinfo, lxmin, lxmax, pollist) .polygonsToRaster2 <- function(p, raster, field=0, filename="", ...) { # This is based on sampling by points. Should be slower except when polygons very detailed and raster has low resolution # but it could be optimized further # currently not used. Perhaps it should be used under certain conditions. # this version does not deal with polygon holes # check if bbox of raster and p overlap filename <- trim(filename) raster <- raster(raster) spbb <- sp::bbox(p) rsbb <- bbox(raster) if (spbb[1,1] > rsbb[1,2] | spbb[2,1] > rsbb[2,2]) { stop('polygon and raster have no overlapping areas') } if (class(p) == 'SpatialPolygons' | field == 0) { putvals <- 1:length(p@polygons) } else { putvals <- as.vector(p@data[,field]) if (class(putvals) == 'character') { stop('selected field is charater type') } } if (filename == "") { v <- vector(length=0) # replace this } else { raster <- writeStart(raster, filename=filename, ...) } rowcol <- cbind(0, 1:ncol(raster)) firstrow <- rowFromY(raster, spbb[2,2]) lastrow <- rowFromY(raster, spbb[2,1]) for (r in 1:nrow(raster)) { if (r < firstrow | r > lastrow) { vals <- rep(NA, times=ncol(raster)) } else { rowcol[,1] <- r sppoints <- xyFromCell(raster, cellFromRowCol(raster, rowcol[,1], rowcol[,2]), TRUE) over <- sp::over(sppoints, p) vals <- putvals[over] } if (filename == "") { v <- c(v, vals) } else { raster <- writeValues(raster, vals) } } if (filename == "") { raster <- setValues(raster, v) } else { raster <- writeStop(raster) } return(raster) } raster/R/getValues.R0000644000176200001440000000265314160021141014031 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("getValues")) { setGeneric("getValues", function(x, row, nrows, ...) standardGeneric("getValues")) } setMethod("getValues", signature(x='RasterLayer', row='missing', nrows='missing'), function(x, format='') { cr <- c(x@ncols, x@nrows) # f <- is.factor(x) # if (f) { # labs <- labels(x) # } if ( inMemory(x) ) { x <- x@data@values } else if ( fromDisk(x) ) { x <- .readRasterLayerValues(x, 1, x@nrows) } else { x <- rep(NA, ncell(x)) } if (format=='matrix') { return ( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) ) #} else if (format =='array') { # return( array( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE), dim=c(cr, 1)) ) # } else if (f) { # x <- factor(x) # set labels? } return( x ) } ) setMethod("getValues", signature(x='RasterBrick', row='missing', nrows='missing'), function(x) { if (! inMemory(x) ) { if ( fromDisk(x) ) { x <- readAll(x) } else { return( matrix(rep(NA, ncell(x) * nlayers(x)), ncol=nlayers(x)) ) } } colnames(x@data@values) <- names(x) x@data@values } ) setMethod("getValues", signature(x='RasterStack', row='missing', nrows='missing'), function(x) { m <- matrix(nrow=ncell(x), ncol=nlayers(x)) colnames(m) <- names(x) for (i in 1:nlayers(x)) { m[,i] <- getValues(x@layers[[i]]) } m } ) raster/R/drawPoly.R0000644000176200001440000000140014160021141013660 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 drawPoly <- function(sp=TRUE, col='red', lwd=2, ...) { xy <- graphics::locator(n=10000, type="l", col=col, lwd=lwd, ...) xy <- cbind(xy$x, xy$y) xy <- rbind(xy, xy[1,]) lines(xy[(length(xy[,1])-1):length(xy[,1]),], col=col, lwd=lwd, ...) if (sp) { return( sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(xy)), 1))) ) } else { return(xy) } } drawLine <- function(sp=TRUE, col='red', lwd=2, ...) { xy <- graphics::locator(n=10000, type="l", col=col, lwd=lwd, ...) xy <- cbind(xy$x, xy$y) if (sp) { return( sp::SpatialLines(list(sp::Lines(list(sp::Line(xy)), "1"))) ) } else { return(xy) } } raster/R/hdrEnvi.R0000644000176200001440000000445414160235746013514 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrENVI <- function(r) { hdrfile <- filename(r) extension(hdrfile) <- ".hdr" thefile <- file(hdrfile, "w") cat("ENVI\n", file = thefile) cat("samples = ", ncol(r), "\n", file = thefile) cat("lines = ", nrow(r), "\n", file = thefile) cat("bands = ", r@file@nbands, "\n", file = thefile) cat("header offset = 0\n", file = thefile) cat("file type = ENVI Standard\n", file = thefile) dsize <- dataSize(r@file@datanotation) if (.shortDataType(r@file@datanotation) == 'INT') { if (dsize == 1) { dtype <- 1 } else if (dsize == 2) { dtype <- 2 } else if (dsize == 4) { dtype <- 3 } else if (dsize == 8) { dtype <- 14 } else { stop('what?') } } else { if (dsize == 4) { dtype <- 4 } else if (dsize == 8) { dtype <- 5 } else { stop('what?') } } cat("data type = ", dtype, "\n", file = thefile) #1=8-bit byte; 2=16-bit signed integer; 3=32-bit signed long integer; 4=32-bit floating point; #5=64-bit double-precision floating point; 6=2x32-bit complex, real-imaginary pair of double precision; #9=2x64-bit double-precision complex, real-imaginary pair of double precision; 12=16-bit unsigned integer; #13=32-bit unsigned long integer; 14=64-bit signed long integer; and 15=64-bit unsigned long integer. cat("data ignore value=", .nodatavalue(r), "\n", file = thefile, sep='') cat("interleave = ", r@file@bandorder, "\n", file = thefile) cat("sensor type = \n", file = thefile) btorder <- as.integer(r@file@byteorder != 'little') # little -> 0, big -> 1 cat("byte order = ", btorder, "\n",file = thefile) if (couldBeLonLat(r)) { cat("map info = {Geographic Lat/Lon, 1, 1,", xmin(r),", ", ymax(r),", ", xres(r),", ", yres(r), "}\n", file = thefile) } else { cat("map info = {projection, 1, 1,", xmin(r),", ", ymax(r),", ", xres(r),", ", yres(r), "}\n", file = thefile) } if (.requireRgdal(FALSE)) { cat("coordinate system string = {", wkt(r), "}\n", file = thefile, sep="") } else { cat("projection info =", proj4string(r), "\n", file = thefile) } cat("z plot range = {", minValue(r),", ", maxValue(r), "}\n", file = thefile) cat("band names = {", paste(names(r),collapse=","), "}", "\n", file = thefile) close(thefile) } raster/R/filler.R0000644000176200001440000000111014160021141013332 0ustar liggesusers .filler <- function(x, y, maxv=12, circular=FALSE) { # should rewrite this using apply (or C) fill <- function(x, y) { r <- matrix(NA, nrow=length(x), ncol=maxv) if (circular) { for (i in 1:nrow(r)) { if (!is.na(y[i])) { if (x[i] < y[i]) { r[i, x[i]:y[i]] <- 1 } else { r[i, c(x[i]:maxv, 1:y[i])] <- 1 } } } r } else { for (i in 1:nrow(r)) { if (!is.na(y[i])) { r[i, x[i]:y[i]] <- 1 } } r } } x <- overlay(x, y, fun=fill) names(x) = paste('v', 1:maxv, sep='') x } raster/R/density.R0000644000176200001440000000322314160021141013543 0ustar liggesusers# Author: Robert J. Hijmans # Date: December 2009 # Version 0.1 # Licence GPL v3 setMethod('density', signature(x='Raster'), function(x, layer, maxpixels=100000, plot=TRUE, main, ...) { if (nlayers(x)==1) { d <- sampleRegular(x, maxpixels, useGDAL=TRUE) x <- density(stats::na.omit(d)) if (plot) { if (missing(main)) { main='' } plot(x, main=main, ...) return(invisible(x)) } else { return(x) } } if (missing(layer)) { y <- 1:nlayers(x) } else if (is.character(layer)) { y <- match(layer, names(x)) } else { y <- layer } y <- unique(as.integer(round(y))) y <- stats::na.omit(y) y <- y[ y >= 1 & y <= nlayers(x) ] nl <- length(y) if (nl == 0) {stop('no existing layers selected')} if (nl > 1) { res <- list() if (nl > 16) { warning('only the first 16 layers are plotted') nl <- 16 y <- y[1:16] } if (missing(main)) { main=names(x) } nc <- ceiling(sqrt(nl)) nr <- ceiling(nl / nc) mfrow <- graphics::par("mfrow") spots <- mfrow[1] * mfrow[2] if (spots < nl) { old.par <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(old.par)) graphics::par(mfrow=c(nr, nc)) } for (i in 1:length(y)) { r <- raster(x, y[i]) m <- main[y[i]] res[[i]] <- density(r, maxpixels=maxpixels, main=m, plot=plot, ...) } } else if (nl==1) { if (missing(main)) { main <- names(x)[y] } r <- raster(x, y) res <- density(r, maxpixels=maxpixels, main=main, plot=plot, ...) } if (plot) return(invisible(res)) else return(res) } ) raster/R/writeStartStop.R0000644000176200001440000000574314160021141015113 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod("writeStart", signature(x="RasterLayer", filename="character"), function(x, filename, options=NULL, format, prj=FALSE, ...) { if (trim(filename) == "") { filename <- rasterTmpFile() } filename <- .fullFilename(filename, expand=TRUE) if (!file.exists(dirname(filename))) { stop("Attempting to write a file to a path that does not exist:\n ", dirname(filename)) } filetype <- .filetype(format=format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype=="ascii") { x <- .startAsciiWriting(x, filename, ...) } else if ( filetype %in% .nativeDrivers() ) { x <- .startRasterWriting(x, filename, format=filetype, ...) } else if ( filetype == "CDF" ) { x <- .startWriteCDF(x, filename, ...) # } else if ( filetype == "big.matrix" ) { # x <- .startBigMatrixWriting(x, filename, ...) } else { x <- .startGDALwriting(x, filename, options=options, format=filetype, ...) } if (prj) { crs <-.getCRS(x) if (crs != "") { writeLines(wkt(x), extension(filename, "prj") ) } } return(x) }) setMethod("writeStart", signature(x="RasterBrick", filename="character"), function(x, filename, options=NULL, format, prj=FALSE, ...) { if (trim(filename) == "") { filename <- rasterTmpFile() } filename <- .fullFilename(filename, expand=TRUE) filetype <- .filetype(format=format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype=="ascii") { stop("ARC-ASCII files cannot contain multiple layers") } native <- filetype %in% c(.nativeDrivers(), "ascii") if (native) { x <- .startRasterWriting(x, filename, format=filetype, ...) } else if ( filetype == "CDF" ) { x <- .startWriteCDF(x, filename, ...) # } else if ( filetype == "big.matrix" ) { # x <- .startBigMatrixWriting(x, filename, ...) } else { x <- .startGDALwriting(x, filename, options=options, format=filetype, ...) } if (prj) { crs <-.getCRS(x) if (!is.na(crs)) { writeLines(wkt(x), extension(filename, "prj") ) } } return(x) }) setMethod("writeStop", signature(x="RasterLayer"), function(x) { driver <- x@file@driver if ( driver %in% .nativeDrivers() ) { return( .stopRasterWriting(x) ) # } else if ( driver == "big.matrix" ) { # return( .stopBigMatrixWriting(x) ) } else if ( driver == "ascii" ) { return( .stopAsciiWriting(x) ) } else if ( driver == "netcdf" ) { return( .stopWriteCDF(x) ) } else { return( .stopGDALwriting(x) ) } } ) setMethod("writeStop", signature(x="RasterBrick"), function(x) { driver <- x@file@driver if (driver %in% .nativeDrivers()) { return( .stopRasterWriting(x) ) } else if ( driver == "netcdf" ) { return( .stopWriteCDF(x) ) # } else if ( driver == "big.matrix" ) { # return( .stopBigMatrixWriting(x) ) } else { return( .stopGDALwriting(x) ) } } ) raster/R/fullFileName.R0000644000176200001440000000122514160021141014427 0ustar liggesusers# raster package # Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 # this function adds the working directory to a filename, if the filename has no path name # and, thus, presumably exists in the working directory. # Storing the full file name is to avoid that a filename becomes invalid if the working directory # changes during an R session .fullFilename <- function(x, expand=FALSE) { x <- trim(x) if (identical(basename(x), x)) { # exclude PG:xxx and perhaps others if (length(grep(":", x)) == 0) { x <- file.path(getwd(), x) } } if (expand) { x <- path.expand(x) } return(x) } raster/R/contour.R0000644000176200001440000000423414160021141013560 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod("contour", signature(x='RasterLayer'), function(x, maxpixels=100000, ...) { x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) contour(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...) } ) rasterToContour <- function(x, maxpixels=100000, ...) { x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE) cL <- grDevices::contourLines(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...) # The below was taken from ContourLines2SLDF(maptools), by Roger Bivand & Edzer Pebesma .contourLines2LineList <- function(cL) { n <- length(cL) res <- vector(mode="list", length=n) for (i in 1:n) { crds <- cbind(cL[[i]][[2]], cL[[i]][[3]]) res[[i]] <- sp::Line(coords=crds) } res } if (length(cL) < 1) stop("no contour lines") cLstack <- tapply(1:length(cL), sapply(cL, function(x) x[[1]]), function(x) x, simplify = FALSE) df <- data.frame(level = names(cLstack)) m <- length(cLstack) res <- vector(mode = "list", length = m) IDs <- paste("C", 1:m, sep = "_") row.names(df) <- IDs for (i in 1:m) { res[[i]] <- sp::Lines(.contourLines2LineList(cL[cLstack[[i]]]), ID = IDs[i]) } SL <- sp::SpatialLines(res, proj4string= .getCRS((x))) sp::SpatialLinesDataFrame(SL, data = df) } filledContour <- function(x, y=1, maxpixels=100000, ...) { if (nlayers(x) > 1) { y <- min(max(1, y), nlayers(x)) x <- raster(x, y) } x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) X <- xFromCol(x, 1:ncol(x)) Y <- yFromRow(x, nrow(x):1) Z <- t( matrix( getValues(x), ncol=x@ncols, byrow=TRUE)[nrow(x):1,] ) lonlat <- couldBeLonLat(x, warnings=FALSE) asp <- list(...)$asp if (is.null(asp)) { if (lonlat) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } graphics::filled.contour(x=X,y=Y,z=Z,asp=asp,...) } else { graphics::filled.contour(x=X,y=Y,z=Z,...) } } raster/R/bands.R0000644000176200001440000000125714160021141013160 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("bandnr")) { setGeneric("bandnr", function(x, ...) standardGeneric("bandnr")) } setMethod('bandnr', signature(x='RasterLayer'), function(x) { return(x@data@band) } ) nbands <- function(x) { cx = class(x) if (inherits(x, "RasterLayer") | inherits(x, "RasterBrick")) { return(x@file@nbands) } else { stop(paste("not implemented for", class(x), "objects")) } } .bandOrder <- function(x) { if (inherits(x, "RasterStack")) { stop(paste("not implemented for RasterStack objects")) } else { return(paste(x@file@bandorder)) } } raster/R/properties.R0000644000176200001440000000234114160021141014260 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .driver <- function(object, warn=TRUE) { if (inherits(object, 'RasterStack')) { d <- sapply(object@layers, function(x) x@file@driver) if (any(d == '' & warn)) { warning('There is no driver associated with one or more layers of this RasterStack') } } else { d <- object@file@driver if (d == '' & warn) { warning('no file/driver associated with this Raster object') } } return(d) } .nodatavalue <- function(object) { if (inherits(object, 'RasterStack')) { return( sapply(object@layers, function(x) x@file@nodatavalue) ) } return(object@file@nodatavalue) } filename <- function(x) { if (inherits(x, 'RasterStack')) { return(x@filename) } return(x@file@name) } # fileext <- toupper(extension(fn)) # if ( fileext == ".GRD" | fileext == ".GRI" ) { # return('raster') # } else { # return('gdal') # } # fcon <- class(try( object@file@con, silent = T ))[1] # if (fcon == 'file') { # return('raster') # } else if (fcon == "GDALReadOnlyDataset") { # return('gdal') # } else if (fcon == "try-error") { # return('NA') # } else { # stop('unknown driver') # } raster/R/readCellsGDAL.R0000644000176200001440000000644714160021141014425 0ustar liggesusers .readCellsGDAL <- function(x, cells, layers) { nl <- nlayers(x) if (nl == 1) { if (inherits(x, 'RasterLayer')) { layers <- bandnr(x) } else { layers <- 1 } } laysel <- length(layers) colrow <- matrix(ncol=2+laysel, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow[,3] <- NA rows <- sort(unique(colrow[,2])) nc <- x@ncols con <- rgdal::GDAL.open(x@file@name, silent=TRUE) if (laysel == 1) { for (i in 1:length(rows)) { offs <- c(rows[i]-1, 0) v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, nc), band = layers) thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { for (i in 1:length(rows)) { thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] if (nrow(thisrow) == 1) { offs <- c(rows[i]-1, thisrow[,1]-1) v <- as.vector( rgdal::getRasterData(con, offset=offs, region.dim=c(1, 1)) ) colrow[colrow[,2]==rows[i], 2+(1:laysel)] <- v[layers] } else { offs <- c(rows[i]-1, 0) v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, nc)) v <- do.call(cbind, lapply(1:nl, function(i) v[,,i])) colrow[colrow[,2]==rows[i], 2+(1:laysel)] <- v[thisrow[,1], layers] } } } rgdal::closeDataset(con) colnames(colrow)[2+(1:laysel)] <- names(x)[layers] colrow[, 2+(1:laysel)] } ...readCellsGDAL <- function(x, cells, layers) { # new version by kendonB via mdsumner # https://github.com/mdsumner/raster-rforge/pull/16/files#diff-5cf48e61a52c5d9bc1d671a341f80d77 # reverted --- too slow nl <- nlayers(x) if (nl == 1) { if (inherits(x, 'RasterLayer')) { layers <- bandnr(x) } else { layers <- 1 } } laysel <- length(layers) colrow <- matrix(ncol=2+laysel, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow <- colrow[order(colrow[,2], colrow[,1]), , drop = FALSE] # This is one if contiguous, something else if not (except for the end of a row) diffrowcol <- diff(colrow[,2]) + diff(colrow[,1]) # Block numbers blocknums <- cumsum(c(TRUE, diffrowcol != 1)) nc <- x@ncols con <- rgdal::GDAL.open(x@file@name, silent=TRUE) if (laysel == 1) { for (blocknum in unique(blocknums)) { block_lgl <- blocknum == blocknums offs <- c(colrow[block_lgl,2][1] - 1, colrow[block_lgl, 1][1] - 1) v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, sum(block_lgl)), band = layers) colrow[block_lgl, 3] <- v } } else { for (blocknum in unique(blocknums)) { block_lgl <- blocknum == blocknums this_block <- colrow[block_lgl, , drop = FALSE] offs <- c(colrow[block_lgl,2][1] - 1, colrow[block_lgl, 1][1] - 1) if (nrow(this_block) == 1) { v <- as.vector( rgdal::getRasterData(con, offset=offs, region.dim=c(1, 1)) ) colrow[block_lgl, 2+(1:laysel)] <- v[layers] } else { v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, sum(block_lgl)), band = layers) v <- do.call(cbind, lapply(1:nl, function(i) v[,,i])) colrow[block_lgl, 2 + (1:laysel)] <- v } } } rgdal::closeDataset(con) colnames(colrow)[2+(1:laysel)] <- names(x)[layers] colrow[, 2+(1:laysel), drop = laysel == 1] } raster/R/rasterizeLines.R0000644000176200001440000002506114160021141015073 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .specialRowFromY <- function(object, y) { rownr <- 1 + (trunc((ymax(object) - y)/yres(object))) rownr[y == ymin(object)] <- nrow(object) rownr[y > ymax(object)] <- -1 rownr[y < ymin(object)] <- nrow(object) + 1 return(rownr) } .specialColFromX <- function(object, x) { colnr <- (trunc((x - xmin(object))/xres(object))) + 1 colnr[x == xmax(object)] <- ncol(object) colnr[x < xmin(object)] <- -1 colnr[x > xmax(object)] <- ncol(object) + 1 return(colnr) } .getCols <- function(rs, rownr, aline, line1, line2) { minx <- xmin(rs) maxx <- xmax(rs) resxy <- matrix(NA, ncol=2, nrow=0) miny <- min(line1[,2], line2[,2]) maxy <- max(line1[,2], line2[,2]) xyxy <- cbind(aline[1:(length(aline[,1])-1), ,drop=FALSE], aline[-1, ,drop=FALSE]) xyxy <- subset(xyxy, !( (xyxy[,2] > maxy & xyxy[,4] > maxy ) | (xyxy[,2] < miny & xyxy[,4] < miny)) ) if (length(xyxy) < 1) { return(resxy) } res <- vector(length=0) for (i in 1:length(xyxy[,1])) { rows <- .specialRowFromY(rs, c(xyxy[i,2], xyxy[i,4]) ) if ((rows[1] > rownr & rows[2] > rownr) | (rows[1] < rownr & rows[2] < rownr)) { next } cols <- .specialColFromX(rs, c(xyxy[i,1], xyxy[i,3])) if ((cols[1] < 1 & cols[2] < 1) | (cols[1] > ncol(rs) & cols[2] > ncol(rs))) { next } rowcol <- cbind(rows, cols)[order(cols),] if (rowcol[1,1] == rowcol[2,1]) { # entire line segment in row add <- rowcol[1,2]:rowcol[2,2] add <- subset(add, add>0 & add<=ncol(rs)) res <- c(res, add) } else { if (rowcol[1,1] == rownr ) { # line segment starts in this row if (rowcol[2,1] < rownr) { xy <- .intersectSegments(line1[1,1], line1[1,2], line1[2,1], line1[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } else { xy <- .intersectSegments(line2[1,1], line2[1,2], line2[2,1], line2[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } if (is.na(xy[1])) { xy <- xyxy[i,3:4] } xy <- t(as.matrix(xy)) outcol = min(.specialColFromX(rs, xy[,1]), ncol(rs)) if (outcol < 1) next cols <- c(max(1, rowcol[1,2]), outcol) col1 <- min(cols) col2 <- max(cols) res <- c(res, col1:col2) } else if (rowcol[2,1] == rownr) { # line segment ends in this row if (rowcol[1,1] < rownr) { xy <- .intersectSegments(line1[1,1], line1[1,2], line1[2,1], line1[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } else { xy <- .intersectSegments(line2[1,1], line2[1,2], line2[2,1], line2[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } if (is.na(xy[1])) { next } xy <- t(as.matrix(xy)) incol <- max(1, .specialColFromX(rs, xy[,1])) if (incol > ncol(rs)) next cols <- c(incol, min(ncol(rs), rowcol[2,2])) col1 <- min(cols) col2 <- max(cols) res <- c(res, col1:col2) } else { # line segment crosses this row xy1 <- .intersectSegments(line1[1,1], line1[1,2], line1[2,1], line1[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) xy2 <- .intersectSegments(line2[1,1], line2[1,2], line2[2,1], line2[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) if (is.na(xy1[1])) { next } if (is.na(xy2[1])) { next } xy <- rbind(xy1, xy2) cols <- .specialColFromX(rs, xy[,1]) col1 <- min(cols) col2 <- max(cols) if (col1 > ncol(rs)) { next } if (col2 == -1) { next } if (col1 == -1) { col1 <- 1 } if (col2 > ncol(rs)) { col2 <- ncol(rs) } res <- c(res, col1:col2) } } } return(res) } .rasterizeLineLength <- function(x, r, background=NA, filename="", ...) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) r <- raster(r) if (canProcessInMemory(r, n=8)) { r[] <- 1:ncell(r) rp <- rasterToPolygons(r) rp <- intersect(x, rp) lengths <- rgeos::gLength(rp, byid=TRUE) / 1000 n <- tapply(lengths, data.frame(rp)[, names(r)], sum) out <- setValues(r, background) out[as.integer(names(n))] <- n if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { out <- raster(r) tr <- blockSize(out) pb <- pbCreate(tr$n, label='rasterize', ...) out <- writeStart(out, filename=filename, ...) nc <- ncol(out) for (i in 1:tr$n) { y <- crop(r, extent(r, tr$row[i], tr$row[i] + tr$nrows[i] - 1, 1, nc)) y[] <- 1:ncell(y) rp <- rasterToPolygons(y, na.rm=FALSE) rp <- intersect(x, rp) lengths <- rgeos::gLength(rp, byid=TRUE) / 1000 n <- tapply(lengths, data.frame(rp)[, names(y)], sum) v <- rep(background, ncell(y)) v[as.integer(names(n))] <- n out <- writeValues(out, v, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } } .linesToRaster <- function(lns, x, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue="all", filename="", ...) { dots <- list(...) if (!is.null(dots$overlap)) { stop('argument "overlap" is no longer available. Use "fun"') } if (!is.null(dots$updateRaster)) { stop('argument "updateRaster" is no longer available. Use "update"') } filename <- trim(filename) if (mask & update) { stop('use either "mask=TRUE" OR "update=TRUE" (or neither)') } if (update) { if (!is.numeric(updateValue)) { if (is.na(updateValue)) { updateValue <- 'NA' } else if (!(updateValue == 'NA' | updateValue == '!NA' | updateValue == 'all')) { stop('updateValue should be either "all", "NA", "!NA"') } } } if (is.character(fun)) { if (!(fun %in% c('first', 'last', 'sum', 'min', 'max', 'count', 'length'))) { stop('invalid character value for fun') } doFun <- FALSE if (fun == 'length') { if (mask) { fun <- 'first' } else if (update) { stop('cannot do update with length yet --- come back later...') } else { return(.rasterizeLineLength(lns, x, background=background, update=FALSE, updateValue="all", filename="", ...) ) } } } else { doFun <- TRUE } rstr <- raster(x) if (!is.na(projection(lns))) { projection(rstr) <-.getCRS(lns) } if (inherits(lns, 'SpatialPolygons')) { lns <- as(lns, "SpatialLines") } if (! inherits(lns, 'SpatialLines')) { stop('lns should be, or inherit from, a SpatialLines* object') } # check if bbox of raster and lns overlap spbb <- sp::bbox(lns) rsbb <- bbox(rstr) if (spbb[1,1] > rsbb[1,2] | spbb[2,1] > rsbb[2,2]) { stop('lines and raster have no overlapping areas') } nline <- length(lns@lines) info <- matrix(NA, nrow=nline, ncol=4) info[,4] <- 1:nrow(info) info[,1] <- sapply(lns@lines, function(i) length(i@Lines)) for (i in 1:nline) { r <- range(sapply( lns@lines[[i]]@Lines, function(j) range(j@coords[,2]))) info[i,2] <- r[1] info[i,3] <- r[2] } lxmin <- min(spbb[1,1], rsbb[1,1]) - 0.5 * xres(rstr) lxmax <- max(spbb[1,2], rsbb[1,2]) + 0.5 * xres(rstr) pvals <- .getPutVals(lns, field, nline, mask) putvals <- pvals[,1] if (ncol(pvals) > 1) { rstr@data@isfactor <- TRUE rstr@data@attributes <- list(pvals) } if (filename == "") { v <- matrix(NA, ncol=nrow(rstr), nrow=ncol(rstr)) } else { rstr <- writeStart(rstr, filename=filename, ...) } rv1 <- rep(NA, ncol(rstr)) lst1 <- vector(length=length(rv1), mode='list') yrs <- yres(rstr) pb <- pbCreate(nrow(rstr), label='rasterize', ...) for (r in 1:nrow(rstr)) { ly <- yFromRow(rstr, r) uly <- ly + 0.51 * yrs lly <- ly - 0.51 * yrs info1 <- subset(info, !(info[,2] > uly | info[,3] < lly ) ) # subpol <- subset(polinfo, !(polinfo[,2] > ly | polinfo[,3] < ly), drop=FALSE) if (doFun) { rv <- lst1 } else { rv <- rv1 } if (nrow(info1) > 0) { line1 <- rbind(c(lxmin, ly + 0.5*yrs), c(lxmax,ly + 0.5*yrs)) line2 <- rbind(c(lxmin, ly - 0.5*yrs), c(lxmax,ly - 0.5*yrs)) for (k in 1:nrow(info1)) { i <- info1[k,4] for (j in 1:info1[k,1]) { if ( max ( lns@lines[[i]]@Lines[[j]]@coords[,2] ) < lly | min( lns@lines[[i]]@Lines[[j]]@coords[,2] ) > uly ) { # line part entirely outside of row. do nothing } else { aline <- lns@lines[[i]]@Lines[[j]]@coords #cat(i, "\n"); utils::flush.console(); colnrs <- .getCols(rstr, r, aline, line1, line2) if ( length(colnrs) > 0 ) { rvtmp <- rv1 rvtmp[colnrs] <- putvals[i] if (doFun) { ind <- which(!is.na(rvtmp)) for (ii in ind) { rv[[ii]] <- c(rv[[ii]], rvtmp[ii]) } } else if (mask) { rv[!is.na(rvtmp)] <- rvtmp[!is.na(rvtmp)] } else if (fun=='last') { rv[!is.na(rvtmp)] <- rvtmp[!is.na(rvtmp)] } else if (fun=='first') { rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='sum') { rv[!is.na(rv) & !is.na(rvtmp)] <- rv[!is.na(rv) & !is.na(rvtmp)] + rvtmp[!is.na(rv) & !is.na(rvtmp)] rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='min') { rv[!is.na(rv) & !is.na(rvtmp)] <- pmin(rv[!is.na(rv) & !is.na(rvtmp)], rvtmp[!is.na(rv) & !is.na(rvtmp)]) rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='max') { rv[!is.na(rv) & !is.na(rvtmp)] <- pmax(rv[!is.na(rv) & !is.na(rvtmp)], rvtmp[!is.na(rv) & !is.na(rvtmp)]) rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='count') { rvtmp[!is.na(rvtmp)] <- 1 rv[!is.na(rv) & !is.na(rvtmp)] <- rv[!is.na(rv) & !is.na(rvtmp)] + rvtmp[!is.na(rv) & !is.na(rvtmp)] rv[is.na(rv)] <- rvtmp[is.na(rv)] } } } } } } if (doFun) { for (i in 1:length(rv)) { if (is.null(rv[[i]])) { rv[[i]] <- NA } } rv <- sapply(rv, fun) } if (mask) { oldvals <- getValues(x, r) ind <- which(is.na(rv)) oldvals[ind] <- NA rv <- oldvals } else if (update) { oldvals <- getValues(x, r) if (is.numeric(updateValue)) { ind <- which(oldvals == updateValue & !is.na(rv)) } else if (updateValue == "all") { ind <- which(!is.na(rv)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { ind <- which(!is.na(oldvals) & !is.na(rv)) } oldvals[ind] <- rv[ind] rv <- oldvals } else { rv[is.na(rv)] <- background } if (filename == "") { v[,r] <- rv } else { rstr <- writeValues(rstr, rv, r) } pbStep(pb, r) } pbClose(pb) if (filename == "") { rstr <- setValues(rstr, as.vector(v)) } else { rstr <- writeStop(rstr) } return(rstr) } raster/R/plotCT.R0000644000176200001440000000417314160021141013276 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2010 # Version 0.9 # Licence GPL v3 .plotCT <- function(x, maxpixels=500000, ext=NULL, interpolate=FALSE, axes, main, xlab='', ylab='', asp, add=FALSE, addfun=NULL, zlim=NULL, zlimcol=NULL, ...) { # plotting with a color table if (missing(main)) { main <- '' } #sethook <- FALSE if (!add) { graphics::plot.new() if (missing(axes)) { axes <- FALSE } if (!axes) { # if (main != "") { } else { old.par <- graphics::par(no.readonly = TRUE) #graphics::par(plt=c(0,1,0,1)) graphics::par(mar=c(0,0,0,0), xaxs='i',yaxs='i') #sethook <- TRUE } if (missing(asp)) { if (couldBeLonLat(x)) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } } } coltab <- colortable(x) x <- sampleRegular(x, maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) z <- getValues(x) if (!is.null(zlim)) { # not that relevant here, but for consistency.... if (is.null(zlimcol)) { z[ zzlim[2] ] <- zlim[2] } else { #if (is.na(zlimcol)) { z[zzlim[2]] <- NA } } if (NCOL(coltab) == 2) { # not implemented z <- as.numeric(cut(z, coltab[,1])) coltab <- as.vector(coltab[,2]) } z <- z + 1 z[is.na(z)] <- 1 if (! is.null(coltab) ) { z <- matrix(coltab[z], nrow=nrow(x), ncol=ncol(x), byrow=T) z <- as.raster(z) } else { z <- matrix(z, nrow=nrow(x), ncol=ncol(x), byrow=T) z <- as.raster(z, max=max(z)) #, na.rm=TRUE)) } requireNamespace("grDevices") bb <- as.vector(extent(x)) if (! add) { plot(c(bb[1], bb[2]), c(bb[3], bb[4]), type = "n", xlab=xlab, ylab=ylab, asp=asp, axes=axes, main=main, ...) } graphics::rasterImage(z, bb[1], bb[3], bb[2], bb[4], interpolate=interpolate, ...) if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } #if (sethook) { # setHook("plot.new", function(...) { # graphics::par(old.par) # setHook("plot.new", function(...) setHook("plot.new", NULL, "replace")) # }, action="replace") #} } raster/R/zonal.R0000644000176200001440000002153514160021141013215 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 setMethod('zonal', signature(x='RasterLayer', z='RasterLayer'), function(x, z, fun='mean', digits=0, na.rm=TRUE, ...) { # backward compatibility if (!is.null(list(...)$stat)) { stop('argument "stat" was replaced by "fun"') } compareRaster(c(x, z)) stopifnot(hasValues(z)) stopifnot(hasValues(x)) layernames <- names(x) if (canProcessInMemory(x, 3)) { inmem <- TRUE } else { inmem <- FALSE } if (inmem) { pb <- pbCreate(2, label='zonal', ...) if (isTRUE(try(fun == 'count', silent=TRUE))) { func <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } } else { func <- match.fun(fun) } x <- getValues(x) z <- round(getValues(z), digits=digits) pb <- pbStep(pb, 1) alltab <- tapply(x, z, FUN=func, na.rm=na.rm) if (is.array(alltab)) { # multiple numbers id <- as.numeric(dimnames(alltab)[[1]]) alltab <- matrix(unlist(alltab, use.names = FALSE), nrow=dim(alltab), byrow=TRUE) alltab <- cbind(id, alltab) } else { alltab <- cbind(as.numeric(names(alltab)), alltab) } pb <- pbStep(pb, 2) colnames(alltab)[1] <- 'zone' d <- dim(alltab)[2] if (d==2) { if (is.character(fun)) { colnames(alltab)[2] <- fun[1] } else { colnames(alltab)[2] <- 'value' } } else { colnames(alltab)[2:d] <- paste0('value_', 1:(d-1)) } } else { if (class(fun)[1] != 'character') { stop("RasterLayers cannot be processed in memory.\n You can use fun='sum', 'mean', 'sd', 'min', 'max', or 'count' but not a function") } if (! fun %in% c('sum', 'mean', 'sd', 'min', 'max', 'count')) { stop("fun can be 'sum', 'mean', 'sd', 'min', 'max', or 'count'") } sdtab <- FALSE counts <- FALSE if (fun == 'count') { func1 <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } func2 <- sum } else { func1 <- func2 <- match.fun(fun) } if ( fun == 'mean' | fun == 'sd') { func1 <- func2 <- sum counts <- TRUE if (fun == 'sd') { sdtab <- TRUE } } alltab <- array(dim=0) sqtab <- cnttab <- alltab tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='zonal', ...) #nc <- nlayers(x) #nc1 <- nc + 1 #nc2 <- 2:nc1 #nc2 <- 2 x <- readStart(x, ...) z <- readStart(z, ...) for (i in 1:tr$n) { d <- cbind(getValues(x, row=tr$row[i], nrows=tr$nrows[i])) Z <- round(getValues(z, row=tr$row[i], nrows=tr$nrows[i]), digits=digits) #cat(i, '\n') #utils::flush.console() a <- tapply(d, Z, FUN=func1, na.rm=na.rm) a <- cbind(as.numeric(names(a)), a) alltab <- rbind(alltab, a) if (counts) { if (na.rm) { a <- tapply(d, Z, FUN=function(x)length(stats::na.omit(x))) a <- cbind(as.numeric(names(a)), a) cnttab <- rbind(cnttab, a) if (sdtab) { a <- tapply( d^2, Z, FUN=function(x)sum(stats::na.omit(x))) a <- cbind(as.numeric(names(a)), a) sqtab <- rbind(sqtab, a) } } else { a <- tapply(d, Z, FUN=length) a <- cbind(as.numeric(names(a)), a) cnttab <- rbind(cnttab, a) if (sdtab) { a <- tapply(d^2, Z, FUN=sum) a <- cbind(as.numeric(names(a)), a) sqtab <- rbind(sqtab, a) } } } if (length(alltab) > 10000) { alltab <- tapply(alltab[,2], alltab[,1], FUN=func2, na.rm=na.rm) alltab <- cbind(as.numeric(names(alltab)), alltab) if (counts) { cnttab <- tapply(cnttab[,2], cnttab[,1], FUN=sum, na.rm=na.rm) cnttab <- cbind(as.numeric(names(cnttab)), cnttab) if (sdtab) { sqtab <- tapply(sqtab[,2], sqtab[,1], FUN=sum, na.rm=na.rm) sqtab <- cbind(as.numeric(names(sqtab)), sqtab) } } } pbStep(pb, i) } x <- readStop(x) z <- readStop(z) alltab <- tapply(alltab[,2], alltab[,1], FUN=func2, na.rm=na.rm) alltab <- cbind(as.numeric(names(alltab)), alltab) if (counts) { cnttab <- tapply(cnttab[,2], cnttab[,1], FUN=sum) cnttab <- cbind(as.numeric(names(cnttab)), cnttab) alltab[,2] <- alltab[,2] / cnttab[,2] if (sdtab) { sqtab <- tapply(sqtab[,2], sqtab[,1], FUN=sum, na.rm=na.rm) sqtab <- cbind(as.numeric(names(sqtab)), sqtab) alltab[,2] <- sqrt(( (sqtab[,2] / cnttab[,2]) - (alltab[,2])^2 ) * (cnttab[,2]/(cnttab[,2]-1))) } } colnames(alltab)[1] <- 'zone' if (is.character(fun)) { colnames(alltab)[2] <- fun } else { colnames(alltab)[2] <- 'value' } } #alltab <- as.matrix(alltab) pbClose(pb) return(alltab) } ) #zonal(r, z, 'sd') setMethod('zonal', signature(x='RasterStackBrick', z='RasterLayer'), function(x, z, fun='mean', digits=0, na.rm=TRUE, ...) { # backward compatibility if (!is.null(list(...)$stat)) { stop('argument "stat" was replaced by "fun"') } compareRaster(c(x, z)) stopifnot(hasValues(z)) stopifnot(hasValues(x)) layernames <- names(x) if (canProcessInMemory(x, 3)) { inmem <- TRUE } else { inmem <- FALSE } if (inmem) { pb <- pbCreate(2, label='zonal', ...) if (isTRUE(try(fun == 'count', silent=TRUE))) { func <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } } else { func <- match.fun(fun) } x <- getValues(x) x <- cbind(x, round(getValues(z), digits=digits)) pb <- pbStep(pb, 1) alltab <- aggregate(x[,1:(ncol(x)-1)], by=list(x[,ncol(x)]), FUN=func, na.rm=na.rm) fun <- 'value' pb <- pbStep(pb, 2) } else { if (class(fun)[1] != 'character') { stop("RasterLayers cannot be processed in memory.\n You can use fun='sum', 'mean', 'sd', 'min', 'max', or 'count' but not a function") } if (! fun %in% c('sum', 'mean', 'sd', 'min', 'max', 'count')) { stop("fun can be 'sum', 'mean', 'sd', 'min', 'max', or 'count'") } sdtab <- FALSE counts <- FALSE if (fun == 'count') { func1 <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } func2 <- sum } else { func1 <- func2 <- match.fun(fun) } if ( fun == 'mean' | fun == 'sd') { func1 <- func2 <- sum counts <- TRUE if (fun == 'sd') { sdtab <- TRUE } } alltab <- array(dim=0) sqtab <- cnttab <- alltab tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='zonal', ...) nc <- nlayers(x) nc1 <- nc + 1 nc2 <- 2:nc1 # for a RasterStack it would be more efficient to loop over the layers x <- readStart(x, ...) z <- readStart(z, ...) for (i in 1:tr$n) { d <- cbind(getValues(x, row=tr$row[i], nrows=tr$nrows[i]), round(getValues(z, row=tr$row[i], nrows=tr$nrows[i]), digits=digits)) #cat(i, '\n') #utils::flush.console() alltab <- rbind(alltab, aggregate(d[,1:nc], by=list(d[,nc1]), FUN=func1, na.rm=na.rm)) if (counts) { if (na.rm) { cnttab <- rbind(cnttab, aggregate(d[,1:nc], by=list(d[,nc1]), FUN=function(x)length(stats::na.omit(x)))) if (sdtab) { sqtab <- rbind(sqtab, aggregate( (d[,1:nc])^2, by=list(d[,nc1]), FUN=function(x)sum(stats::na.omit(x)))) } } else { cnttab <- rbind(cnttab, aggregate(d[,1:nc], by=list(d[,nc1]), FUN=length)) if (sdtab) { sqtab <- rbind(sqtab, aggregate( (d[,1:nc])^2, by=list(d[,nc]), FUN=sum)) } } } if (length(alltab) > 10000) { alltab <- aggregate(alltab[,nc2], by=list(alltab[,1]), FUN=func2, na.rm=na.rm) if (counts) { cnttab <- aggregate(cnttab[,nc2], by=list(cnttab[,1]), FUN=sum, na.rm=na.rm) if (sdtab) { sqtab <- aggregate(sqtab[,nc2], by=list(sqtab[,1]), FUN=sum, na.rm=na.rm) } } } pbStep(pb, i) } x <- readStop(x) z <- readStop(z) alltab <- aggregate(alltab[,nc2], by=list(alltab[,1]), FUN=func2, na.rm=na.rm) if (counts) { cnttab <- aggregate(cnttab[,nc2], by=list(cnttab[,1]), FUN=sum) alltab[,nc2] <- alltab[,nc2] / cnttab[,nc2] if (sdtab) { sqtab <- aggregate(sqtab[,nc2], by=list(sqtab[,1]), FUN=sum, na.rm=na.rm) alltab[,nc2] <- sqrt(( (sqtab[,nc2] / cnttab[,nc2]) - (alltab[nc2])^2 ) * (cnttab[,nc2]/(cnttab[,nc2]-1))) } } } alltab <- as.matrix(alltab) colnames(alltab)[1] <- 'zone' if (ncol(alltab) > 2) { colnames(alltab)[2:ncol(alltab)] <- layernames } else { colnames(alltab)[2] <- fun[1] } pbClose(pb) return(alltab) } ) #zonal(r, z, 'sd') raster/R/bbox.R0000644000176200001440000000100514160021141013012 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("bbox", signature(obj="Extent"), function(obj) { bb <- matrix(ncol=2, nrow=2) colnames(bb) <- c("min","max") rownames(bb) <- c("s1","s2") bb[1,1] <- obj@xmin bb[1,2] <- obj@xmax bb[2,1] <- obj@ymin bb[2,2] <- obj@ymax return(bb) } ) setMethod("bbox", signature(obj="Raster"), function(obj) { e <- extent(obj) return( bbox(e) ) } ) raster/R/cellFromPolygon.R0000644000176200001440000000240014160021141015173 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2011 # Version 1.0 # Licence GPL v3 cellFromPolygon <- function(object, p, weights=FALSE) { spbb <- sp::bbox(p) rsbb <- bbox(object) addres <- max(res(object)) npol <- length(p@polygons) res <- list() res[[npol+1]] = NA if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { return(res[1:npol]) } rr <- raster(object) for (i in 1:npol) { pp <- p[i,] spbb <- sp::bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE, datatype="FLT4S") rc[rc==0] <- NA xy <- rasterToPoints(rc) weight <- xy[,3] / 100 xy <- xy[,-3] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch holes or very small polygons cell <- cellFromXY(object, xy) if (weights) { res[[i]] <- cbind(cell, weight) } else { res[[i]] <- cell } } } } return( res[1:npol] ) } raster/R/inifile.R0000644000176200001440000000431214160021141013503 0ustar liggesusers# Authors: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .strSplitOnFirstToken <- function(s, token="=") { pos <- which(strsplit(s, '')[[1]]==token)[1] if (is.na(pos)) { return(c(trim(s), NA)) } else { first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } } .strSplitOnLastToken <- function(s, token="=") { # not used here pos <- unlist(strsplit(s, ''), use.names = FALSE) pos <- max(which(pos==token)) if (!is.finite(pos)) { return(c(s, NA)) } else { first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } } readIniFile <- function(filename, token='=', commenttoken=';', aslist=FALSE, case) { stopifnot(file.exists(filename)) Lines <- trim(readLines(filename, warn = FALSE)) ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=commenttoken) } ) Lines <- matrix(unlist(ini), ncol=2, byrow=TRUE)[,1] ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=token) }) ini <- matrix(unlist(ini), ncol=2, byrow=TRUE) ini <- ini[ ini[,1] != "", , drop=FALSE] ns <- length(which(is.na(ini[,2]))) if (ns > 0) { sections <- c(which(is.na(ini[,2])), length(ini[,2])) # here I should check whether the section text is enclosed in [ ]. If not, it is junk text that should be removed, rather than used as a section ini <- cbind("", ini) for (i in 1:(length(sections)-1)) { ini[sections[i]:(sections[i+1]), 1] <- ini[sections[i],2] } ini[,1] <- gsub("\\[", "", ini[,1]) ini[,1] <- gsub("\\]", "", ini[,1]) sections <- sections[1:(length(sections)-1)] ini <- ini[-sections,] } else { ini <- cbind("", ini) } if (!missing(case)) { ini <- case(ini) } colnames(ini) <- c("section", "name", "value") if (aslist) { iniToList <- function(ini) { un <- unique(ini[,1]) LST <- list() for (i in 1:length(un)) { sel <- ini[ini[,1] == un[i], 2:3, drop=FALSE] lst <- as.list(sel[,2]) names(lst) <- sel[,1] LST[[i]] <- lst } names(LST) <- un return(LST) } ini <- iniToList(ini) } return(ini) } raster/R/sampleStratified.R0000644000176200001440000000524514160021141015372 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2012 # Version 2.0 # Licence GPL v3 setMethod('sampleStratified', signature(x='RasterLayer'), function(x, size, exp=10, na.rm=TRUE, xy=FALSE, ext=NULL, sp=FALSE, ...) { stopifnot(hasValues(x)) size <- round(size) stopifnot(size <= ncell(x)) stopifnot(size > 0) if (!is.null(ext)) { oldx <- raster(x) x <- crop(x, ext) } if (canProcessInMemory(x)) { v <- cbind(1:ncell(x), round(getValues(x))) if (na.rm) { v <- v[!is.na(v[,2]), ] } f <- table(v[,2], useNA='ifany') f <- cbind(as.integer(names(f)), f) ys <- list() for (i in 1:nrow(f)) { if (is.na(f[i,1])) { y <- v[is.na(v[, 2]), ,drop=FALSE] } else { y <- v[v[, 2] == f[i,1], ,drop=FALSE] } if (nrow(y) < size) { warning("only ", nrow(y), " cells found for stratum ", f[i,1]) } else { if (nrow(y) > size) { y <- y[sample(nrow(y), size), ,drop=FALSE] } } # bug fix by Antoine Stevens ys[[i]] <- y } } else { # unique would suffice, unless to check whether a sample _can_ be obtained for a stratum f <- freq(x) if (na.rm) { na <- which(is.na(f[,1])) if (length(na) > 0) { f <- f[-na, ,drop=FALSE] } } exp <- max(1, exp) ss <- exp * size * nrow(f) if (ss < 1000) { ss <- 1000 } if (ss > ncell(x)) { ss <- ncell(x) } sr <- sampleRandom(x, ss, na.rm=na.rm, ext=NULL, cells=TRUE, rowcol=FALSE, sp=FALSE) ys <- list() for (i in seq_len(nrow(f))) { y <- sr[sr[, 2] == f[i,1], ,drop=FALSE] if (nrow(y) == 0) { warning("no samples found for value: ", i, ". Perhaps increase the value of 'ext'") } else { if (nrow(y) > size) { y <- y[sample(nrow(y), size), ,drop=FALSE] } ys[[i]] <- y } } } res <- do.call(rbind, ys) colnames(res) <- c('cell', names(x)) ta <- tapply(res[,1], res[,2], length) tanm <- names(ta)[which(ta < size)] if (length(tanm)== 1) { warning('fewer samples than requested found for stratum: ', tanm) } else if (length(tanm) > 1) { warning('fewer samples than requested found for strata: ', paste(tanm, collapse=', ')) } if (!is.null(ext)) { pts <- xyFromCell(x, res[,1]) res[,1] <- cellFromXY(oldx, pts) if (xy) { res <- cbind(res[,1,drop=FALSE], pts, res[,2,drop=FALSE]) } } else if (xy) { pts <- xyFromCell(x, res[,1]) res <- cbind(res[,1,drop=FALSE], pts, res[,2,drop=FALSE]) } if (sp) { if (!xy & is.null(ext)) { pts <- xyFromCell(x, res[,1]) } res <- sp::SpatialPointsDataFrame(pts, data.frame(res), proj4string=.getCRS((x))) } return(res) } ) raster/R/kml_multiple.R0000644000176200001440000000743714160021141014575 0ustar liggesusers# Derived from functions GE_SpatialGrid and kmlOverlay # in the maptools package by Duncan Golicher, David Forrest and Roger Bivand # Adaptation for the raster package by Robert J. Hijmans # Date : October 2011 # Version 0.9 # Licence GPL v3 .zipKML <- function(kml, image, zip, overwrite=FALSE) { if (zip == "") { zip <- Sys.getenv('R_ZIPCMD', 'zip') } if (zip != "") { wd <- getwd() on.exit( setwd(wd) ) setwd(dirname(kml)) kml <- basename(kml) kmz <- extension(kml, '.kmz') if (file.exists(kmz)) { if (overwrite) { file.remove(kmz) } else { stop('kml file created, but kmz file exists, use "overwrite=TRUE" to overwrite it') } } image <- basename(image) if (zip=='7z') { kmzzip <- extension(kmz, '.zip') cmd <- paste(zip, 'a', kmzzip, kml, image, collapse=" ") file.rename(kmzzip, kmz) } else { cmd <- paste(c(zip, kmz, kml, image), collapse=" ") } sss <- try( system(cmd, intern=TRUE), silent=TRUE ) if (file.exists(kmz)) { files <- c(kml, image) files <- files[file.exists(files)] x <- file.remove(files) return(invisible(kmz)) } else { return(invisible(kml)) } } else { return(invisible(kml)) } } setMethod('KML', signature(x='RasterStackBrick'), function (x, filename, time=NULL, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) { if (! couldBeLonLat(x)) { stop("CRS of x must be longitude/latitude") } stopifnot(hasValues(x)) if (missing(filename)) { filename <- extension(basename(rasterTmpFile('G_')), '.kml') } nl <- nlayers(x) if (is.null(time)) { dotime <- FALSE atime <- time } else { dotime <- TRUE if (length(time) == nl) { when <- TRUE } else if (length(time) == nl+1) { when <- FALSE } else { stop('length(time) should equall nlayers(x) for "when", or (nlayers(x)+1) for "begin-end"') } } x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE) kmlfile <- filename extension(kmlfile) <- '.kml' if (file.exists(kmlfile)) { if (overwrite) { file.remove(kmlfile) } else { stop('kml file exists, use "overwrite=TRUE" to overwrite it') } } name <- names(x) kml <- c('', '') kml <- c(kml, c("", paste("", extension(basename(filename), ''), "", sep=''))) e <- extent(x) latlonbox <- c("\t", paste("\t\t", e@ymax, "", e@ymin, "", e@xmax, "", e@xmin, "", sep = ""), "\t", "") imagefile <- paste(extension(filename, ''), "_", 1:nl, ".png", sep="") for (i in 1:nl) { grDevices::png(filename = imagefile[i], width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg="transparent") if (!is.na(colNA)) { graphics::par(mar=c(0,0,0,0), bg=colNA) } else { graphics::par(mar=c(0,0,0,0)) } image(x[[i]], col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...) grDevices::dev.off() a <- c("", paste("\t", name[i], "", sep='')) if (dotime) { if (when) { atime <- c("\t", paste("\t\t", time[i], "", sep=''), "\t") } else { atime <- c("\t", paste("\t\t", time[i], "", sep=''), paste("\t\t", time[i+1], "", sep=''), "\t") } } kml <- c(kml, a, atime, paste("\t", basename(imagefile[i]), "", sep=''), latlonbox) } kml <- c(kml, "", "") cat(paste(kml, sep="", collapse="\n"), file=kmlfile, sep = "") .zipKML(kmlfile, imagefile, zip, overwrite=overwrite) } ) raster/R/scalebar.R0000644000176200001440000001026514160021141013644 0ustar liggesusers# Author: Robert J. Hijmans # scalebar partly based on Josh Gray' code in http://spatiallyexplicit.wordpress.com/2011/06/07/crop-circles/ # Date : July 2011 # Version 1.0 # Licence GPL v3 .destPoint <- function (p, d, b=90, r=6378137) { toRad <- pi/180 lon1 <- p[, 1] * toRad lat1 <- p[, 2] * toRad b <- b * toRad lat2 <- asin(sin(lat1) * cos(d/r) + cos(lat1) * sin(d/r) * cos(b)) lon2 <- lon1 + atan2(sin(b) * sin(d/r) * cos(lat1), cos(d/r) - sin(lat1) * sin(lat2)) lon2 <- (lon2 + pi)%%(2 * pi) - pi cbind(lon2, lat2)/toRad } .oldscalebar <- function(object, xy=click(), length=100000, label='100 km', offset=0.3, lwd=4, ... ) { object <- raster(object) if (couldBeLonLat(object)) { midy <- object@extent@ymax - 0.5 * (object@extent@ymax - object@extent@ymin) p <- cbind(0, midy) d <- .destPoint(p, length) length <- d[1,1] } xy2 <- xy xy2[1,1] <- xy2[1,1] + length lines(rbind(xy, xy2), lwd=lwd, ...) xy[1,1] <- xy[1,1] + 0.5 * length xy[1,2] <- xy[1,2] + offset * length text(xy[1,1], xy[1,2], label, ...) } .arrow <- function(d, xy=click(), head=0.1, ...) { graphics::arrows(xy[1], xy[2], xy[1], xy[2]+d, length=head, ...) lines(rbind(xy, rbind(cbind(xy[1], xy[2]-d))), ...) text(xy[1,1], xy[1,2]-(0.25*d), 'N') } scalebar <- function(d, xy=NULL, type='line', divs=2, below='', lonlat=NULL, label, adj=c(0.5, -0.5), lwd=2, ...){ stopifnot(type %in% c('line', 'bar')) pr <- graphics::par() if (is.null(lonlat)) { if ( pr$usr[1] > -181 & pr$usr[2] < 181 & pr$yaxp[1] > -200 & pr$yaxp[2] < 200 ) { lonlat <- TRUE } else { lonlat <- FALSE } } if (lonlat) { lat <- mean(pr$yaxp[1:2]) if (missing(d)) { dx <- (pr$usr[2] - pr$usr[1]) / 10 d <- pointDistance(cbind(0, lat), cbind(dx, lat), TRUE) d <- signif(d / 1000, 2) label <- NULL } p <- cbind(0, lat) dd <- .destPoint(p, d * 1000) dd <- dd[1,1] } else { if (missing(d)) { d <- round(10*(pr$usr[2] - pr$usr[1])/10) / 10 label <- NULL } dd <- d } if(is.null(xy)) { padding=c(5,5) / 100 #defaults to a lower left hand position parrange <- c(pr$usr[2] - pr$usr[1], pr$usr[4] - pr$usr[3]) xy <- c(pr$usr[1]+(padding[1]*parrange[1]), pr$usr[3]+(padding[2]*parrange[2])) } if (type == 'line') { lines(matrix(c(xy[1], xy[2], xy[1]+dd, xy[2]), byrow=T, nrow=2), lwd=lwd, ...) if (missing(label)) { label <- paste(d) } if (is.null(label)) { label <- paste(d) } if (missing(adj)) { adj <- c(0.5, -0.2-lwd/20 ) } text(xy[1]+(0.5*dd), xy[2],labels=label, adj=adj,...) } else if (type == 'bar') { stopifnot(divs > 0) if (missing(adj)) { adj <- c(0.5, -1 ) } lwd <- dd / 25 if (divs==2) { half <- xy[1] + dd / 2 graphics::polygon(c(xy[1], xy[1], half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='white') graphics::polygon(c(half, half, xy[1]+dd, xy[1]+dd ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='black') if (missing(label)) { label <- c('0', '', d) } if (is.null(label)) { label <- c('0', '', d) } text(xy[1], xy[2],labels=label[1], adj=adj,...) text(xy[1]+0.5*dd, xy[2],labels=label[2], adj=adj,...) text(xy[1]+dd, xy[2],labels=label[3], adj=adj,...) } else { q1 <- xy[1] + dd / 4 half <- xy[1] + dd / 2 q3 <- xy[1] + 3 * dd / 4 end <- xy[1] + dd graphics::polygon(c(xy[1], xy[1], q1, q1), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='white') graphics::polygon(c(q1, q1, half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='black') graphics::polygon(c(half, half, q3, q3 ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='white') graphics::polygon(c(q3, q3, end, end), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='black') if (missing(label)) { label <- c('0', round(0.5*d), d) } if (is.null(label)) { label <- c('0', round(0.5*d), d) } text(xy[1], xy[2], labels=label[1], adj=adj,...) text(half, xy[2], labels=label[2], adj=adj,...) text(end, xy[2],labels=label[3], adj=adj,...) } if (below != "") { adj[2] <- -adj[2] text(xy[1]+(0.5*dd), xy[2], labels=below, adj=adj,...) } } } raster/R/fourCellsFromXY.R0000644000176200001440000000105014160021141015123 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009, August 2012 # Licence GPL v3 # updated November 2011 # version 1.0 fourCellsFromXY <- function(object, xy, duplicates=TRUE) { # if duplicates is TRUE, the same cell number can be returned # twice (if point in the middle of division between two cells) or # four times (if point in center of cell) r <- raster(object) # use small object stopifnot(is.matrix(xy)) return( .doFourCellsFromXY(r@ncols, r@nrows, xmin(r), xmax(r), ymin(r), ymax(r), xy, duplicates, .isGlobalLonLat(r))) } raster/R/sparse.R0000644000176200001440000001314014160021141013360 0ustar liggesusers#to be removed #setAs('RasterLayerSparse', 'RasterLayer', function(from){ raster(from) } ) setClass ("RasterLayerSparse", contains = "RasterLayer", representation ( index = "vector" ), prototype ( index = vector(mode="numeric") ) ) setMethod('raster', signature(x='RasterLayerSparse'), function(x) { r <- raster(x@extent, nrows=x@nrows, ncols=x@ncols, crs=.getCRS(x)) if (length(stats::na.omit(x@data@values)) > 0) { v <- rep(NA, ncell(r)) v[x@index] <- x@data@values setValues(r, v) } else { r } } ) setClass (".RasterBrickSparse", contains = "RasterBrick", representation ( index = "vector" ), prototype ( index = vector(mode="numeric") ) ) setAs('RasterLayer', 'RasterLayerSparse', function(from){ x <- methods::new('RasterLayerSparse') v <- stats::na.omit(cbind(1:ncell(from), getValues(from))) setValues(x, v[,2], v[,1]) } ) setMethod("Arith", signature(e1='RasterLayerSparse', e2='numeric'), function(e1, e2){ if (!hasValues(e1)) { stop('RasterLayerSparse has no values') } stopifnot(length(e2) == 1) setValues(e1, methods::callGeneric(as.numeric(e1@data@values), e2)) } ) setMethod("Arith", signature(e1='numeric', e2='RasterLayerSparse'), function(e1, e2){ if (!hasValues(e2)) { stop('RasterLayerSparse has no values') } stopifnot(length(e1) == 1) setValues(e2, methods::callGeneric(as.numeric(e2@data@values), e1) ) } ) setMethod("Math", signature(x='RasterLayerSparse'), function(x){ if (!hasValues(x)) { return(x) } # funname <- as.character(sys.call(sys.parent())[[1]]) funname <- .Generic if (substr(funname, 1, 3) == 'cum' ) { setValues(x, do.call(funname, list(x@data@values))) } else { setValues(x, methods::callGeneric(x@data@values)) } } ) setMethod('setValues', signature(x='RasterLayerSparse'), function(x, values, index=NULL, ...) { stopifnot(is.vector(values)) if (!(is.numeric(values) | is.integer(values) | is.logical(values))) { stop('values must be numeric, integer or logical.') } if (is.null(index)) { if (! hasValues(x)) { stop('you must supply an index argument if the RasterLayerSparse does not have values') } stopifnot(length(x@index) == length(values)) } else { stopifnot(is.vector(index)) stopifnot(length(index) == length(values)) stopifnot(all(index > 0 | index <= ncell(x))) x@index <- index } x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@file@name <- "" x@file@driver <- "" x@data@values <- values x <- setMinMax(x) return(x) } ) setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='numeric'), function(x, row, nrows, format='') { row <- round(row) nrows <- round(nrows) stopifnot(validRow(x, row)) stopifnot(nrows > 0) row <- min(x@nrows, max(1, row)) endrow <- max(min(x@nrows, row+nrows-1), row) nrows <- endrow - row + 1 nc <- ncol(x) startcell <- cellFromRowCol(row, 1) lastcell <- cellFromRowCol(endrow, nc) if (inMemory(x)){ i <- which(x@index >= startcell & x@index <= lastcell) if (length(i) > 0) { v <- cellFromRowColCombine(x, row:endrow, 1:nc) m <- match(i, v) v[] <- NA v[m] <- x@data@values[i] } else { v <- rep(NA, nrows * x@ncols) } } else if ( fromDisk(x) ) { # not yet implemented ## v <- .readRasterLayerValues(x, row, nrows) } else { v <- rep(NA, nrows * x@ncols) } if (format=='matrix') { v <- matrix(v, nrow=nrows, byrow=TRUE) rownames(v) <- row:(row+nrows-1) colnames(v) <- 1:ncol(v) } return(v) } ) setMethod('getValuesBlock', signature(x='RasterLayerSparse'), function(x=1, row, nrows=1, col=1, ncols=(ncol(x)-col+1), format='', ...) { row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) if (!(validRow(x, row))) { stop(paste(row, 'is not a valid rownumber')) } if ( inMemory(x) ) { i <- which(x@index >= startcell & x@index <= lastcell) if (length(i) > 0) { res <- cellFromRowColCombine(x, row:lastrow, col:lastcol) m <- match(i, res) res[] <- NA res[m] <- x@data@values[i] } else { res <- rep(NA, nrows * ncols) } } else if ( fromDisk(x) ) { # not yet implemented #if (! fromDisk(x)) { # return(rep(NA, times=(lastcell-startcell+1))) #} #res <- .readRasterLayerValues(x, row, nrows, col, ncols, is.open) } else { res <- rep(NA, nrows * ncols) } if (format=='matrix') { res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE ) colnames(res) <- col:lastcol rownames(res) <- row:lastrow } res } ) setMethod("getValues", signature(x='RasterLayerSparse', row='missing', nrows='missing'), function(x, format='') { cr <- c(x@ncols, x@nrows) if ( inMemory(x) ) { i <- x@index v <- x@data@values x <- rep(NA, ncell(x)) x[i] <- v } else if ( fromDisk(x) ) { # not yet implemented ### x <- .readRasterLayerValues(x, 1, x@nrows) } else { x <- rep(NA, ncell(x)) } if (format=='matrix') { x <- matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) } return( x ) } ) raster/R/plotRaster2.R0000644000176200001440000000264014160021141014307 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 0.9 # Licence GPL v3 .plotraster2 <- function(object, col=rev(terrain.colors(250)), maxpixels=100000, xlab='', ylab='', ext=NULL, xlim, ylim, add=FALSE, addfun=NULL, colNA=NA, main, facvar=0, alpha=NULL, ...) { if ( ! hasValues(object) ) { stop('no values associated with this RasterLayer') } maxpixels <- max(1, maxpixels) if (is.null(ext)) { ext <- extent(object) } else { ext <- intersect(extent(object), ext) } if (!missing(xlim)) { if (xlim[1] >= xlim[2]) stop('invalid xlim') if (xlim[1] < ext@xmax) ext@xmin <- xlim[1] if (xlim[2] > ext@xmin) ext@xmax <- xlim[2] } if (!missing(ylim)) { if (ylim[1] >= ylim[2]) stop('invalid ylim') if (ylim[1] < ext@ymax) ext@ymin <- ylim[1] if (ylim[2] > ext@ymin) ext@ymax <- ylim[2] } # leg <- object@legend object <- sampleRegular(object, size=maxpixels, ext=ext, asRaster=TRUE) if (!is.null(alpha)) { if (inherits(alpha, 'RasterLayer')) { alpha <- sampleRegular(alpha, size=maxpixels, ext=ext, asRaster=TRUE) } } if (facvar > 0) { object <- deratify(object, facvar) } if (missing(main)) { main <- '' #main <- names(object) } .rasterImagePlot(object, col=col, xlab=xlab, ylab=ylab, add=add, colNA=colNA, main=main, alpha=alpha, ...) if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } } raster/R/plotRGB.R0000644000176200001440000000734514160021141013406 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2010 # Version 0.9 # Licence GPL v3 # partly based on functions in the pixmap package by Friedrich Leisch setMethod("plotRGB", signature(x='RasterStackBrick'), function(x, r=1, g=2, b=3, scale, maxpixels=500000, stretch=NULL, ext=NULL, interpolate=FALSE, colNA='white', alpha, bgalpha, addfun=NULL, zlim=NULL, zlimcol=NULL, axes=FALSE, xlab='', ylab='', asp=NULL, add=FALSE, margins=FALSE, ...) { x <- x[[c(r, g, b)]] if (missing(scale)) { scale <- 255 if (! inherits(x, 'RasterStack')) { if ( x@data@haveminmax ) { scale <- max(max(x@data@max), 255) } } } scale <- as.vector(scale)[1] r <- sampleRegular(raster(x,1), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) g <- sampleRegular(raster(x,2), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) b <- sampleRegular(raster(x,3), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) RGB <- cbind(getValues(r), getValues(g), getValues(b)) if (!is.null(zlim)) { if (length(zlim) == 2) { zlim <- sort(zlim) if (is.null(zlimcol)) { RGB[ RGBzlim[2] ] <- zlim[2] } else { #if (is.na(zlimcol)) { RGB[RGBzlim[2]] <- NA } } else if (NROW(zlim) == 3 & NCOL(zlim) == 2) { for (i in 1:3) { zmin <- min(zlim[i,]) zmax <- max(zlim[i,]) if (is.null(zlimcol)) { RGB[RGB[,i] < zmin, i] <- zmin RGB[RGB[,i] > zmax, i] <- zmax } else { #if (is.na(zlimcol)) { RGB[RGB < zmin | RGB > zmax, i] <- NA } } } else { stop('zlim should be a vector of two numbers or a 3x2 matrix (one row for each color)') } } RGB <- stats::na.omit(RGB) if (!is.null(stretch)) { stretch = tolower(stretch) if (stretch == 'lin') { RGB[,1] <- .linStretchVec(RGB[,1]) RGB[,2] <- .linStretchVec(RGB[,2]) RGB[,3] <- .linStretchVec(RGB[,3]) scale <- 255 } else if (stretch == 'hist') { RGB[,1] <- .eqStretchVec(RGB[,1]) RGB[,2] <- .eqStretchVec(RGB[,2]) RGB[,3] <- .eqStretchVec(RGB[,3]) scale <- 255 } else if (stretch != '') { warning('invalid stretch value') } } naind <- as.vector( attr(RGB, "na.action") ) if (!is.null(naind)) { bg <- grDevices::col2rgb(colNA) bg <- grDevices::rgb(bg[1], bg[2], bg[3], alpha=bgalpha, maxColorValue=255) z <- rep( bg, times=ncell(r)) z[-naind] <- grDevices::rgb(RGB[,1], RGB[,2], RGB[,3], alpha=alpha, maxColorValue=scale) } else { z <- grDevices::rgb(RGB[,1], RGB[,2], RGB[,3], alpha=alpha, maxColorValue=scale) } z <- matrix(z, nrow=nrow(r), ncol=ncol(r), byrow=T) requireNamespace("grDevices") bb <- as.vector(t(bbox(r))) if (!add) { if ((!axes) & (!margins)) { graphics::par(plt=c(0,1,0,1)) } if (is.null(asp)) { if (couldBeLonLat(x)) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) #asp <- min(5, 1/cos((ym * pi)/180)) } else { asp <- 1 } } xlim=c(bb[1], bb[2]) ylim=c(bb[3], bb[4]) plot(NA, NA, xlim=xlim, ylim=ylim, type = "n", xaxs='i', yaxs='i', xlab=xlab, ylab=ylab, asp=asp, axes=FALSE, ...) if (axes) { xticks <- graphics::axTicks(1, c(xmin(r), xmax(r), 4)) yticks <- graphics::axTicks(2, c(ymin(r), ymax(r), 4)) if (xres(r) %% 1 == 0) xticks = round(xticks) if (yres(r) %% 1 == 0) yticks = round(yticks) graphics::axis(1, at=xticks) graphics::axis(2, at=yticks, las = 1) #graphics::axis(3, at=xticks, labels=FALSE, lwd.ticks=0) #graphics::axis(4, at=yticks, labels=FALSE, lwd.ticks=0) } } graphics::rasterImage(z, bb[1], bb[3], bb[2], bb[4], interpolate=interpolate, ...) if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } } ) raster/R/roundExtent.R0000644000176200001440000000150614160021141014405 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod("Math2", signature(x='Extent'), function (x, digits=0) { #digits <- max(0, round(digits)) x@xmin <- methods::callGeneric( x@xmin, digits) x@xmax <- methods::callGeneric( x@xmax, digits) x@ymin <- methods::callGeneric( x@ymin, digits) x@ymax <- methods::callGeneric( x@ymax, digits) validObject(x) return(x) } ) setMethod("floor", signature(x='Extent'), function (x) { x@xmin <- floor( x@xmin) x@xmax <- ceiling( x@xmax) x@ymin <- floor( x@ymin) x@ymax <- ceiling( x@ymax) return(x) } ) setMethod("ceiling", signature(x='Extent'), function (x) { x@xmin <- ceiling( x@xmin) x@xmax <- floor( x@xmax) x@ymin <- ceiling( x@ymin) x@ymax <- floor( x@ymax) return(x) } ) raster/R/buffer.R0000644000176200001440000001023014160021141013331 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 .pointBuffer <- function(xy, d, lonlat=TRUE, a=6378137, f=1/298.257223563, crs="", ... ) { n <- list(...)$quadsegs if (is.null(n)) { n <- 360 } else { n <- n * 4 } if (length(d)==1) { d <- rep(d, nrow(xy)) } else if (length(d) != nrow(xy)) { # recycling dd <- vector(length=nrow(xy)) dd[] <- d d <- dd } n <- max(5, round(n)) brng <- 1:n * 360/n pols <- list() if (lonlat) { a = 6378137.0 f = 1/298.257223563 for (i in 1:nrow(xy)) { p <- cbind(xy[i,1], xy[i,2], brng, d[i]) #r <- .Call("geodesic", as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f), PACKAGE='raster') #pols[[i]] <- matrix(r, ncol=3, byrow=TRUE)[, 1:2] r <- .Call("_raster_dest_point", p, TRUE, a, f, PACKAGE='raster') pols[[i]] <- r[,1:2] } } else { brng <- brng * pi/180 for (i in 1:nrow(xy)) { x <- xy[i,1] + d[i] * cos(brng) y <- xy[i,2] + d[i] * sin(brng) pols[[i]] <- cbind(x, y) } } sp <- do.call(spPolygons, pols) crs(sp) <- crs sp } setMethod('buffer', signature(x='Spatial'), function(x, width=1, dissolve=TRUE, ...) { if (inherits(x, 'SpatialPoints')) { if (.couldBeLonLat(x)) { if (!isLonLat(x)) { warning('crs unknown, assuming lonlat') } lonlat=TRUE } else { lonlat = FALSE } pb <- .pointBuffer(xy=sp::coordinates(x)[,1:2,drop=FALSE], d=width, lonlat=lonlat, crs=crs(x), ...) if (dissolve) { pb <- aggregate(pb) } else if (.hasSlot(x, 'data')) { pb <- sp::SpatialPolygonsDataFrame(pb, x@data, match.ID=FALSE) } return(pb) } valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) prj <- x@proj4string x@proj4string <- sp::CRS(as.character(NA)) x <- rgeos::gBuffer(x, byid=!dissolve, width=width, ...) x@proj4string <- prj x } ) setMethod('buffer', signature(x='RasterLayer'), function(x, width=0, filename='', doEdge=FALSE, ...) { stopifnot(width > 0) if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (class(pts)[1] == "try-error") { d <- .distanceRows(x, filename=filename, ...) d <- reclassify(d, rbind(c(-1,width, 1), c(width, Inf, NA))) return(d) } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells for which to compute a distance') } out <- raster(x) filename <- trim(filename) if (couldBeLonLat(x)) { longlat=TRUE } else { longlat=FALSE } if (canProcessInMemory(out, 6)) { pb <- pbCreate(4, label='buffer', ...) v <- values(x) i <- is.na(v) if (!any(i)) { stop('raster has no NA values to compute distance to') } pbStep(pb) xy <- xyFromCell(out, which(i)) vals <- .Call('_raster_distanceToNearestPoint', xy, pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') pbStep(pb) v[!i] <- 1 v[i] <- NA^(vals > width) out <- setValues(out, v) pbStep(pb) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='buffer', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- 0 if (length(j) > 0) { vals[j] <- .Call('_raster_distanceToNearestPoint', xy[j,,drop=FALSE], pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') } vals[vals > width] <- NA vals[!is.na(vals)] <- 1 out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) raster/R/RcppExports.R0000644000176200001440000000661714160021141014367 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 .doBilinear <- function(xy, x, y, v) { .Call(`_raster_doBilinear`, xy, x, y, v) } .broom <- function(d, f, dm, dist, down) { .Call(`_raster_broom`, d, f, dm, dist, down) } .doCellFromRowCol <- function(nrow, ncol, rownr, colnr) { .Call(`_raster_doCellFromRowCol`, nrow, ncol, rownr, colnr) } .clamp <- function(d, r, usevals) { .Call(`_raster_do_clamp`, d, r, usevals) } .edge <- function(d, dim, classes, edgetype, dirs) { .Call(`_raster_do_edge`, d, dim, classes, edgetype, dirs) } .focal_fun <- function(d, w, dim, fun, naonly) { .Call(`_raster_do_focal_fun`, d, w, dim, fun, naonly) } .focal_get <- function(d, dim, ngb) { .Call(`_raster_do_focal_get`, d, dim, ngb) } .focal_sum <- function(d, w, dim, narm, naonly, bemean) { .Call(`_raster_do_focal_sum`, d, w, dim, narm, naonly, bemean) } .getPolygons <- function(xyv, res, nodes) { .Call(`_raster_getPolygons`, xyv, res, nodes) } .layerize <- function(d, cls, falsena) { .Call(`_raster_layerize`, d, cls, falsena) } .availableRAM <- function(ram) { .Call(`_raster_availableRAM`, ram) } .getMode <- function(values, ties) { .Call(`_raster_getMode`, values, ties) } .doSpmin <- function(x, y) { .Call(`_raster_doSpmin`, x, y) } .doSpmax <- function(x, y) { .Call(`_raster_doSpmax`, x, y) } .ppmin <- function(x, y, narm) { .Call(`_raster_ppmin`, x, y, narm) } .ppmax <- function(x, y, narm) { .Call(`_raster_ppmax`, x, y, narm) } .doRowMin <- function(x, narm) { .Call(`_raster_doRowMin`, x, narm) } .doRowMax <- function(x, narm) { .Call(`_raster_doRowMax`, x, narm) } .aggregate_get <- function(d, dims) { .Call(`_raster_aggregate_get`, d, dims) } .aggregate_fun <- function(d, dims, narm, fun) { .Call(`_raster_aggregate_fun`, d, dims, narm, fun) } .get_area_polygon <- function(d, lonlat) { .Call(`_raster_get_area_polygon`, d, lonlat) } .point_distance <- function(p1, p2, lonlat, a, f) { .Call(`_raster_point_distance`, p1, p2, lonlat, a, f) } .distanceToNearestPoint <- function(d, p, lonlat, a, f) { .Call(`_raster_distanceToNearestPoint`, d, p, lonlat, a, f) } .directionToNearestPoint <- function(d, p, lonlat, degrees, from, a, f) { .Call(`_raster_directionToNearestPoint`, d, p, lonlat, degrees, from, a, f) } .dest_point <- function(xybd, lonlat, a, f) { .Call(`_raster_dest_point`, xybd, lonlat, a, f) } .reclassify <- function(d, rcl, dolowest, doright, doleftright, NAonly, NAval) { .Call(`_raster_reclassify`, d, rcl, dolowest, doright, doleftright, NAonly, NAval) } .terrain <- function(d, dim, res, unit, option, geo, gy) { .Call(`_raster_do_terrains`, d, dim, res, unit, option, geo, gy) } .doCellFromXY <- function(ncols, nrows, xmin, xmax, ymin, ymax, x, y) { .Call(`_raster_doCellFromXY`, ncols, nrows, xmin, xmax, ymin, ymax, x, y) } .doXYFromCell <- function(ncols, nrows, xmin, xmax, ymin, ymax, cell) { .Call(`_raster_doXYFromCell`, ncols, nrows, xmin, xmax, ymin, ymax, cell) } .doFourCellsFromXY <- function(ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat) { .Call(`_raster_doFourCellsFromXY`, ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat) } raster/R/extractPoints_sp.R0000644000176200001440000000353514160235735015463 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2014 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='SpatialPolygons', y='SpatialPoints'), function(x, y, ...){ valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) if (! identical( .proj4string(x), .proj4string(y)) ) { warning('non identical crs') y@proj4string <- x@proj4string } i <- rgeos::gIntersects(y, x, byid=TRUE) j <- cbind(1:length(y), rep(1:length(x), each=length(y)), as.vector(t(i))) j <- j[j[,3] == 1, -3, drop=FALSE] colnames(j) <- c('point.ID', 'poly.ID') if (.hasSlot(x, 'data')) { r <- data.frame(j, x@data[j[,2], ,drop=FALSE], row.names=NULL) } else { r <- data.frame(j, row.names=NULL) } q <- data.frame(point.ID = 1:length(y)) merge(q, r, by='point.ID', all=TRUE) }) setMethod('extract', signature(x='SpatialPolygons', y='data.frame'), function(x, y, ...) { stopifnot(ncol(y) == 2) y <- as.matrix(y) stopifnot(is.numeric(y[1,1])) extract(x, y, ...) } ) setMethod('extract', signature(x='SpatialPolygons', y='matrix'), function(x, y, ...) { stopifnot(ncol(y) == 2) stopifnot(is.numeric(y[1,1])) i <- which(rowSums(is.na(y)) == 0) if (length(i) == 0) { r <- cbind(data.frame(point.ID=1:nrow(y), poly.ID=NA), x@data[0,][1:nrow(y),]) rownames(r) <- NULL } else if (length(i) < nrow(y)) { sp <- sp::SpatialPoints(y[i,], proj4string=x@proj4string) v <- extract(x, sp, ...) r <- cbind(data.frame(point.ID=1:nrow(y), poly.ID=NA), x@data[0,][1:nrow(y),]) if (nrow(v) == nrow(sp)) { # no overlapping polygons r[i, ] <- v } else { r <- r[! r$point.ID %in% i, ] r <- rbind(r, v) r <- r[order(r$point.ID), ] } rownames(r) <- NULL } else { sp <- sp::SpatialPoints(y, proj4string=x@proj4string) r <- extract(x, sp, ...) } return(r) } ) raster/R/rotate.R0000644000176200001440000000250514160241365013400 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('rotate', signature(x='Raster'), function(x, filename='', ...) { e <- extent(x) if (e@xmin < -60) { warning('xmin is much smaller than zero. No rotation done') return(x) } xrange <- e@xmax - e@xmin if (xrange < 350 | xrange > 370 | e@xmin < -10 | e@xmax > 370) { if (xrange < 350 | xrange > 370 | e@xmin < -190 | e@xmax > 190) { warning('this does not look like an appropriate object for this function') } } xr <- xres(x) ext1 <- extent(-xr, 180, -100, 100) if (is.null(intersect(e, ext1 ))) { r1 <- NULL } else { r1 <- crop(x, ext1) } ext2 <- extent(180, 360+xr, -100, 100) if (is.null(intersect(e, ext2 ))) { r2 <- NULL } else { r2 <- crop(x, ext2) r2 <- shift(r2, -360) } ln <- names(x) if (is.null(r1)) { out <- r2 } else if (is.null(r2)) { out <- r1 } else { out <- merge(r1, r2, overlap=FALSE) } names(out) <- names(x) out@z <- x@z # suggested by Mike Sumner: p <- proj4string(out) if (length(grep("\\+over", p)) > 0) { projection(out) <- gsub("[[:space:]]\\+over", "", p) } if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } ) raster/R/bilinearValue.R0000644000176200001440000000640414160021141014652 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Licence GPL v3 # updated November 2011 # version 1.0 .bilinearValue <- function(raster, xyCoords, layer, n) { #bilinear <- function(xy, x, y, v) { # .doBilinear(xy, x, y, v) #} r <- raster(raster) nls <- nlayers(raster) four <- fourCellsFromXY(r, xyCoords, duplicates=FALSE) xy4 <- matrix(xyFromCell(r, as.vector(four)), ncol=8) x <- rbind(.doSpmin(xy4[,1], xy4[,3]), .doSpmax(xy4[,1], xy4[,3])) y <- rbind(.doSpmin(xy4[,5], xy4[,6]), .doSpmax(xy4[,5], xy4[,6])) # data.frame is faster than cbind in this case (less copying?) xy4 <- data.frame( x = c(x[1,], x[1,], x[2,], x[2,]), y = c(y[1,], y[2,], y[1,], y[2,]) ) cells <- cellFromXY(r, xy4) suppressWarnings(row1 <- rowFromCell(r, min(cells, na.rm=TRUE))) if (is.na(row1)) { if (nls == 1) { return(rep(NA, nrow(xyCoords))) } else { return(matrix(NA, nrow= nrow(xyCoords), ncol=nls)) } } nrows <- rowFromCell(r, max(cells, na.rm=TRUE)) - row1 + 1 offs <- cellFromRowCol(r, row1, 1) - 1 cells <- cells - offs if (nls == 1) { vv <- getValues(raster, row1, nrows) v <- matrix( vv[cells], ncol=4) res <- rep(NA, nrow(v)) rs <- rowSums(is.na(v)) i <- rs==3 if (sum(i) > 0) { cells <- cellFromXY(raster, xyCoords[i,]) - offs res[i] <- vv[cells] } i <- rs > 0 & rs < 3 if (sum(i) > 0) { vv <- v[i,,drop=FALSE] vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2] vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1] vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4] vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3] vmean <- rep(rowMeans(vv, na.rm=TRUE), 4) vv[is.na(vv)] <- vmean[is.na(vv)] # res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], vv) res[i] <- .doBilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv) } i <- rs==0 if (sum(i) > 0) { # res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], v[i,]) res[i] <- .doBilinear(xyCoords[i, ,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE]) } res } else { if (missing(layer)) { layer <- 1 } if (missing(n)) { n <- (nls-layer+1) } lyrs <- layer:(layer+n-1) allres <- matrix(ncol=length(lyrs), nrow=nrow(xyCoords)) colnames(allres) <- names(raster)[lyrs] cvv <- getValues(raster, row1, nrows)[, lyrs] cv <- cvv[cells,] for (j in 1:ncol(cv)) { v <- matrix(cv[, j], ncol=4) res <- rep(NA, nrow(v)) rs <- rowSums(is.na(v)) i <- rs==3 if (sum(i) > 0) { cells <- cellFromXY(raster, xyCoords[i,]) - offs res[i] <- cvv[cells, j] } i <- rs > 0 & rs < 3 if (sum(i) > 0) { vv <- v[i,,drop=FALSE] vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2] vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1] vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4] vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3] vmean <- rep(rowMeans(vv, na.rm=TRUE), 4) vv[is.na(vv)] <- vmean[is.na(vv)] res[i] <- .doBilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv) } i <- rs==0 if (sum(i) > 0) { res[i] <- .doBilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE]) } allres[,j] <- res } allres } } raster/R/is.na.R0000644000176200001440000000545514160021141013105 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("is.na", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.na(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.na( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("is.nan", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.nan(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.nan( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("is.finite", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.finite(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.finite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("is.infinite", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.infinite(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.infinite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) raster/R/plotExent.R0000644000176200001440000000077114160021141014053 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 .extentMatrix <- function(x) { xy <- matrix(NA, nrow=5, ncol=2) xy[c(1,4),1] <- x@xmin xy[2:3,1] <- x@xmax xy[1:2,2] <- x@ymax xy[3:4,2] <- x@ymin xy[5,] <- xy[1,] return(xy) } setMethod("plot", signature(x='Extent', y='missing'), function(x, y, type='l', add=FALSE, ...) { xy <- .extentMatrix(x) if (add) { lines(xy, ...) } else { plot(xy, type=type, ...) } } ) raster/R/resample.R0000644000176200001440000000751514160021141013704 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod('resample', signature(x='Raster', y='Raster'), function(x, y, method="bilinear", filename="", ...) { # to do: compare projections of x and y ln <- names(x) nl <- nlayers(x) if (nl == 1) { y <- raster(y) if (method=='ngb') { colortable(y) <- colortable(x) } } else { y <- brick(y, values=FALSE, nl=nl) } if (!hasValues(x)) { return(y) } if (!method %in% c('bilinear', 'ngb')) { stop('invalid method') } if (method == 'ngb') method <- 'simple' skipaggregate <- isTRUE(list(...)$skipaggregate) if (!skipaggregate) { rres <- res(y) / res(x) resdif <- max(rres) if (resdif > 2) { ag <- pmax(1, floor(rres-1)) if (max(ag) > 1) { if (method == 'bilinear') { x <- aggregate(x, ag, 'mean') } else { x <- aggregate(x, ag, modal) } } } } e <- .intersectExtent(x, y, validate=TRUE) filename <- trim(filename) if (canProcessInMemory(y, 4*nl)) { inMemory <- TRUE v <- matrix(NA, nrow=ncell(y), ncol=nlayers(x)) } else { inMemory <- FALSE y <- writeStart(y, filename=filename, ... ) } if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(ceiling(y@nrows/10), length(cl)) # at least 10 rows per node message('Using cluster with ', nodes, ' nodes') utils::flush.console() tr <- blockSize(y, minblocks=nodes, n=nl*4*nodes) pb <- pbCreate(tr$n, label='resample', ...) clFun <- function(i) { #r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xy <- xyFromCell(y, cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, ncol(y)) ) .xyValues(x, xy, method=method) } parallel::clusterExport(cl, c('x', 'y', 'tr', 'method'), envir=environment()) .sendCall <- eval( parse( text="parallel:::sendCall") ) for (ni in 1:nodes) { .sendCall(cl[[ni]], clFun, list(ni), tag=ni) } if (inMemory) { for (i in 1:tr$n) { d <- .recvOneData(cl) if (! d$value$success) { stop('cluster error') } start <- cellFromRowCol(y, tr$row[d$value$tag], 1) end <- cellFromRowCol(y, tr$row[d$value$tag]+tr$nrows[d$value$tag]-1, y@ncols) v[start:end, ] <- d$value$value ni <- ni + 1 if (ni <= tr$n) { .sendCall(cl[[d$node]], clFun, list(ni), tag=ni) } pbStep(pb) } y <- setValues(y, v) if (filename != '') { writeRaster(y, filename, ...) } } else { for (i in 1:tr$n) { d <- .recvOneData(cl) y <- writeValues(y, d$value$value, tr$row[d$value$tag]) ni <- ni + 1 if (ni <= tr$n) { .sendCall(cl[[d$node]], clFun, list(ni), tag=ni) } pbStep(pb) } y <- writeStop(y) } } else { tr <- blockSize(y, n=nl*4) pb <- pbCreate(tr$n, label='resample', ...) if (inMemory) { for (i in 1:tr$n) { #r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xy <- xyFromCell(y, cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, ncol(y)) ) vals <- .xyValues(x, xy, method=method) start <- cellFromRowCol(y, tr$row[i], 1) end <- cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, y@ncols) v[start:end, ] <- vals pbStep(pb, i) } v <- setValues(y, v) if (filename != '') { v <- writeRaster(v, filename, ...) } pbClose(pb) names(v) <- ln return(v) } else { for (i in 1:tr$n) { #r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xy <- xyFromCell(y, cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, ncol(y)) ) vals <- .xyValues(x, xy, method=method) y <- writeValues(y, vals, tr$row[i]) pbStep(pb, i) } y <- writeStop(y) } } pbClose(pb) names(y) <- ln return(y) } ) raster/R/indexReplaceBrick.R0000644000176200001440000001471214160021141015447 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setMethod("$", "Raster", function(x, name) { x[[name]] } ) setMethod("$<-", "Raster", function(x, name, value) { i <- which(name == names(x))[1] if (is.na(i)) { if (inherits(value, 'Raster')) { names(value) <- name x <- addLayer(x, value) return(x) } else { r <- raster(x) names(r) <- name r[] <- value x <- addLayer(x, r) return(x) } } else { if (inherits(value, 'Raster')) { if (inherits(x, 'RasterLayer')) { if (name == names(x)) { x <- value } else { x <- stack(x) x[[name]] <- value } } else { x[[name]] <- value } } else { r <- x[[name]] r[] <- value x[[name]] <- value } return(x) } } ) setMethod("[[", "Raster", function(x,i,j,...,drop=TRUE) { if ( missing(i)) { stop('you must provide an index') } if (! missing(j)) { warning('second index is ignored') } if (is.numeric(i)) { sgn <- sign(i) sgn[sgn==0] <- 1 if (! all(sgn == 1) ) { if (! all(sgn == -1) ) { stop("only 0's may be mixed with negative subscripts") } else { i <- (1:nlayers(x))[i] } } } subset(x, i, drop=drop) }) setReplaceMethod("[[", c("RasterStackBrick", "character", "missing"), function(x, i, j, value) { if (inherits(value, 'Raster')) { names(value) <- i } n <- which(i == names(x))[1] if (is.na(n)) { n <- nlayers(x) + 1 } x[[n]] <- value x } ) setReplaceMethod("[[", c("RasterLayer", "character", "missing"), function(x, i, j, value) { stopifnot(length(i) == 1) if (i[1] != names(x)) { x <- stack(x) x[[i]] <- value return(x) } if (inherits(value, 'RasterLayer')) { names(value) <- i return(value) } else if (inherits(value, 'Raster')) { if (nlayers(value) == 1) { value <- value[[1]] names(value) <- i return(value) } else { stop("too many layers") } } setValues(x, value) } ) setReplaceMethod("[[", c("RasterStack", "numeric", "missing"), function(x, i, j, value) { i <- round(i) if (i < 1) { stop('index should be > 0') } nl <- nlayers(x) if (i > nl + 1) { stop('index should be <= nlayers(x)+1') } if (!inherits(value, 'RasterLayer')) { val <- value if (i > nl) { value <- x[[nl]] } else { value <- x[[i]] } value[] <- val } else { compareRaster(x, value) } if (i > nl) { x <- addLayer(x, value) } else { x@layers[[i]] <- value } x } ) setReplaceMethod("[[", c("Raster", "numeric", "missing"), function(x, i, j, value) { i <- round(i) if (i < 1) { stop('index should be > 0') } nl <- nlayers(x) if (i > nl + 1) { stop('index should be <= nlayers(x)+1') } if (inherits(x, "RasterLayer")) { return(value) } if (canProcessInMemory(x)) { if (!inMemory(x)) { x <- readAll(x) } if (inherits(value, 'RasterLayer')) { compareRaster(x, value) x <- setValues(x, getValues(value), i) names(x)[i] <- names(value) } else { val <- value if (i > nl) { value <- getValues(x[[nl]]) } else { value <- getValues(x[[i]]) } # for recycling value[] <- val x <- setValues(x, value, i) } } else { x <- stack(x) x[[i]] <- value } return(x) } ) setReplaceMethod("[", c("RasterStackBrick", "Raster", "missing"), function(x, i, j, value) { nl <- nlayers(i) if (! hasValues(i) ) { i <- cellsFromExtent(x, i) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { dims <- dim(i) i <- as.logical(getValues(i)) dim(i) <- c(prod(dims[1:2]), dims[3]) } else { i <- cellsFromExtent(x, i) } if (nl < nlayers(x)) { .replace(x, i, value=value, recycle=nl) } else { .replace(x, i, value=value, recycle=0) } } ) setReplaceMethod("[", c("Raster", "Extent", "missing"), function(x, i, j, value) { i <- cellsFromExtent(x, i) .replace(x, i, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster", "Spatial", "missing"), function(x, i, j, value) { if (inherits(i, 'SpatialPolygons')) { v <- 1:length(i@polygons) v[] <- value return( .polygonsToRaster(i, x, field=v, fun='last', mask=FALSE, update=TRUE, updateValue="all", silent=TRUE) ) } else if (inherits(i, 'SpatialLines')) { v <- 1:length(i@lines) v[] <- value return( .linesToRaster(i, x, field=v, fun='last', mask=FALSE, update=TRUE, updateValue="all", silent=TRUE) ) } else { # if (inherits(i, 'SpatialPoints')) { i <- cellFromXY(x, sp::coordinates(i)[,1:2,drop=FALSE]) return( .replace(x, i, value=value, recycle=1) ) } } ) setReplaceMethod("[", c("RasterStackBrick","missing","missing"), function(x, i, j, value) { nl <- nlayers(x) if (inherits(x, 'RasterStack')) { x <- brick(x, values=FALSE) } if (is.matrix(value)) { if (all(dim(value) == c(ncell(x), nl))) { x <- try( setValues(x, value)) } else { stop('dimensions of the matrix do not match the Raster* object') } } else { v <- try( matrix(nrow=ncell(x), ncol=nl) ) if (! inherits(x, "try-error")) { v[] <- value x <- try( setValues(x, v) ) } } if (inherits(x, "try-error")) { stop('cannot set values on this raster (it is too large)') } return(x) } ) setReplaceMethod("[", c("Raster", "numeric", "numeric"), function(x, i, j, value) { i <- cellFromRowColCombine(x, i, j) .replace(x, i, value, recycle=1) } ) setReplaceMethod("[", c("Raster","missing", "numeric"), function(x, i, j, value) { j <- cellFromCol(x, j) .replace(x, j, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster","numeric", "missing"), function(x, i, j, value) { theCall <- sys.call(-1) narg <- length(theCall)-length(match.call(call=sys.call(-1))) if (narg > 0) { i <- cellFromRow(x, i) } .replace(x, i=i, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster", "matrix", "missing"), function(x, i, j, value) { if (ncol(i) == 2) { i <- cellFromRowCol(x, i[,1], i[,2]) } else { i <- as.vector(i) } .replace(x, i=i, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster", "logical", "missing"), function(x, i, j, value) { .replace(x, i, value, recycle=1) } ) raster/R/kernelDens.R0000644000176200001440000000177014160021141014163 0ustar liggesusers ### this is the kde2d function from the MASS packlage with minimal changes .kde2d <- function (x, y, h, n, lims) { nx <- length(x) gx <- seq.int(lims[1L], lims[2L], length.out = n[1L]) gy <- seq.int(lims[3L], lims[4L], length.out = n[2L]) h <- h/4 ax <- outer(gx, x, "-")/h[1L] ay <- outer(gy, y, "-")/h[2L] tcrossprod(matrix(stats::dnorm(ax), , nx), matrix(stats::dnorm(ay), , nx))/(nx * h[1L] * h[2L]) } .kernelDens <- function(p, x, bandwidth, ...) { .bandwidth.nrd <- function(x) { ### this function is from the MASS package r <- stats::quantile(x, c(0.25, 0.75)) h <- (r[2L] - r[1L])/1.34 4 * 1.06 * min(sqrt(stats::var(x)), h) * length(x)^(-1/5) } if(missing(bandwidth)) { bw <- c(.bandwidth.nrd(p[,1]), .bandwidth.nrd(p[,2])) } else { bw <- rep(bandwidth, length.out = 2L) } v <- .kde2d(p[,1], p[,2], bw, dim(x)[1:2], as.vector(t(bbox(x)))) v <- t(v) v <- v[nrow(v):1, ] setValues(x, v) } #a = kernelDens(xy, r) raster/R/as.array.R0000644000176200001440000000161314160021141013605 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 setMethod('as.array', signature(x='RasterLayer'), function(x, maxpixels, ...) { if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } x <- array(as.matrix(x), c(dim(x))) x } ) setMethod('as.array', signature(x='RasterStackBrick'), function(x, maxpixels, transpose=FALSE) { if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } dm <- dim(x) x <- getValues(x) if (transpose) { ar <- array(NA, c(dm[2], dm[1], dm[3])) for (i in 1:dm[3]) { ar[,,i] <- matrix(x[,i], nrow=dm[2], byrow=FALSE) } } else { ar <- array(NA, dm) for (i in 1:dm[3]) { ar[,,i] <- matrix(x[,i], nrow=dm[1], byrow=TRUE) } } ar } ) raster/R/barplot.R0000644000176200001440000000122414160021141013526 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 setMethod('barplot', 'RasterLayer', function(height, maxpixels=1000000, digits=0, breaks=NULL, col=rainbow, ...) { x <- sampleRegular(height, maxpixels) adj <- length(x) / ncell(height) if (adj < 1) { warning('a sample of ', round(100*adj, 1), '% of the raster cells were used to estimate frequencies') } if (!is.null(digits)) { x <- round(x, digits) } if (!is.null(breaks)) { x <- cut(x, breaks) } x <- table(x) / adj if (is.function(col)) { col <- col(length(x)) } barplot(x, col=col, ...) } ) raster/R/summary-methods.R0000644000176200001440000000420714160021141015225 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .addArgs <- function(...) { lst <- list(...) if (length(lst) > 0 ) { i <- sapply(lst, function(x) class(x) %in% c('logical', 'integer', 'numeric')) add <- unlist(lst[i], use.names = FALSE) } else { add <- NULL } return(add) } setMethod("Summary", signature(x='Raster'), function(x, ..., na.rm=FALSE){ fun <- as.character(sys.call()[[1L]]) dots <- list(...) if (length(dots) > 0) { d <- sapply(dots, function(i) inherits(i, 'Raster')) if (any(d)) { x <- .makeRasterList(x, dots[d]) if (length(x) > 1) { x <- stack(x) } else { x <- x[[1]] } } add <- .addArgs(unlist(dots[!d])) } else { add <- NULL } if (nlayers(x)==1 & length(add)==0) { warning('Nothing to summarize if you provide a single RasterLayer; see cellStats') return(x) } if (fun[1] == 'sum') { return(.sum( x, add, na.rm=na.rm)) } else if (fun[1] == 'min') { return(.min( x, add, na.rm=na.rm )) } else if (fun[1] == 'max') { return(.max( x, add, na.rm=na.rm)) } else if (fun[1] == 'range') { return(.range( x, add, na.rm=na.rm)) } out <- raster(x) if (canProcessInMemory(x)) { if (!is.null(add)) { add <- fun(add, na.rm=na.rm) x <- cbind(getValues(x), add) } else { x <- getValues(x) } x <- apply(x, 1, FUN=fun, na.rm=na.rm) out <- setValues(out, x) return(out) } tr <- blockSize(x) out <- writeStart(out, filename="") x <- readStart(x) pb <- pbCreate(tr$n) if (!is.null(add)) { add <- fun(add, na.rm=na.rm) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- apply(cbind(v, add), 1, FUN=fun, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- apply(v, 1, FUN=fun, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) x <- readStop(x) writeStop(out) } ) raster/R/clump.R0000644000176200001440000000675214160021141013216 0ustar liggesusers# Authors: Robert J. Hijmans and Jacob van Etten, # Date : May 2010 # Version 1.0 # Licence GPL v3 # RH: updated for igraph (from igraph0) # sept 23, 2012 .smallClump <- function(x, directions=8) { x1 <- raster(x) val <- which(getValues(x) != 0) if (length(val) == 0) { return( setValues(x1, NA) ) } adjv <- as.vector(t(adjacent(x1, val, directions=directions, target=val, pairs=TRUE))) # RH. To fix problem of missing single cells, perhaps more efficient than "include=T" in adjacent add <- val[! val %in% adjv] adjv <- c(adjv, rep(add, each=2)) cl <- igraph::clusters(igraph::graph(adjv, directed=FALSE))$membership[val] cl <- as.numeric(as.factor(cl)) # RH force 1 to n x1[val] <- cl return(x1) } setMethod('clump', signature(x='RasterLayer'), function(x, filename='', directions=8, gaps=TRUE, ...) { if( !requireNamespace("igraph")) { stop('you need to install the igraph package to be able to use this function') } if (! directions %in% c(4,8)) { stop('directions should be 4 or 8') } filename <- trim(filename) if (filename != "" & file.exists(filename)) { if (! .overwrite(...)) { stop("file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it") } } datatype <- list(...)$datatype out <- raster(x) if (canProcessInMemory(out, 3)) { x <- .smallClump(x, directions) names(x) <- 'clumps' if (filename != '') { if (is.null(datatype)) { x <- writeRaster(x, filename, datatype='INT4S') } else { x <- writeRaster(x, filename, ...) } } return(x) } # else names(out) <- 'clumps' out <- writeStart(out, filename=rasterTmpFile(), datatype='INT4S') tr <- blockSize(out, minrows=3) pb <- pbCreate(tr$n, label='clump', ...) ext <- c(xmin(out), xmax(out), ymax(out), NA) maxval <- 0 rcl <- matrix(nrow=0, ncol=2) for (i in 1:tr$n) { ext[4] <- yFromRow(out, tr$row[i]) + 0.5 * yres(out) endrow <- tr$row[i] + tr$nrows[i] - 1 ext[3] <- yFromRow(out, endrow) - 1.5 * yres(out) # one additional row for overlap xc <- crop(x, extent(ext)) xc <- .smallClump(xc, directions) + maxval if (i > 1) { firstrow <- getValues(xc, 1) rc <- stats::na.omit(unique(cbind(lastrow, firstrow))) rcl <- rbind(rcl, rc) } lastrow <- getValues(xc, nrow(xc)) mv <- maxValue(xc) if (!is.na(mv)) { maxval <- mv } out <- writeValues(out, getValues(xc, 1, tr$nrows[i]), tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) if (nrow(rcl) > 0) { g <- igraph::graph.edgelist(rcl, directed=FALSE) clumps <- igraph::clusters(g)$membership rc <- cbind(igraph::V(g), clumps) i <- rc[,1] != rc[,2] rc <- rc[i, ,drop=FALSE] if (is.null(datatype)) { out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) } else { out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, ...) } return(out) } else if (!gaps) { un <- unique(out) un <- data.frame(cbind(un, clumps=1:length(un))) if (is.null(datatype)) { return( subs(out, un, subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) ) } else { return( subs(out, un, subsWithNA=FALSE, filename=filename, ...) ) } } else if (filename != '') { if (is.null(datatype)) { return( writeRaster(out, filename=filename, datatype='INT4S', ...) ) } else { return( writeRaster(out, filename=filename, ...) ) } } else { return(out) } } ) raster/R/trim.R0000644000176200001440000000645314160021141013047 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 1.0 # Licence GPL v3 setMethod("trim", signature(x="character"), function(x, internal=FALSE, ...) { if (internal) { gsub("^ *|(?<= ) | *$", "", x, perl=TRUE) } else { gsub("^\\s+|\\s+$", "", x) } } ) setMethod("trim", signature(x="data.frame"), function(x, ...) { for (i in 1:ncol(x)) { if (class(x[,i]) == "character") { x[,i] <- trim(x[,i]) } else if (class(x[,i]) == "factor") { x[,i] <- as.factor(trim(as.character(x[,i]))) } } return(x) } ) setMethod("trim", signature(x="matrix"), function(x, ...) { if (is.character(x)) { x[] = trim(as.vector(x)) } else { rows <- rowSums(is.na(x)) cols <- colSums(is.na(x)) rows <- which(rows != ncol(x)) cols <- which(cols != nrow(x)) if (length(rows)==0) { x <- matrix(ncol=0, nrow=0) } else { x <- x[min(rows):max(rows), min(cols):max(cols), drop=FALSE] } } return(x) } ) # June 2013, modification by Mike Sumner, added argument "value" .memtrimlayer <- function(r, padding=0, values=NA, filename="", ...) { x <- as.matrix(r) if (all(is.na(values))) { rows <- rowSums(is.na(x)) cols <- colSums(is.na(x)) } else { rows <- apply(x, 1, function(i) sum(i %in% values)) cols <- apply(x, 2, function(i) sum(i %in% values)) } rows <- which(rows != ncol(x)) if (length(rows)==0) { stop("only NA values found") } cols <- which(cols != nrow(x)) rows <- pmin(pmax(1, c(min(rows) - padding, max(rows + padding))), nrow(r)) cols <- pmin(pmax(1, c(min(cols) - padding, max(cols + padding))), ncol(r)) e <- extent(r, rows[1], rows[2], cols[1], cols[2]) crop(r, e, filename=filename, ...) } setMethod("trim", signature(x="Raster"), function(x, padding=0, values=NA, filename="", ...) { filename <- trim(filename) if (!hasValues(x)) { stop("The Raster object has no values") } if (nlayers(x) == 1 && canProcessInMemory(x)) { x <- .memtrimlayer(x, padding=padding, values=values, ...) if (filename != "") { x <- writeRaster(x, filename, ...) } return(x) } nr <- nrow(x) nc <- ncol(x) nrl <- nr * nlayers(x) ncl <- nc * nlayers(x) cnt <- 0 for (r in 1:nr) { v <- getValues(x, r) if (sum(v %in% values) < ncl) { break } cnt <- cnt + 1 } if ( cnt == nr) { stop("only NA values found") } firstrow <- min(max(r-padding, 1), nr) for (r in nr:firstrow) { v <- getValues(x, r) if (sum(v %in% values) < ncl) { break } } lastrow <- max(min(r+padding, nr), 1) if (lastrow < firstrow) { tmp <- firstrow firstrow <- lastrow lastrow <- tmp } for (c in 1:nc) { v <- getValuesBlock(x, 1 ,nrow(x), c, 1) if (sum(v %in% values) < nrl) { break } } firstcol <- min(max(c-padding, 1), nc) for (c in nc:firstcol) { v <- getValuesBlock(x, 1 ,nrow(x), c, 1) if (sum(v %in% values) < nrl) { break } } lastcol <- max(min(c+padding, nc), 1) if (lastcol < firstcol) { tmp <- firstcol firstcol <- lastcol lastcol <- tmp } xr <- xres(x) yr <- yres(x) e <- extent(xFromCol(x, firstcol)-0.5*xr, xFromCol(x, lastcol)+0.5*xr, yFromRow(x, lastrow)-0.5*yr, yFromRow(x, firstrow)+0.5*yr) return( crop(x, e, filename=filename, ...) ) } ) raster/R/text.R0000644000176200001440000000541614160021141013056 0ustar liggesusers# Author: Robert J. Hijmans # Date : August 2010 # Version 0.9 # Licence GPL v3 .haloText <- function(x, y=NULL, labels, col='black', hc='white', hw=0.1, ... ) { # with minor modifications from #From: Greg Snow imail.org> #Subject: Re: Text Contrast in a Plot #Newsgroups: gmane.comp.lang.r.general #Date: 2009-04-24 21:23:25 GMT xy <- grDevices::xy.coords(x,y) xo <- hw * graphics::strwidth('A') yo <- hw * graphics::strheight('A') theta <- seq(pi/4, 2*pi, length.out=8*hw*10) for (i in theta) { text( xy$x + cos(i)*xo, xy$y + sin(i)*yo, labels, col=hc, ... ) } text(xy$x, xy$y, labels, col=col, ... ) } setMethod('text', signature(x='RasterLayer'), function(x, labels, digits=0, fun=NULL, halo=FALSE, ...) { x <- rasterToPoints(x, fun=fun, spatial=FALSE) if (missing(labels)) { if (NCOL(x) > 2) { labels <- as.character(round(x[,3], digits=digits) ) } else { labels <- 1:NROW(x) } } if (halo) { .haloText(x[,1], x[,2], labels, ...) } else { text(x[,1], x[,2], labels, ...) } } ) setMethod('text', signature(x='RasterStackBrick'), function(x, labels, digits=0, fun=NULL, halo=FALSE, ...) { if (missing(labels)) { labels <- 1 } if (length(labels) != ncell(x)) { labels <- labels[1] if (is.character(labels)) { i <- which(labels == names(x)) if (i == 0) { i <- 1 } } x <- x[[labels]] x <- rasterToPoints(x, fun=fun, spatial=FALSE) labels <- as.character(round(x[,3], digits=digits) ) } if (halo) { .haloText(x[,1], x[,2], labels, ...) } else { text(x[,1], x[,2], labels, ...) } } ) setMethod('text', signature(x='SpatialPolygons'), function(x, labels, halo=FALSE, ...) { if (missing(labels)) { labels <- 1 } if (length(labels) == 1) { if (.hasSlot(x, 'data')) { if (labels %in% names(x)) { labels <- x@data[, labels] } } else { if (length(x)> 1) { labels <- 1:length(x) } } labels <- as.character(labels) } xy <- sp::coordinates(x)[,1:2,drop=FALSE] if (halo) { .haloText(xy[,1], xy[,2], labels, ...) } else { text(xy[,1], xy[,2], labels, ...) } } ) setMethod('text', signature(x='SpatialPoints'), function(x, labels, halo=FALSE, ...) { if (missing(labels)) { labels <- 1 } if (length(labels) == 1) { if (.hasSlot(x, 'data')) { if (labels %in% names(x)) { labels <- x@data[, labels] } } else { if (length(x)> 1) { labels <- 1:length(x) } } labels <- as.character(labels) } xy <- sp::coordinates(x)[,1:2,drop=FALSE] if (halo) { .haloText(xy[,1], xy[,2], labels, ...) } else { text(xy[,1], xy[,2], labels, ...) } } ) raster/R/rasterFromIDRISI.R0000644000176200001440000000502514160021141015116 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromIDRISIFile <- function(filename, crs="", old=FALSE, ...) { if (old) { idformat <- 'IDRISIold' } else { idformat <- 'IDRISI' } valuesfile <- .setFileExtensionValues(filename, idformat) if (!file.exists(valuesfile )){ stop( paste(valuesfile, "does not exist")) } filename <- .setFileExtensionHeader(filename, idformat) ini <- readIniFile(filename, token=':') ini[,2] = toupper(ini[,2]) byteorder <- .Platform$endian nodataval <- -Inf layernames <- '' filetype <- '' for (i in 1:length(ini[,1])) { if (ini[i,2] == "MIN. X") {xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAX. X") {xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MIN. Y") {yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAX. Y") {yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MIN. VALUE") { minval <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAX. VALUE") { maxval <- as.numeric(ini[i,3]) } else if (ini[i,2] == "VALUE UNITS") { valunit <- ini[i,3] } else if (ini[i,2] == "ROWS") {nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "COLUMNS") {nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "DATA TYPE") {inidatatype <- toupper(ini[i,3]) } else if (ini[i,2] == "FILE TYPE") {filetype <- toupper(ini[i,3]) } else if (ini[i,2] == "FILE TITLE") {layernames <- ini[i,3] } else if (ini[i,2] == "FLAG VALUE") { suppressWarnings(nodataval <- try(as.numeric(ini[i,3], silent=TRUE))) if (!is.numeric(nodataval)) {nodataval <- -Inf} } } if (filetype=='PACKED BINARY') { stop('cannot natively read packed binary files, read via rgdal?') } # attempt could be made to decipher some of the idrisi crs descriptions x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) if (nchar(layernames) > 1) { # lnams <- unlist(strsplit(layernames, ':')) lnams <- layernames } else { lnams <- gsub(" ", "_", extension(basename(filename), "")) } names(x) <- lnams x@file@name <- filename x@data@min <- minval x@data@max <- maxval x@data@haveminmax <- TRUE if (inidatatype == 'BYTE') { dataType(x) <- 'INT1U' } else if (inidatatype == 'INTEGER') { dataType(x) <- 'INT2S' } else if (inidatatype == 'REAL') { dataType(x) <- 'FLT4S' } else { stop(paste('unsupported IDRISI data type:', inidatatype)) } x@file@nodatavalue <- nodataval x@data@fromdisk <- TRUE x@file@driver <- idformat return(x) } raster/R/extractExtent.R0000644000176200001440000000331414160021141014727 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='Extent'), function(x, y, cellnumbers=FALSE, fun=NULL, na.rm=FALSE, layer=1, nl, df=FALSE, ...) { e <- intersect(extent(x), y) e <- alignExtent(e, x) if (!is.null(fun)) { cellnumbers <- FALSE } else if (cellnumbers) { cell <- cellsFromExtent(x, e) value <- extract(x, cell, layer=layer, nl=nl, df=df) if (df) { value <- data.frame(cell=cell, value) } else { value <- cbind(cell=cell, value) } return(value) } r <- res(x) e@xmin <- e@xmin + 0.25 * r[1] e@xmax <- e@xmax - 0.25 * r[1] e@ymin <- e@ymin + 0.25 * r[2] e@ymax <- e@ymax - 0.25 * r[2] row <- rowFromY(x, e@ymax) lastrow <- rowFromY(x, e@ymin) nrows <- lastrow-row+1 col <- colFromX(x, e@xmin) lastcol <- colFromX(x, e@xmax) ncols <- lastcol-col+1 v <- getValuesBlock(x, row, nrows, col, ncols) if (nlayers(x) > 1) { if (missing(layer)) { layer <- 1 } else { layer <- max(min(nlayers(x), layer), 1) } if (missing(nl)) { nl <- nlayers(x) - layer + 1 } else { nl <- max(min(nlayers(x)-layer+1, nl), 1) } lyrs <- layer:(layer+nl-1) v <- v[ , lyrs, drop=FALSE] } else { lyrs <- 1 } if (! is.null(fun)) { if (is.matrix(v)) { ln <- colnames(v) v <- apply(v, 2, FUN=fun, na.rm=na.rm) names(v) <- ln } else { v <- fun(v, na.rm=na.rm) } } if (df) { v <- data.frame(v) if (ncol(v) == 1) { v <- data.frame(factorValues(x, v, lyrs)) } else { v <- .insertFacts(x, v, lyrs) } } return(v) } ) raster/R/notused.R0000644000176200001440000000232514160021141013547 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 # Not used .writeRasterAssign <- function(x, filename, ...) { name <- deparse(substitute(x)) x <- writeRaster(x, filename, ...) assign(name, x, envir=parent.frame()) return(invisible()) } .writeSparse <- function(raster, filename, overwrite=FALSE) { # raster@file@driver <- 'raster' if (!overwrite & file.exists(filename)) { stop(filename, "exists. Use 'overwrite=TRUE' if you want to overwrite it") } raster@data@values[is.nan(raster@data@values)] <- NA dtype <- .shortDataType(raster@data@datanotation) if (dtype == "integer") { raster@data@values <- as.integer(raster@data@values) } if (class(raster@data@values)=='integer') { dataType(raster) <- 'INT4S' } raster <- setMinMax(raster) binraster <- .setFileExtensionValues(raster@file@name, 'raster') raster <- readStart(raster) writeBin( as.vector(raster@data@indices), raster@file@con, size = as.integer(4)) writeBin( as.vector(raster@data@values), raster@file@con, size = dataSize(raster@file@datanotation) ) raster <- readStop(raster) # add the 'sparse' key word to the hdr file!!! hdr(raster) return(raster) } raster/R/project.R0000644000176200001440000000277214160021230013541 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2014 # Version 1.0 # Licence GPL v3 .proj4string <- function(x) { if (inherits(x, "Spatial")) { suppressWarnings(sp::proj4string(x)) } else { x@crs@projargs } } .CRS <- function(...) { suppressWarnings(sp::CRS(...)) } if (!isGeneric(".project")) { setGeneric(".project", function(x, ...) standardGeneric(".project")) } setMethod('.project', signature(x='Raster'), function(x, to=NULL, res=NULL, crs=NULL, method="bilinear", alignOnly=FALSE, over=FALSE, filename="", ...) { projectRaster(x, to=to, res=res, crs=crs, method=method, alignOnly=alignOnly, over=over, filename=filename, ...) } ) setMethod('.project', signature(x='SpatialGrid'), function(x, ...) { y <- brick(x) .requireRgdal() dots <- list(...) if (!is.null(dots$CRSobj) & is.null(dots$crs)) { y <- projectRaster(y, crs=dots$CRSobj, ...) } else { y <- projectRaster(y, ...) } as(y, class(x)) } ) setMethod('.project', signature(x='SpatialPixels'), function(x, ...) { y <- brick(x) .requireRgdal() dots <- list(...) if (!is.null(dots$CRSobj) & is.null(dots$crs)) { y <- projectRaster(y, crs=dots$CRSobj, ...) } else { y <- projectRaster(y, ...) } as(y, class(x)) } ) setMethod('.project', signature(x='Spatial'), function(x, crs, ...) { .requireRgdal() if (!is.null(list(...)$CRSobj)) { crs <- list(...)$CRSobj } sp::spTransform(x, CRSobj=crs(crs), ...) } ) raster/R/init.R0000644000176200001440000000624714160021141013040 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod("init", signature(x="Raster"), function(x, fun='cell', filename="", ...) { vv <- list(...)$v v <- NULL if (!is.null(vv)) { if (vv %in% c('x', 'y', 'row', 'col', 'cell', 'chess')) { v <- vv } } else if (is.character(fun) ) { fun <- tolower(fun[1]) if (fun %in% c('x', 'y', 'row', 'col', 'cell', 'chess')) { v <- fun } else { stop("argument 'fun' is a character variable, but not one of 'x', 'y', 'row', 'col', 'cell', or 'chess'") } } else if (is.numeric(fun)) { value <- fun fun <- function(...) value } out <- raster(x) filename <- trim(filename) inmem=TRUE if (!canProcessInMemory(out, 2)) { inmem=FALSE if (filename == '') { filename <- rasterTmpFile() } } if (!is.null(v)) { if ( inmem ) { if (v == 'cell') { out <- setValues(out, 1:ncell(out)) } else if (v == 'row') { out <- setValues(out, rep(1:nrow(out), each=ncol(out))) } else if (v == 'y') { out <- setValues(out, rep(yFromRow(out, 1:nrow(out)), each=ncol(out))) } else if (v == 'col') { out <- setValues(out, rep(1:ncol(out), times=nrow(out))) } else if (v == 'x') { out <- setValues(out, rep(xFromCol(out, 1:ncol(out)), times=nrow(out))) } else if (v == 'chess') { if ((ncol(out) %% 2) == 1) { out <- setValues(out, c(rep(c(0,1), floor(ncell(out)/2)), 0)) } else { rs <- c(rep(c(0,1), ncol(out) / 2), rep(c(1,0), ncol(out) / 2)) rs <- rep(rs, floor(nrow(out) / 2)) if ((nrow(out) %% 2) == 1) { rs <- c(rs, rep(c(0,1), ncol(out) / 2)) } out <- setValues(out, rs) } } } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='init', ...) for (i in 1:tr$n) { if (v == 'cell') { out <- writeValues(out, cellFromRowCol(out, tr$row[i],1):cellFromRowCol(out, tr$row[i]+tr$nrows[i]-1, ncol(out)), tr$row[i]) } else if (v == 'row') { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) out <- writeValues(out, rep(r, each=ncol(out)), tr$row[i]) } else if (v == 'col') { out <- writeValues(out, rep(1:ncol(out), tr$nrows[i]), tr$row[i]) } else if (v == 'x') { out <- writeValues(out, rep(xFromCol(out, 1:ncol(out)), tr$nrows[i]), tr$row[i]) } else if (v == 'y') { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) out <- writeValues(out, rep(yFromRow(out, r), each=ncol(out)), tr$row[i]) } else if (v == 'chess') { stop('not implemented for large files yet') } pbStep(pb, i) } pbClose(pb) out <- writeStop(out) } } else { if ( inmem ) { n <- ncell(out) out <- setValues(out, fun(n)) } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='init', ...) for (i in 1:tr$n) { n <- ncol(out) * tr$nrows[i] out <- writeValues(out, fun(n), tr$row[i]) pbStep(pb, r) } pbClose(pb) out <- writeStop(out) } } if (inmem & filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } ) raster/R/corLocal.R0000644000176200001440000001101514160021141013620 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 setMethod('corLocal', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ngb=5, method = c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) { compareRaster(x,y) if (test) { out <- brick(x, values=FALSE, nl=2) names(out) <- c(method[1], 'p-value') } else { out <- raster(x) names(out) <- c(method[1]) } if (canProcessInMemory(x, n=2*ngb)) { vx <- getValuesFocal(x, 1, nrow(x), ngb=ngb) vy <- getValuesFocal(y, 1, nrow(y), ngb=ngb) if (test) { v <- matrix(NA, ncol=2, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[i, ] <- c(a$estimate, a$p.value) } } } else { v <- rep(NA, ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { v[i] <- stats::cor(z[,1], z[,2], method=method) } } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='corLocal', ...) out <- writeStart(out, filename=filename, ...) if (test) { for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- matrix(NA, ncol=2, nrow=nrow(vx)) for (j in 1:nrow(vx)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[j, ] <- c(a$estimate, a$p.value) } } out <- writeValues(out, v, tr$row[i]) } } else { for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- rep(NA, nrow(vx)) for (j in 1:length(v)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { v[j] <- stats::cor(z[,1], z[,2], method=method) } } out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } ) setMethod('corLocal', signature(x='RasterStackBrick', y='RasterStackBrick'), function(x, y, method = c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) { compareRaster(x,y) nl1 <- nlayers(x) nl2 <- nlayers(y) if (nl1 != nl2) { stop('nlayers does not match') } if (nl1 < 3) { stop('number of layers should be > 2') } if (test) { out <- brick(x, values=FALSE, nl=2) names(out) <- c(method[1], 'p-value') } else { out <- raster(x) names(out) <- c(method[1]) } if (canProcessInMemory(x)) { vx <- getValues(x) vy <- getValues(y) if (test) { v <- matrix(NA, ncol=2, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[i, ] <- c(a$estimate, a$p.value) } } } else { v <- rep(NA, ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { v[i] <- stats::cor(z[,1], z[,2], method=method) } } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='corLocal', ...) out <- writeStart(out, filename=filename, ...) if (test) { for (i in 1:tr$n) { vx <- getValues(x, tr$row[i], tr$nrows[i]) vy <- getValues(y, tr$row[i], tr$nrows[i]) v <- matrix(NA, ncol=2, nrow=nrow(vx)) for (j in 1:nrow(vx)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[j, ] <- c(a$estimate, a$p.value) } } out <- writeValues(out, v, tr$row[i]) } } else { for (i in 1:tr$n) { vx <- getValues(x, tr$row[i], tr$nrows[i]) vy <- getValues(y, tr$row[i], tr$nrows[i]) v <- rep(NA, nrow(vx)) for (j in 1:length(v)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { v[j] <- stats::cor(z[,1], z[,2], method=method) } } out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } ) raster/R/nlayers.R0000644000176200001440000000142714160021141013545 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("nlayers")) { setGeneric("nlayers", function(x) standardGeneric("nlayers")) } setMethod('nlayers', signature(x='BasicRaster'), function(x){ return(0) } ) setMethod('nlayers', signature(x='Raster'), function(x){ return(1) } ) setMethod('nlayers', signature(x='RasterStack'), function(x){ as.integer( sum(unlist( sapply(x@layers, nlayers) ) ) ) } ) setMethod('nlayers', signature(x='RasterBrick'), function(x){ return(x@data@nlayers) } ) setMethod('nlayers', signature(x='Spatial'), function(x){ if (! is.null( attr(x, 'data') ) ) { return( dim(x@data)[2] ) } else { return( 0 ) } } ) raster/R/frbind.R0000644000176200001440000000272414160021141013335 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 # friendly rbind # rbinds data.frames with different column names .frbind <- function(x, ...) { if (! inherits(x, 'data.frame') ) { x <- data.frame(x) } d <- list(...) if (length(d) == 0) { return(x) } for (i in 1:length(d)) { dd <- d[[i]] if (! inherits(dd, 'data.frame')) { dd <- data.frame(dd) } cnx <- colnames(x) cnd <- colnames(dd) e <- cnx[(cnx %in% cnd)] for (j in e) { if (class(x[,j]) != class(dd[,j])) { x[,j] <- as.character(x[,j]) dd[,j] <- as.character(dd[,j]) } } a <- which(!cnd %in% cnx) if (length(a) > 0) { zz <- dd[NULL, a, drop=FALSE] zz[1:nrow(x),] <- NA x <- cbind(x, zz) } b <- which(!cnx %in% cnd) if (length(b) > 0) { zz <- x[NULL, b, drop=FALSE] zz[1:nrow(dd),] <- NA dd <- cbind(dd, zz) } x <- rbind(x, dd) } x } .frbindMatrix <- function(x, ...) { d <- list(...) if (length(d) == 0) { return(x) } for (i in 1:length(d)) { dd <- d[[i]] cnx <- colnames(x) cnd <- colnames(dd) a <- which(!cnd %in% cnx) if (length(a) > 0) { zz <- dd[NULL, a, drop=FALSE] zz[1:nrow(x),] <- NA x <- cbind(x, zz) } b <- which(!cnx %in% cnd) if (length(b) > 0) { zz <- x[NULL, b, drop=FALSE] zz[1:nrow(dd),] <- NA dd <- cbind(dd, zz) } x <- rbind(x, dd) } x } raster/R/unique.R0000644000176200001440000000405314160021141013374 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 setMethod('unique', signature(x='RasterLayer', incomparables='missing'), function(x, incomparables=FALSE, na.last=NA, progress="", ...) { if (! inMemory(x) ) { if ( fromDisk(x) ) { if (canProcessInMemory(x, 2)) { x <- readAll(x) } } else { stop('RasterLayer has no values') } } if ( inMemory(x) ) { x <- unique(x@data@values, incomparables=incomparables, progress="", ...) return(sort(x, na.last=na.last)) } else { u1 <- vector() u2 <- vector() tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='unique', progress=progress, ...) for (i in 1:tr$n) { u1 <- unique( c(u1, getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i])), incomparables=incomparables, ... ) if (length(u1) > 10000 ) { u2 <- unique(c(u1, u2), incomparables=incomparables, ...) u1 <- vector() } pbStep(pb, i) } pbClose(pb) return(sort(unique(c(u1, u2), incomparables=incomparables, ...), na.last=na.last)) } } ) setMethod('unique', signature(x='RasterStackBrick', incomparables='missing'), function(x, incomparables=FALSE, na.last=NA, progress="", ...) { if (! inMemory(x) ) { if (canProcessInMemory(x, 2)) { x <- readAll(x) } } if ( inMemory(x) ) { x <- unique(getValues(x), incomparables=incomparables, ...) # if (is.list(x)) { # for (i in 1:length(x)) { # x[[i]] <- sort(x[[i]], na.last=na.last) # } # } else { # xx <- vector(length=ncol(x), mode='list') # for (i in 1:ncol(x)) { # xx[[i]] <- sort(x[,i], na.last=na.last) # } # x <- xx # } return(x) } else { nl <- nlayers(x) un <- list(length=nl, mode='list') tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='unique', progress=progress) un <- NULL for (i in 1:tr$n) { v <- unique( getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) un <- unique(rbind(v, un), incomparables=incomparables, ...) pbStep(pb, i) } pbClose(pb) return(un) } } ) raster/R/median.R0000644000176200001440000000342114160021141013321 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 setMethod(".median", signature(x='Raster'), function(x, na.rm=FALSE, ...){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- unlist(.addArgs(...)) } else { add <- NULL } out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (nlayers(x) == 1) { return(.deepCopyRasterLayer(x)) } if (canProcessInMemory(x)) { x <- getValues(x) x <- setValues(out, apply(x, 1, median, na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='median') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- apply(v, 1, median, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { d3 <- d[3] + length(add) if (canProcessInMemory(x)) { if (length(add) == 1) { x <- cbind(getValues(x), add) } else { x <- getValues(x) x <- t(apply(x, 1, function(i) c(i, add))) } x <- setValues(out, apply(x, 1, median, na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='median') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- t(apply(v, 1, function(i) c(i, add))) v <- apply(v, 1, median, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } ) raster/R/gainoffset.R0000644000176200001440000000232414160021141014212 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2010 # Version 1.0 # Licence GPL v3 'gain<-' <- function(x, value) { value <- as.numeric(value[1]) if (inherits(x, 'RasterStack')) { x@layers <- lapply( x@layers, function(z) { if (fromDisk(x)) { z@data@gain <- value } else { z <- z * value } return(z) } ) } else { if (fromDisk(x)) { x@data@gain <- value } else { x <- x * value } } return(x) } gain <- function(x) { if (inherits(x, 'RasterStack')) { r <- sapply( x@layers, function(z) { z@data@gain } ) } else { r <- x@data@gain } return(r) } 'offs<-' <- function(x, value) { value <- as.numeric(value[1]) if (inherits(x, 'RasterStack')) { x@layers <- lapply( x@layers, function(z) { if (fromDisk(z)) { z@data@offset <- value } else { z <- z + value } return(z) } ) } else { if (fromDisk(x)) { x@data@offset <- value } else { x <- x + value } } return(x) } offs <- function(x) { if (inherits(x, 'RasterStack')) { r <- sapply( x@layers, function(z) { z@data@offset } ) } else { r <- x@data@offset } return(r) } raster/R/getValuesBlock.R0000644000176200001440000001024314160021141014776 0ustar liggesusers # Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("getValuesBlock")) { setGeneric("getValuesBlock", function(x, ...) standardGeneric("getValuesBlock")) } setMethod('getValuesBlock', signature(x='RasterStack'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) { stopifnot(hasValues(x)) stopifnot(row <= x@nrows) stopifnot(col <= x@ncols) stopifnot(nrows > 0) stopifnot(ncols > 0) row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 nlyrs <- nlayers(x) if (missing(lyrs)) { lyrs <- 1:nlyrs } else { lyrs <- lyrs[lyrs %in% 1:nlyrs] if (length(lyrs) == 0) { stop("no valid layers selected") } nlyrs <- length(lyrs) x <- x[[lyrs, drop=FALSE]] } startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) nc <- ncol(x) res <- matrix(ncol=nlyrs, nrow=nrows * ncols) inmem <- sapply(x@layers, function(x) x@data@inmemory) if (any(inmem)) { if (col==1 & ncols==nc) { cells <- startcell:lastcell } cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol) } for (i in 1:nlyrs) { xx <- x@layers[[i]] if ( inMemory(xx) ) { res[,i] <- xx@data@values[cells] } else { res[,i] <- .readRasterLayerValues(xx, row, nrows, col, ncols) } } colnames(res) <- names(x) res } ) setMethod('getValuesBlock', signature(x='RasterBrick'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) { stopifnot(hasValues(x)) row <- max(1, round(row)) col <- max(1, round(col)) stopifnot(row <= x@nrows) stopifnot(col <= x@ncols) nrows <- min(round(nrows), x@nrows-row+1) ncols <- min((x@ncols-col+1), round(ncols)) stopifnot(nrows > 0) stopifnot(ncols > 0) nlyrs <- nlayers(x) if (missing(lyrs)) { lyrs <- 1:nlyrs } else { lyrs <- lyrs[lyrs %in% 1:nlyrs] if (length(lyrs) == 0) { stop("no valid layers") } nlyrs <- length(lyrs) } if ( inMemory(x) ){ lastrow <- row + nrows - 1 if (col==1 & ncols==x@ncols) { rnge <- cellFromRowCol(x, c(row, lastrow), c(1, ncol(x))) res <- x@data@values[rnge[1]:rnge[2], , drop=FALSE] } else { lastcol <- col + ncols - 1 res <- x@data@values[cellFromRowColCombine(x, row:lastrow, col:lastcol), , drop=FALSE] } if (NCOL(res) > nlyrs) { res <- res[, lyrs, drop=FALSE] } colnames(res) <- names(x)[lyrs] } else if ( fromDisk(x) ) { res <- .readRasterBrickValues(x, row, nrows, col, ncols) if (NCOL(res) > nlyrs) { res <- res[, lyrs, drop=FALSE] } } else { # no data res <- ( matrix(rep(NA, nrows * ncols * nlyrs), ncol=nlyrs) ) colnames(res) <- names(x)[lyrs] } return(res) } ) setMethod('getValuesBlock', signature(x='RasterLayer'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), format='', ...) { row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) if (!(validRow(x, row))) { stop(paste(row, 'is not a valid rownumber')) } if ( inMemory(x) ) { if (col==1 & ncols==ncol(x)) { res <- x@data@values[startcell:lastcell] } else { cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol) res <- x@data@values[cells] } } else if ( fromDisk(x)) { res <- .readRasterLayerValues(x, row, nrows, col, ncols) } else { # no values res <- rep(NA, nrows * ncols) } if (format=='m') { res <- matrix(res) } else if (format=='matrix') { res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE ) colnames(res) <- col:lastcol rownames(res) <- row:lastrow } res } ) raster/R/labels.R0000644000176200001440000000154214160021141013330 0ustar liggesusers .polygonLabelPosition <- function(x, cex=1) { xy <- sp::coordinates(x) # make sure that labels are inside of polygons sx <- sp::geometry(x) k <- extract(sx, xy) k <- which(k[,1] != k[,2]) if (length(k) > 0) { for (i in k) { pol <- sx[i, ] e <- extent(pol) p1 <- xy[i, ,drop=FALSE] dx <- 0.25 * (e@xmax - e@xmin) dy <- 0.25 * (e@ymax - e@ymin) fixed <- FALSE for (j in 1:4) { if (j < 3) { p[1,1] <- p1[1,1] - dx } else { p[1,1] <- p1[1,1] + dx } if (j %in% c(2,3)) { p[1,2] <- p1[1,2] - dy } else { p[1,2] <- p1[1,2] + dy } z <- extract(pol, rbind(p,p)) if (!is.na(z[1,2])) { xy[i, ] <- p break fixed <- TRUE } } if (!fixed) print(paste(i, 'not fixed')) } } # make sure that labels do not overlap? xy } raster/R/addLayer.R0000644000176200001440000000234114160021141013611 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("addLayer")) { setGeneric("addLayer", function(x, ...) standardGeneric("addLayer")) } setMethod('addLayer', signature(x='Raster'), function(x, ...) { rasters <- .makeRasterList(...) if (! inherits(x, 'RasterStack')) { x <- stack(x) } if (length(rasters)==0) { return(x) } if (nlayers(x) > 0) { compareRaster(c(x, rasters)) } else if (length(rasters) > 1) { compareRaster(rasters) } vals <- sapply(rasters, hasValues) if (sum(vals) == 0 & nlayers(x) == 0) { vals[1] <- TRUE } if (sum(vals) != length(vals)) { warning('Cannot add a RasterLayer with no associated data in memory or on disk to a RasterStack') } rasters <- rasters[vals] if (nlayers(x) == 0) { r <- rasters[[1]] x@nrows <- r@nrows x@ncols <- r@ncols x@extent <- r@extent crs(x) <- .getCRS(r) if (rotated(r)) { x@rotated = r@rotated x@rotation = r@rotation } nl <- 1 x@layers[[nl]] <- r rasters <- rasters[-1] if (length(rasters)==0) { return(x) } } x@layers <- c(x@layers, rasters) names(x) <- sapply(x@layers, names) return(x) } ) raster/R/setZ.R0000644000176200001440000000063314160021141013013 0ustar liggesusers# Robert J. Hijmans # June 2011 # Version 1.0 # Licence GPL v3 setZ <- function(x, z, name='time') { if (is.null(z)) { x@z <- list() return(x) } if (is.list(z)) { z <- unlist(z) } stopifnot(length(z) == nlayers(x)) z <- list(z) names(z) <- name[1] x@z <- z x } getZ <- function(x) { if (length(x@z) == 0) { return(NULL) } else { return(x@z[[1]]) } } raster/R/dataType.R0000644000176200001440000000612014160021141013636 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 'dataType<-' <- function(x, value) { if (inherits(x, 'RasterStack')) { stop('Cannot set datatype of a RasterStack') } # for backward compatibility issues and non fatal mistakes. datatype <- substr( toupper( trim(value) ), 1, 5) if (datatype == 'LOGIC') {datatype <- 'LOG1S' } else if (datatype == 'BYTE') {datatype <- 'INT1U' } else if (datatype == 'SMALL') {datatype <- 'INT2S' } else if (datatype == 'INTEG') {datatype <- 'INT2S' } else if (datatype == 'NUMER') {datatype <- 'FLT4S' } else if (datatype == 'FLOAT') {datatype <- 'FLT4S' } else if (datatype == 'DOUBL') {datatype <- 'FLT8S' } else if (datatype == 'SINGL') {datatype <- 'FLT4S' } else if (datatype == 'REAL') {datatype <- 'FLT4S'} if (nchar(datatype) < 3) { stop(paste('invalid datatype:', datatype)) } else if (nchar(datatype) == 3) { if (datatype == 'LOG') { datatype <- paste(datatype, '1S', sep='') } else { datatype <- paste(datatype, '4S', sep='') } } else if (nchar(datatype) == 4) { if (datatype == 'INT1') { datatype <- paste(datatype, 'U', sep='') } else { datatype <- paste(datatype, 'S', sep='') } } # now for real if (!(substr(datatype, 1, 4) %in% c('LOG1', 'INT1', 'INT2', 'INT4', 'FLT4', 'FLT8'))) { stop('not a valid data type') } type <- substr(datatype,1,3) size <- substr(datatype,4,4) signed <- substr(datatype,5,5) != 'U' if (type == "FLT") { # if (dataContent(x) != 'nodata') { # x@data@values[] <- as.numeric(x@data@values) # } if (size == '4') { x@file@datanotation <- 'FLT4S' x@file@nodatavalue <- -3.4E38 } else if (size == '8') { x@file@datanotation <- 'FLT8S' x@file@nodatavalue <- -1.7E308 } else { stop("invalid datasize for a FLT (should be 4 or 8)") } } else if (type == "INT") { # x@data@min <- round(x@data@min) # x@data@max <- round(x@data@max) # if (dataContent(x) != 'nodata') { # x@data@values[] <- as.integer(round(x@data@values)) # } # } if (size == '4') { if (signed) { x@file@datanotation <- 'INT4S' x@file@nodatavalue <- -2147483647 } else { x@file@datanotation <- 'INT4U' x@file@nodatavalue <- 4294967295 } } else if (size == '2') { if (signed) { x@file@datanotation <- 'INT2S' x@file@nodatavalue <- -32768 } else { x@file@datanotation <- 'INT2U' x@file@nodatavalue <- 65535 } } else if (size == '1') { if (signed) { x@file@datanotation <- 'INT1S' x@file@nodatavalue <- as.double(NA) # no default NA value } else { x@file@datanotation <- 'INT1U' x@file@nodatavalue <- as.double(NA) # no default NA value } # } else if (size == '8') { # x@file@nodatavalue <- -9223372036854775808 # x@file@datanotation <- 'INT8S' } else { stop("invalid datasize for this datatype") } } else if ( type == 'LOG' ) { x@file@nodatavalue <- -128 x@file@datanotation <- 'LOG1S' } else { stop("unknown datatype") } return(x) } raster/R/rasterizePointsNGB.R0000644000176200001440000000117214160021141015621 0ustar liggesusers .p2r <- function(p, r=1, x, field, fun, ...) { points <- .pointsToMatrix(p) field <- .getPutVals(p, field, nrow(points), mask=FALSE) x <- raster(x) bf <- .xyvBuf(x, points, r, fun=NULL, na.rm=TRUE, cellnumbers=TRUE, small=TRUE, onlycells=TRUE) bf <- do.call(rbind, bf) bf <- bf[order(bf[,2]), ] field <- data.frame(field, value=1:NROW(field)) bf <- merge(bf, field, by='value') cellvs <- tapply(bf$field, bf[, 'cell', drop=F], fun) cellvs <- cbind(as.numeric(names(cellvs)), do.call(rbind, cellvs)) if (ncol(cellvs) > 2) { x <- brick(x, nl=ncol(cellvs)-1) } x[cellvs[,1]] <- cellvs[,-1] x } raster/R/distance.R0000644000176200001440000000503714160021141013663 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('distance', signature(x='RasterLayer', y='missing'), function(x, y, filename='', doEdge=TRUE, ...) { if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (inherits(pts, "try-error")) { return( .distanceRows(x, filename=filename, ...) ) } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a distance)') } out <- raster(x) filename <- trim(filename) if (couldBeLonLat(x)) { longlat=TRUE } else { longlat=FALSE } if (canProcessInMemory(out, 6)) { pb <- pbCreate(3, label='distance', ...) x <- values(x) i <- which(is.na(x)) if (length(i) < 1) { stop('raster has no NA values to compute distance to') } pbStep(pb) x[] <- 0 xy <- xyFromCell(out, i) x[i] <- .Call('_raster_distanceToNearestPoint', xy, pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') pbStep(pb) out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='distance', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- 0 if (length(j) > 0) { vals[j] <- .Call('_raster_distanceToNearestPoint', xy[j,,drop=FALSE], pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') } out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) setMethod('distance', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ...) { stats::dist(as.matrix(stack(x, y))) } ) setMethod('distance', signature(x='Spatial', y='Spatial'), function(x, y, ...) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) stopifnot(inherits(x, 'SpatialVector')) stopifnot(inherits(y, 'SpatialVector')) d <- rgeos::gDistance(x, y, byid=TRUE) apply(d, 1, min) } ) raster/R/dim.R0000644000176200001440000000346014160021141012640 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('dim', signature(x='BasicRaster'), function(x){ return(c(nrow(x), ncol(x), 1)) } ) setMethod('dim', signature(x='RasterStackBrick'), function(x){ return(c(nrow(x), ncol(x), nlayers(x))) } ) setMethod('nrow', signature(x='BasicRaster'), function(x){ return(x@nrows)} ) setMethod('ncol', signature(x='BasicRaster'), function(x){ return(x@ncols) } ) setMethod('dim<-', signature(x='BasicRaster'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x)) } value <- as.integer(pmax(round(value[1:2]), c(1,1))) x@nrows <- value[1] x@ncols <- value[2] return(x) } ) setMethod('dim<-', signature(x='RasterLayer'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x)) } else if (length(value) > 2) { value <- value[1:2] } value <- as.integer(pmax(round(value), c(1,1))) if (value[1] != nrow(x) | value[2] != ncol(x)) { x <- clearValues(x) x <- .clearFile(x) x@nrows <- value[1] x@ncols <- value[2] } return(x) } ) setMethod('dim<-', signature(x='RasterBrick'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x), nlayers(x)) } else if (length(value) == 2) { value <- c(value, nlayers(x)) } else if (length(value) > 3) { warning('value should have length 1, 2, or 3. Additional values ignored') value <- value[1:3] } value <- as.integer(pmax(round(value), c(1,1,1))) if (value[1] != nrow(x) | value[2] != ncol(x) | value[3] != nlayers(x)) { x <- clearValues(x) x <- .clearFile(x) x@nrows <- value[1] x@ncols <- value[2] x@data@nlayers <- value[3] } return(x) } ) raster/R/cellStats.R0000644000176200001440000002427514160021141014034 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 / April 2012 # Version 1.0 # Licence GPL v3 .csTextFun <- function(fun) { if (class(fun)[1] != 'character') { if (is.primitive(fun)) { test <- try(deparse(fun)[[1]], silent=TRUE) if (test == '.Primitive(\"sum\")') { fun <- 'sum' } else if (test == '.Primitive(\"min\")') { fun <- 'min' } else if (test == '.Primitive(\"max\")') { fun <- 'max' } } else { f <- paste(deparse(fun), collapse = "\n") if (f == paste(deparse(mean), collapse = "\n")) { fun <- 'mean' } else if (f == paste(deparse(stats::sd), collapse = "\n")) { fun <- 'sd' } else if (f == paste(deparse(range), collapse = "\n")) { fun <- 'range' } } } return(fun) } if (!isGeneric("cellStats")) { setGeneric("cellStats", function(x, stat, ...) standardGeneric("cellStats")) } setMethod('cellStats', signature(x='RasterStackBrick'), function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) { stopifnot(hasValues(x)) makeMat <- FALSE if (nlayers(x) == 1) { makeMat <- TRUE #return( cellStats(raster(x, values=TRUE, stat=stat, ...) ) } stat <- .csTextFun(stat) if (!inMemory(x)) { if (canProcessInMemory(x)) { x <- readAll(x) } } if (inMemory(x) ) { x <- getValues(x) if (makeMat) { x <- matrix(x, ncol=1) } if (class(stat) == 'character') { if (stat == "mean" ) { return( colMeans(x, na.rm=na.rm) ) } else if (stat == "sum" ) { return( colSums(x, na.rm=na.rm) ) } else if (stat == "min" ) { v <- .colMin(x, na.rm=na.rm) names(v) <- names(x) return(v) } else if (stat == "max" ) { v <- .colMax(x, na.rm=na.rm) names(v) <- names(x) return(v) } else if (stat == 'countNA') { warning ("'countNA' is deprecated. Use 'freq(x, value=NA)' instead") return( colSums(is.na(x)) ) } else if (stat == 'sd') { st <- apply(x, 2, stats::sd, na.rm=na.rm) if (! asSample) { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } st <- sqrt(st^2 * ((n-1)/n)) } return(st) } else if (stat == 'rms') { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } if (asSample) { n <- n-1 } # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n)) return( sqrt( apply(x, 2, function(x) sum(x^2))/n ) ) } else if (stat == 'skew') { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } if (asSample) { sdx <- apply(x, 2, stats::sd, na.rm=na.rm) } else { sdx <- apply(x, 2, function(x) sqrt(sum((x-mean(x, na.rm=na.rm))^2, na.rm=na.rm)/n)) } return( colSums(t(t(x) - colMeans(x, na.rm=na.rm))^3, na.rm=na.rm) / (n * sdx^3) ) } } # else return(apply(x, 2, stat, na.rm=na.rm, ...)) } if (class(stat) != 'character') { stop('cannot use this function for large files') } st <- NULL counts <- FALSE if (stat == 'sum') { fun <- sum st <- 0 } else if (stat == 'min') { st <- Inf } else if (stat == 'max') { st <- -Inf } else if (stat == 'range') { fun <- range } else if (stat == 'countNA') { warning ("'countNA' is depracted. Use freq(x, 'value=NA') instead") st <- 0 counts <- TRUE } else if (stat == 'skew') { zmean <- cellStats(x, 'mean') cnt <- 0 d3 <- 0 sumsq <- 0 counts <- TRUE } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') { st <- 0 sumsq <- 0 cnt <- 0 counts <- TRUE } else { stop("invalid 'stat'. Should be 'sum', 'min', 'max', 'sd', 'mean', 'rms', or 'skew'") } tr <- blockSize(x) pb <- pbCreate(tr$n, label='cellStats', ...) for (i in 1:tr$n) { d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (makeMat) { d <- matrix(d, ncol=1) } if (counts) { if (na.rm & stat != 'countNA') { nas <- colSums( is.na(d) ) if (min(nas) == nrow(d)) { next } cells <- nrow(d) - nas } else { if (stat == 'countNA') { nas <- colSums( is.na(d) ) } else { cells <- nrow(d) } } } if (stat=='mean') { st <- colSums(d, na.rm=na.rm) + st cnt <- cnt + cells } else if (stat=='sum') { st <- colSums(d, na.rm=na.rm) + st } else if (stat == 'sd') { st <- colSums(d, na.rm=na.rm) + st cnt <- cnt + cells sumsq <- colSums(d^2, na.rm=na.rm) + sumsq } else if (stat=='countNA') { st <- st + nas } else if (stat=='rms') { sumsq <- colSums(d^2, na.rm=TRUE) + sumsq cnt <- cnt + cells } else if (stat=='skew') { d <- t( t(d) - zmean ) sumsq <- colSums(d^2, na.rm=TRUE) + sumsq d3 <- colSums(d^3, na.rm=TRUE) + d3 cnt <- cnt + cells } else if (stat=='min') { tmp <- .colMin(d, na.rm=na.rm) st <- pmin(st, tmp, na.rm=na.rm) } else if (stat=='max') { tmp <- .colMax(d, na.rm=na.rm) st <- pmax(st, tmp, na.rm=na.rm) } else { # range st <- apply(rbind(d, st), 2, fun, na.rm=na.rm) } pbStep(pb, i) } if (stat == 'sd') { meansq <- (st/cnt)^2 st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1))) if (!asSample) { #st <- sqrt( st^2 * (cnt / (cnt-1))) st <- sqrt( st^2 * ((cnt-1) / cnt)) } } else if (stat == 'mean') { st <- st / cnt } else if (stat == 'rms') { if (asSample) { st <- sqrt(sumsq/(cnt-1)) } else { st <- sqrt(sumsq/cnt) } } else if (stat == 'skew') { if (asSample) { stsd <- sqrt(sumsq/(cnt-1))^3 } else { stsd <- sqrt(sumsq/cnt)^3 } st <- d3 / (cnt*stsd) } else if (stat %in% c('min', 'max')) { names(st) <- names(x) } pbClose(pb) return(st) } ) setMethod('cellStats', signature(x='RasterLayer'), function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) { stopifnot(hasValues(x)) stat <- .csTextFun(stat) if (! inMemory(x) ) { if (canProcessInMemory(x)) { x <- readAll(x) } } if (inMemory(x) ) { x <- getValues(x) if (class(stat) == 'character') { if (stat == "mean" ) { return( mean(x, na.rm=na.rm) ) } else if (stat == "sum" ) { return( sum(as.double(x), na.rm=na.rm ) ) } else if (stat == 'countNA') { return( sum(is.na(x)) ) } else if (stat == "range" ) { return( range(x, na.rm=na.rm) ) } else if (stat == "min" ) { return( min(x, na.rm=na.rm) ) } else if (stat == "max" ) { return( max(x, na.rm=na.rm) ) } else if (stat == "sd" ) { st <- stats::sd(x, na.rm=na.rm) if (! asSample) { if (na.rm) { n <- length(stats::na.omit(x)) } else { n <- length(x) } #st <- sqrt(st^2 * (n/(n-1))) st <- sqrt(st^2 * ((n-1)/n)) } return(st) } else if (stat == 'rms') { if (na.rm) { n <- sum(! is.na(x)) } else { n <- length(x) } if (asSample) { n <- n-1 } # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n)) return( sqrt( sum(x^2)/n ) ) } else if (stat == "skew" ) { if (na.rm) { x <- stats::na.omit(x) } if (asSample) { sdx <- stats::sd(x) } else { sdx <- sqrt(sum((x-mean(x))^2)/(length(x))) } return( sum( (x - mean(x))^3 ) / (length(x) * sdx^3) ) } } else { return( stat(x, na.rm=na.rm) ) } } if (class(stat) != 'character') { stop('cannot use this function for large files') } st <- NULL counts <- FALSE if (stat == 'sum') { fun <- sum st <- 0 } else if (stat == 'min') { fun <- min } else if (stat == 'max') { fun <- max } else if (stat == 'range') { fun <- range } else if (stat == 'countNA') { st <- 0 counts <- TRUE } else if (stat == 'skew') { zmean <- cellStats(x, 'mean') cnt <- 0 sumsq <- 0 d3 <- 0 counts <- TRUE } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') { st <- 0 sumsq <- 0 cnt <- 0 counts <- TRUE } else { stop("invalid 'stat'. Should be sum, min, max, sd, mean, or 'countNA'") } tr <- blockSize(x) pb <- pbCreate(tr$n, label='cellStats', ...) for (i in 1:tr$n) { d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (counts) { if (na.rm & stat != 'countNA') { nas <- sum(is.na(d) ) if (nas == length(d)) { # only NAs next } cells <- length(d) - nas } else { if (stat == 'countNA') { nas <- sum(is.na(d) ) } else { cells <- length(d) } } } if (stat=='mean') { st <- sum(d, na.rm=na.rm) + st cnt <- cnt + cells } else if (stat=='sum') { st <- sum(as.double(d), na.rm=na.rm) + st } else if (stat == 'sd') { st <- sum(d, na.rm=na.rm) + st cnt <- cnt + cells sumsq <- sum( d^2 , na.rm=na.rm) + sumsq } else if (stat=='countNA') { st <- st + nas } else if (stat=='skew') { d <- (d - zmean) sumsq <- sum(d^2, na.rm=na.rm) + sumsq d3 <- sum(d^3, na.rm=na.rm) + d3 cnt <- cnt + cells } else if (stat=='rms') { sumsq <- sum( d^2, na.rm=na.rm) + sumsq cnt <- cnt + cells } else { st <- fun(d, st, na.rm=na.rm) } pbStep(pb, i) } pbClose(pb) if (stat == 'sd') { meansq <- (st/cnt)^2 st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1))) if (!asSample) { #st <- sqrt( st^2 * (cnt / (cnt-1))) st <- sqrt( st^2 * ((cnt-1) / cnt)) } } else if (stat == 'mean') { st <- st / cnt } else if (stat == 'rms') { if (asSample) { st <- sqrt(sumsq/(cnt-1)) } else { st <- sqrt(sumsq/cnt) } } else if (stat == 'skew') { if (asSample) { stsd <- sqrt(sumsq/(cnt-1))^3 } else { stsd <- sqrt(sumsq/cnt)^3 } st <- d3 / (cnt*stsd) } return(st) } ) raster/R/colortable.R0000644000176200001440000000040514160021141014211 0ustar liggesusers colortable <- function(x) { if (.hasSlot(x, 'legend')) { x@legend@colortable } else { logical(0) } } 'colortable<-' <- function(x, value) { # for now assuming values are between 0 and 255!! x@legend@colortable <- value return(x) } raster/R/select.R0000644000176200001440000000546314160021141013353 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric("select")) { setGeneric("select", function(x, ...) standardGeneric("select")) } setMethod('select', signature(x='Raster'), function(x, use='rec', ...) { use <- substr(tolower(use), 1, 3) stopifnot(use %in% c('rec', 'pol')) if (use == 'rec') { e <- drawExtent() int <- intersect(e, extent(x)) if (is.null(int)) { x <- NULL } else { x <- crop(x, e) } } else { e <- drawPoly() int <- intersect(extent(x), e) if (is.null(int)) { x <- NULL } else { x <- crop(x, e) x <- mask(x, e) } } x } ) setMethod('select', signature(x='Spatial'), function(x, use='rec', draw=TRUE, col='cyan', size=2, ...) { use <- substr(tolower(use), 1, 3) stopifnot(use %in% c('rec', 'pol')) if (use == 'rec') { e <- as(drawExtent(), 'SpatialPolygons') } else { e <- drawPoly() } e@proj4string <- x@proj4string int <- intersect(extent(e), extent(x)) if (is.null(int)) { return( NULL ) } if (inherits(x, 'SpatialPolygons')) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) int <- rgeos::gIntersects(x, e, byid=TRUE) int <- apply(int, 2, any) if (any(int)) { x <- x[int, ] if (draw) { sp::plot(x, add=TRUE, border=col, lwd=size) } } else { x <- NULL } } else if (inherits(x, 'SpatialLines')) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) int <- rgeos::gIntersects(x, e, byid=TRUE) int <- apply(int, 2, any) if (any(int)) { x <- x[int, ] if (draw) { sp::plot(x, add=TRUE, col=col, lwd=size) } } else { x <- NULL } } else if (inherits(x, 'SpatialGrid')) { cls <- class(x) if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPointsDataFrame') } else { x <- as(x, 'SpatialPoints') } i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { x <- x[i,] sp::gridded(x) <- TRUE x <- as(x, cls) if (draw) { sp::plot(x, col=col, cex=size, add=TRUE) } } else { x <- NULL } } else if (inherits(x, 'SpatialPixels')) { cls <- class(x) if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPointsDataFrame') } else { x <- as(x, 'SpatialPoints') } i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { x <- x[i,] x <- as(x, cls) if (draw) { points(x, col=col, cex=size) } } else { x <- NULL } } else { # SpatialPoints i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { x <- x[i,] if (draw) { points(x, col=col, cex=size) } } else { x <- NULL } } x } ) raster/R/canProcessInMemory.R0000644000176200001440000000433414160021141015650 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 #.RAMavailable <- function(defmem=.maxmemory()) { # # if (useC) { # .availableRAM(defmem) # } else { # essentially the same results as above, but slower # if ( .Platform$OS.type == "windows" ) { # mem <- system2("wmic", args = "OS get FreePhysicalMemory /Value", stdout = TRUE) # mem3 <- gsub("\r", "", mem[3]) # mem3 <- gsub("FreePhysicalMemory=", "", mem3) # memavail <- as.numeric(mem3) * 1024 #memavail <- 0.5 * (utils::memory.size(NA) - utils::memory.size(FALSE)) # } else if ( .Platform$OS.type == "unix" ) { # mac is also "unix" and this does not work on mac # memavail <- as.numeric(system("awk '/MemFree/ {print $2}' /proc/meminfo", intern=TRUE)) # } else { #don't know how to do this on a mac # memavail <- defmem # } # } # memavail #} canProcessInMemory <- function(x, n=4, verbose=FALSE) { # for testing purposes # rasterOptions(format='GTiff') # requireNamespace("ncdf4") # requireNamespace("rgdal") # rasterOptions(format='big.matrix') # rasterOptions(format='CDF') # rasterOptions(overwrite=TRUE) # rasterOptions(todisk=TRUE) # return(FALSE) if (.toDisk()) { return(FALSE) } nc <- ncell(x) # avoid vectors that are too long n <- n * nlayers(x) memneed <- nc * n * 8 maxmem <- .maxmemory() memavail <- .availableRAM(maxmem) if (verbose) { gb <- 1073741824 cat(" GB") cat(paste("\navailable :", round(memavail / gb, 2))) cat(paste0("\n ", round(100*.memfrac()) , "% : ", round(.memfrac() * memavail / gb, 2))) cat(paste("\n needed :", round(memneed / gb, 2))) cat(paste("\n allowed :", round(maxmem / gb, 2), " (if available)\n")) } if (nc > (2^31 -1)) return(FALSE) # can't use all of it; default is 60% memavail <- .memfrac() * memavail # the below allows you to safely set a high maxmem # but still limit total mem use memavail <- min(memavail, maxmem) if (memneed > memavail) { # new (hidden) option; the 0.25 could be another option # now you can only make it lower via chunksize options(rasterChunk = min(.chunksize(), memavail * 0.25)) return(FALSE) } else { return(TRUE) } } raster/R/distanceFromPoints.R0000644000176200001440000000240614160021141015701 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 distanceFromPoints <- function(object, xy, filename='', ...) { pts <- .pointsToMatrix(xy) filename <- trim(filename) if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE } out <- raster(object) a = 6378137.0 f = 1/298.257223563 if (canProcessInMemory(out, 4)) { xy <- xyFromCell(out, 1:ncell(out)) out <- setValues(out, .Call('_raster_distanceToNearestPoint', xy, pts, longlat, a, f , PACKAGE = 'raster')) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- .Call('_raster_distanceToNearestPoint', xy, pts, longlat, a, f, PACKAGE='raster') out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } raster/R/cellValues.R0000644000176200001440000000437714160021141014176 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 .cellValues <- function(x, cells, layer, nl, df=FALSE, factors=FALSE) { cells[cells < 1 | cells > ncell(x)] <- NA if (inherits(x, 'RasterLayer')) { if (inMemory(x)) { if (length(stats::na.omit(cells)) == 0) { if (length(cells) == 0) { return(NULL) } return(cells) } # as.numeric to avoid logical values for backwards compatibility result <- as.numeric(x@data@values[cells] ) } else { result <- .readCells(x, cells, 1) } } else { nlyrs <- nlayers(x) if (missing(layer)) { layer <- 1 } layer <- min( max( round(layer), 1), nlyrs) if (missing(nl)) { nl <- nlyrs } nl <- min( max( round(nl), 1), nlyrs-layer+1 ) lyrs <- layer:(layer+nl-1) if (inherits(x, 'RasterStack')) { result <- matrix(ncol=nl, nrow=length(cells)) colnames(result) <- names(x)[lyrs] if (length(stats::na.omit(cells)) == 0) { return(result) } if (inMemory(x)) { for (i in 1:length(lyrs)) { result[,i] <- as.numeric(x@layers[[lyrs[i]]]@data@values[cells] ) } } else { for (i in 1:length(lyrs)) { result[,i] <- .readCells( x@layers[[lyrs[i]]], cells, 1) } } } else if (inherits(x, 'RasterBrick')) { if (inMemory(x)) { result <- x@data@values[cells, lyrs, drop=FALSE] } else if (x@file@driver == 'netcdf') { result <- .readBrickCellsNetCDF(x, cells, layer, nl) } else { result <- .readCells(x, cells, lyrs) } if (is.null(dim(result))) { result <- matrix(result, ncol=length(lyrs)) } colnames(result) <- names(x)[lyrs] } } if (df) { if (!is.matrix(result)) { result <- matrix(result) colnames(result) <- names(x) } result <- data.frame(ID=1:NROW(result), result) facts <- is.factor(x)[lyrs] if (any(facts) & factors) { if (ncol(result) == 2) { # possibly multiple columns added result <- cbind(result[,1,drop=FALSE], factorValues(x, result[,2], layer)) } else { # single columns only i <- which(facts) for (j in i) { result <- .insertColsInDF(result, factorValues(x, result[, j+1], j), j+1) } } } } result } raster/R/kernelDensity.R0000644000176200001440000000074214160021141014707 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2016 # Version 0.1 # Licence GPL v3 .kernelDensity <- function(xy, r, bandwidth) { requireNamespace("MASS") lims <- as.vector(extent(r)) + rep(res(r), each=2) * c(0.5,-0.5) n <- rev(dim(r)[1:2]) xy <- .pointsToMatrix(xy) k <- raster( MASS::kde2d(xy[,1], xy[,2], h=bandwidth, n=n, lims=lims) ) # to avoid possible small changes due to floating point math and to transfer crs setValues(r, getValues(k)) } raster/R/projection.R0000644000176200001440000001072014160215116014247 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 # to be removed when released sp has this for crs setMethod("wkt", signature(obj="ANY"), function(obj) { if (!inherits(obj, "CRS")) { obj <- obj@crs } else if (inherits(obj, c("sf", "sfc"))) { obj <- sf::st_crs(obj) obj <- as(obj, "CRS") # passes on WKT comment } w <- comment(obj) if (is.null(w)) { warning("no wkt comment") return("") } else { return(w) } } ) setMethod("wkt", signature(obj="Raster"), function(obj) { w <- comment(obj@crs) if (is.null(w)) { warning("no wkt comment") return("") } else { return(w) } } ) .srs_from_sp <- function(x) { crs <- x@proj4string pj <- crs@projargs wk <- wkt(crs) return(c(pj, wk)) } .makeCRS <- function(user="", prj="", wkt="") { if (wkt != "") { if (prj != "") { .CRS(prj, SRS_string=wkt) } else { .CRS(SRS_string=wkt) } } else if (user !="") { if (substr(trim(user), 1 ,1) == "+") { .CRS(user) } else { .CRS(SRS_string=user) } } else { .CRS(prj) } } .getCRS <- function(x) { if (methods::extends(class(x), "CRS")) { return(x) } if (is.null(x)) { x <- .CRS() } else if (methods::extends(class(x), "BasicRaster")) { x <- x@crs } else if (methods::extends(class(x), "Spatial")) { x <- x@proj4string } else if (inherits(x, c("sf", "sfc"))) { x <- sf::st_crs(x) x <- as(x, "CRS") # passes on WKT comment } else if (inherits(x, "SpatRaster")) { crs <- crs(x) x <- .makeCRS(x[1], x[2]) } else if (inherits(x, "SpatVector")) { crs <- crs(x) x <- .makeCRS(x[1], x[2]) } else if (is.na(x)) { x <- .CRS() } else if (is.character(x)) { x <- trimws(x) if (x == "") { x <- .CRS() } else if (substr(x, 1, 1) == "+") { x <- .CRS(x) } else { x <- .CRS(SRS_string = x) } #if (trimws(x) == "") { # x <- return(CRS()) #} else { # wkt <- rgdal::showSRID(x) # x <- .CRS() # x@projargs <- rgdal::showP4(wkt) # attr(x, "comment") <- wkt #} } else if (is.numeric(x)) { x <- paste0("EPSG:", round(x)) x <- .CRS(SRS_string = x) } else { x <- .CRS() } # else if "is .CRS" x } setMethod("crs", signature("ANY"), function(x, asText=FALSE, ...) { projection(x, asText=asText) } ) setMethod("crs<-", signature("BasicRaster", "ANY"), function(x, ..., value) { projection(x) <- value x } ) #rgdal::showWKT(projection(x))) setMethod("crs<-", signature("Spatial", "ANY"), function(x, ..., value) { if (!inherits(value, "CRS")) { if (is.na(value)) { value <- .CRS() } else if (is.character(value)) { value <- .CRS(value) } else { value <- .CRS(value) } } suppressWarnings(x@proj4string <- value) x } ) setMethod("is.na", signature(x="CRS"), function(x) { is.na(x@projargs) } ) "projection<-" <- function(x, value) { value <- .getCRS(value) if (inherits(x, "RasterStack")) { if (nlayers(x) > 0) { for (i in 1:nlayers(x)) { x@layers[[i]]@crs <- value #x@layers[[i]]@crs <- .CRS(value) } } } if (inherits(x, "Spatial")) { x@proj4string <- value } else { x@crs <- value } return(x) } projection <- function(x, asText=TRUE) { if (methods::extends(class(x), "BasicRaster")) { x <- x@crs } else if (methods::extends(class(x), "Spatial")) { x <- x@proj4string } else if (inherits(x, c("sf", "sfc"))) { crs = sf::st_crs(x) if (asText) { return(crs$proj4string) # extracts sp::proj4string from WKT } else { return(as(crs, "CRS")) # passes on WKT comment } } else if (inherits(x, "character")) { if (asText) { return(x) } else { return( .CRS(x) ) } } else if (!inherits(x, "CRS")) { return(as.logical(NA)) } if (asText) { if (inherits(x, "CRS")) { if (is.na(x@projargs)) { return(as.character(NA)) } else { return(trim(x@projargs)) } } } else if (!inherits(x, "CRS")) { x <- .CRS(x) } return(x) } setMethod("proj4string", signature("BasicRaster"), function(obj) { obj@crs@projargs } ) setMethod("as.character", signature("CRS"), function(x, ...) { x@projargs } ) setMethod("proj4string", signature("CRS"), function(obj) { obj@projargs } ) setMethod("proj4string<-", signature("Raster"), function(obj, value) { crs(obj) <- value obj } ) raster/R/unstack.R0000644000176200001440000000072014160021141013533 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("unstack")) { setGeneric("unstack", function(x, ...) standardGeneric("unstack")) } setMethod("unstack", signature(x='RasterStack'), function(x) { return(x@layers) } ) setMethod("unstack", signature(x='RasterBrick'), function(x) { if (nlayers(x) == 0) { list() } else { lapply(1:nlayers(x), function(i) raster(x, i)) } } ) raster/R/getData.R0000644000176200001440000003167614160021141013452 0ustar liggesusers# Download geographic data and return as R object # Author: Robert J. Hijmans # License GPL3 # Version 0.9 # October 2008 getData <- function(name='GADM', download=TRUE, path='', ...) { path <- .getDataPath(path) tout <- getOption("timeout") on.exit(options(timeout = tout)) options(timeout = max(600, tout)) if (name=='GADM') { .GADM(..., download=download, path=path) } else if (name=='SRTM') { .SRTM(..., download=download, path=path) } else if (name=='alt') { .raster(..., name=name, download=download, path=path) } else if (name=='worldclim') { .worldclim(..., download=download, path=path) } else if (name=='CMIP5') { .cmip5(..., download=download, path=path) } else if (name=='ISO3') { ccodes()[,c(2,1)] } else if (name=='countries') { .countries(download=download, path=path, ...) } else { stop(name, ' not recognized as a valid name.') } } .download <- function(aurl, filename) { fn <- paste(tempfile(), '.download', sep='') res <- utils::download.file(url=aurl, destfile=fn, quiet = FALSE, mode = "wb", cacheOK = TRUE) if (res == 0) { w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) if (! file.rename(fn, filename) ) { # rename failed, perhaps because fn and filename refer to different devices file.copy(fn, filename) file.remove(fn) } } else { stop('could not download the file' ) } } .ISO <- function() { ccodes() } ccodes <- function() { path <- system.file(package="raster") #d <- utils::read.csv(paste(path, "/external/countries.csv", sep=""), stringsAsFactors=FALSE, encoding="UTF-8") readRDS(file.path(path, "external/countries.rds")) } .getCountry <- function(country='') { country <- toupper(trim(country[1])) cs <- ccodes() cs <- sapply(cs, toupper) cs <- data.frame(cs, stringsAsFactors=FALSE) nc <- nchar(country) if (nc == 3) { if (country %in% cs$ISO3) { return(country) } else { stop('unknown country') } } else if (nc == 2) { if (country %in% cs$ISO2) { i <- which(country==cs$ISO2) return( cs$ISO3[i] ) } else { stop('unknown country') } } else if (country %in% cs[,1]) { i <- which(country==cs[,1]) return( cs$ISO3[i] ) } else if (country %in% cs[,4]) { i <- which(country==cs[,4]) return( cs$ISO3[i] ) } else if (country %in% cs[,5]) { i <- which(country==cs[,5]) return( cs$ISO3[i] ) } else { stop('provide a valid name name or 3 letter ISO country code; you can get a list with "ccodes()"') } } .getDataPath <- function(path) { path <- trim(path) if (path=="") { path <- .dataloc() } else { if (substr(path, nchar(path)-1, nchar(path)) == '//' ) { p <- substr(path, 1, nchar(path)-2) } else if (substr(path, nchar(path), nchar(path)) == '/' | substr(path, nchar(path), nchar(path)) == '\\') { p <- substr(path, 1, nchar(path)-1) } else { p <- path } if (!file.exists(p) & !file.exists(path)) { stop('path does not exist: ', path) } } if (substr(path, nchar(path), nchar(path)) != '/' & substr(path, nchar(path), nchar(path)) != '\\') { path <- paste(path, "/", sep="") } return(path) } .GADM <- function(country, level, download, path, version=3.6, type='sp') { # if (!file.exists(path)) { dir.create(path, recursive=T) } country <- .getCountry(country) if (missing(level)) { stop('provide a "level=" argument; levels can be 0, 1, or 2 for most countries, and higher for some') } if (version > 3) { if (type == 'sf') { filename <- file.path(path, paste0('gadm36_', country, '_', level, "_sf.rds")) } else { filename <- file.path(path, paste0('gadm36_', country, '_', level, "_sp.rds")) } } else { filename <- paste(path, 'GADM_', version, '_', country, '_', level, ".rds", sep="") } if (!file.exists(filename)) { if (download) { baseurl <- paste0("https://biogeo.ucdavis.edu/data/gadm", version) if (version == 2.8) { theurl <- paste(baseurl, '/rds/', country, '_adm', level, ".rds", sep="") } else { if (type == 'sf') { theurl <- paste(baseurl, '/Rsf/gadm36_', country, '_', level, "_sf.rds", sep="") } else { theurl <- paste(baseurl, '/Rsp/gadm36_', country, '_', level, "_sp.rds", sep="") } } .download(theurl, filename) if (!file.exists(filename)) { message("\nCould not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } if (file.exists(filename)) { x <- readRDS(filename) # avoid pesky warnings if (type != 'sf') { crs(x) <- "+proj=longlat +datum=WGS84" } return(x) } else { return(NULL) } } .countries <- function(download, path, type='sp', ...) { if (type == 'sf') { f <- "countries_gadm36_sf.rds" } else { f <- "countries_gadm36_sp.rds" } filename <- file.path(path, f) if (!file.exists(filename)) { if (download) { theurl <- paste0("https://biogeo.ucdavis.edu/data/gadm3.6/", f) .download(theurl, filename) if (!file.exists(filename)) { message("\nCould not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } if (file.exists(filename)) { #thisenvir = new.env() #data <- get(load(filename, thisenvir), thisenvir) data <- readRDS(filename) crs(data) <- "+proj=longlat +datum=WGS84" return(data) } } .cmip5 <- function(var, model, rcp, year, res, lon, lat, path, download=TRUE) { if (!res %in% c(0.5, 2.5, 5, 10)) { stop('resolution should be one of: 2.5, 5, 10') } if (res==2.5) { res <- '2_5m' } else if (res == 0.5) { res <- "30s" } else { res <- paste(res, 'm', sep='') } var <- tolower(var[1]) vars <- c('tmin', 'tmax', 'prec', 'bio') stopifnot(var %in% vars) var <- c('tn', 'tx', 'pr', 'bi')[match(var, vars)] model <- toupper(model) models <- c('AC', 'BC', 'CC', 'CE', 'CN', 'GF', 'GD', 'GS', 'HD', 'HG', 'HE', 'IN', 'IP', 'MI', 'MR', 'MC', 'MP', 'MG', 'NO') stopifnot(model %in% models) rcps <- c(26, 45, 60, 85) stopifnot(rcp %in% rcps) stopifnot(year %in% c(50, 70)) #m <- matrix(c(0,1,1,0,1,1,1,1,1,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,0,0,1,0,1,1,1,0,0,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1), ncol=4) m <- matrix(c(0,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,0,0,0,1,1,1,0,1,0,1,1,1,1,0,1,1,1,1,1,0,1,1,0,1,1,1,1,1,1,1,1,1,1,1,1), ncol=4) i <- m[which(model==models), which(rcp==rcps)] if (!i) { warning('this combination of rcp and model is not available') return(invisible(NULL)) } path <- paste(path, '/cmip5/', res, '/', sep='') dir.create(path, recursive=TRUE, showWarnings=FALSE) zip <- tolower(paste(model, rcp, var, year, '.zip', sep='')) theurl <- paste('https://biogeo.ucdavis.edu/data/climate/cmip5/', res, '/', zip, sep='') zipfile <- paste(path, zip, sep='') if (var == 'bi') { n <- 19 } else { n <- 12 } tifs <- paste(extension(zip, ''), 1:n, '.tif', sep='') files <- paste(path, tifs, sep='') fc <- sum(file.exists(files)) if (fc < n) { if (!file.exists(zipfile)) { if (download) { .download(theurl, zipfile) if (!file.exists(zipfile)) { message("\n Could not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } utils::unzip(zipfile, exdir=dirname(zipfile)) } stack(paste(path, tifs, sep='')) } #.cmip5(var='prec', model='BC', rcp=26, year=50, res=10, path=getwd()) .worldclim <- function(var, res, lon, lat, path, download=TRUE) { if (!res %in% c(0.5, 2.5, 5, 10)) { stop('resolution should be one of: 0.5, 2.5, 5, 10') } if (res==2.5) { res <- '2-5' } stopifnot(var %in% c('tmean', 'tmin', 'tmax', 'prec', 'bio', 'alt')) path <- paste(path, 'wc', res, '/', sep='') dir.create(path, showWarnings=FALSE) if (res==0.5) { lon <- min(180, max(-180, lon)) lat <- min(90, max(-60, lat)) rs <- raster(nrows=5, ncols=12, xmn=-180, xmx=180, ymn=-60, ymx=90 ) row <- rowFromY(rs, lat) - 1 col <- colFromX(rs, lon) - 1 rc <- paste(row, col, sep='') zip <- paste(var, '_', rc, '.zip', sep='') zipfile <- paste(path, zip, sep='') if (var == 'alt') { bilfiles <- paste(var, '_', rc, '.bil', sep='') hdrfiles <- paste(var, '_', rc, '.hdr', sep='') } else if (var != 'bio') { bilfiles <- paste(var, 1:12, '_', rc, '.bil', sep='') hdrfiles <- paste(var, 1:12, '_', rc, '.hdr', sep='') } else { bilfiles <- paste(var, 1:19, '_', rc, '.bil', sep='') hdrfiles <- paste(var, 1:19, '_', rc, '.hdr', sep='') } theurl <- paste('https://biogeo.ucdavis.edu/data/climate/worldclim/1_4/tiles/cur/', zip, sep='') } else { zip <- paste(var, '_', res, 'm_bil.zip', sep='') zipfile <- paste(path, zip, sep='') if (var == 'alt') { bilfiles <- paste(var, '.bil', sep='') hdrfiles <- paste(var, '.hdr', sep='') } else if (var != 'bio') { bilfiles <- paste(var, 1:12, '.bil', sep='') hdrfiles <- paste(var, 1:12, '.hdr', sep='') } else { bilfiles <- paste(var, 1:19, '.bil', sep='') hdrfiles <- paste(var, 1:19, '.hdr', sep='') } theurl <- paste('https://biogeo.ucdavis.edu/data/climate/worldclim/1_4/grid/cur/', zip, sep='') } files <- c(paste(path, bilfiles, sep=''), paste(path, hdrfiles, sep='')) fc <- sum(file.exists(files)) if ( fc < length(files) ) { if (!file.exists(zipfile)) { if (download) { .download(theurl, zipfile) if (!file.exists(zipfile)) { message("\n Could not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } utils::unzip(zipfile, exdir=dirname(zipfile)) for (h in paste(path, hdrfiles, sep='')) { x <- readLines(h) x <- c(x[1:14], 'PIXELTYPE SIGNEDINT', x[15:length(x)]) writeLines(x, h) } } if (var == 'alt') { st <- raster(paste(path, bilfiles, sep='')) } else { st <- stack(paste(path, bilfiles, sep='')) } projection(st) <- "+proj=longlat +datum=WGS84" return(st) } .raster <- function(country, name, mask=TRUE, path, download, keepzip=FALSE, ...) { country <- .getCountry(country) path <- .getDataPath(path) if (mask) { mskname <- '_msk_' mskpath <- 'msk_' } else { mskname<-'_' mskpath <- '' } filename <- paste(path, country, mskname, name, ".grd", sep="") if (!file.exists(filename)) { zipfilename <- filename extension(zipfilename) <- '.zip' if (!file.exists(zipfilename)) { if (download) { theurl <- paste("https://biogeo.ucdavis.edu/data/diva/", mskpath, name, "/", country, mskname, name, ".zip", sep="") .download(theurl, zipfilename) if (!file.exists(zipfilename)) { message("\nCould not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } ff <- utils::unzip(zipfilename, exdir=dirname(zipfilename)) if (!keepzip) { file.remove(zipfilename) } } if (file.exists(filename)) { rs <- raster(filename) } else { #patrn <- paste(country, '.', mskname, name, ".grd", sep="") #f <- list.files(path, pattern=patrn) f <- ff[substr(ff, nchar(ff)-3, nchar(ff)) == '.grd'] if (length(f)==0) { warning('something went wrong') return(NULL) } else if (length(f)==1) { rs <- raster(f) } else { rs <- sapply(f, raster) message('returning a list of RasterLayer objects') return(rs) } } projection(rs) <- "+proj=longlat +datum=WGS84" return(rs) } .SRTM <- function(lon, lat, download, path) { stopifnot(lon >= -180 & lon <= 180) stopifnot(lat >= -60 & lat <= 60) rs <- raster(nrows=24, ncols=72, xmn=-180, xmx=180, ymn=-60, ymx=60 ) rowTile <- rowFromY(rs, lat) colTile <- colFromX(rs, lon) if (rowTile < 10) { rowTile <- paste('0', rowTile, sep='') } if (colTile < 10) { colTile <- paste('0', colTile, sep='') } baseurl <- "https://srtm.csi.cgiar.org/wp-content/uploads/files/srtm_5x5/TIFF/" f <- paste0("srtm_", colTile, "_", rowTile, ".zip") zipfilename <- file.path(path, f) tiffilename <- file.path(path, gsub(".zip$", ".tif", f)) if (!file.exists(tiffilename)) { if (!file.exists(zipfilename)) { if (download) { theurl <- paste0(baseurl, f) test <- try (.download(theurl, zipfilename) , silent=TRUE) if (inherits(test, "try-error")) { stop("cannot download the file") } } else {message("file not available locally, use download=TRUE") } } if (file.exists(zipfilename)) { utils::unzip(zipfilename, exdir=dirname(zipfilename)) file.remove(zipfilename) } } if (file.exists(tiffilename)) { rs <- raster(tiffilename) projection(rs) <- "+proj=longlat +datum=WGS84" return(rs) } else { stop('file not found') } } #.SRTM(lon=5.5, lat=44.5, TRUE, ".") raster/R/drawExtent.R0000644000176200001440000000146714160021141014221 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009, December 2011 # Version 1.0 # Licence GPL v3 drawExtent <- function(show=TRUE, col="red") { if (show) { loc1 <- graphics::locator(n=1, type="p", pch='+', col=col) } else { loc1 <- graphics::locator(n=1) } loc2 <- graphics::locator(n=1) loc <- rbind(unlist(loc1), unlist(loc2)) e <- extent(min(loc[,'x']), max(loc[,'x']), min(loc[,'y']), max(loc[,'y'])) if (e@xmin == e@xmax) { e@xmin <- e@xmin - 0.0000001 e@xmax <- e@xmax + 0.0000001 } if (e@ymin == e@ymax) { e@ymin <- e@ymin - 0.0000001 e@ymax <- e@ymax + 0.0000001 } if (show) { p <- rbind(c(e@xmin, e@ymin), c(e@xmin, e@ymax), c(e@xmax, e@ymax), c(e@xmax, e@ymin), c(e@xmin, e@ymin) ) lines(p, col=col) } return(e) } raster/R/hillShade.R0000644000176200001440000000144214160021141013762 0ustar liggesusers# Author: Andrew Bevan, Oscar Perpinan Lamigueiro, and Robert J. Hijmans # Date : March 2010 # Version 1.0 # Licence GPL v3 hillShade <- function(slope, aspect, angle=45, direction=0, filename='', normalize=FALSE, ...) { compareRaster(slope, aspect) direction <- direction * pi/180 zenith <- (90 - angle)*pi/180 #x <- cos(slope) * cos(declination) + sin(slope) * sin(declination) * cos(direction-aspect) if (normalize) { fun <- function(slp, asp) { shade <- cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) shade[shade < 0] <- 0 shade * 255 } } else { fun <- function(slp, asp) { cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) } } x <- overlay(slope, aspect, fun=fun, filename=filename, ...) return(x) } raster/R/extentUnion.R0000644000176200001440000000012714160021141014404 0ustar liggesusers# Authors: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 raster/R/crop.R0000644000176200001440000000503014160021141013025 0ustar liggesusers# Authors: Robert J. Hijmans and Jacob van Etten # Date : October 2008 # Version 0.9 # Licence GPL v3 .copyWithProperties <- function(x) { if (inherits(x, 'RasterBrick')) { out <- brick(x, values=FALSE) out@legend <- x@legend } else if (inherits(x, 'RasterStack')) { out <- brick(x, values=FALSE) } else { out <- raster(x) out@legend <- x@legend } names(out) <- names(x) out <- setZ(out, getZ(x)) fx <- is.factor(x) if (isTRUE(any(fx))) { out@data@isfactor <- fx out@data@attributes <- levels(x) } out } setMethod('crop', signature(x='Raster', y='ANY'), function(x, y, filename='', snap='near', datatype=NULL, ...) { filename <- trim(filename) y <- try ( extent(y), silent=TRUE ) if (inherits(y, "try-error")) { stop('Cannot get an Extent object from argument y') } methods::validObject(y) out <- .copyWithProperties(x) leg <- out@legend e <- intersect(extent(x), extent(y)) if (is.null(e)) { stop('extents do not overlap') } e <- alignExtent(e, x, snap=snap) out <- setExtent(out, e, keepres=TRUE) if (! hasValues(x)) { return(out) } col1 <- colFromX(x, xmin(out)+0.5*xres(out)) col2 <- colFromX(x, xmax(out)-0.5*xres(out)) row1 <- rowFromY(x, ymax(out)-0.5*yres(out)) row2 <- rowFromY(x, ymin(out)+0.5*yres(out)) if (row1==1 & row2==nrow(x) & col1==1 & col2==ncol(x)) { if (filename == "") { return(x) } else { return(writeRaster(x, filename=filename, datatype=datatype, ...)) } } nc <- ncol(out) if (is.null(datatype)) { datatype <- unique(c(dataType(x), 'INT2S')) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } dataType(out) <- datatype xx <- out xx@ncols <- x@ncols # getValuesBlock might read entire rows and then subset if (canProcessInMemory(xx, 4)) { nr <- row2 - row1 + 1 v <- getValuesBlock(x, row1, nrows=nr, col=col1, ncols=nc) out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename=filename, datatype=datatype, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='crop', ...) out <- writeStart(out, filename=filename, datatype=datatype, ... ) x <- readStart(x, ...) for (i in 1:tr$n) { vv <- getValuesBlock(x, row=tr$row[i]+row1-1, nrows=tr$nrows[i], col1, nc) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) x <- readStop(x) pbClose(pb) } if (!inherits(out, 'RasterStack')) { out@legend <- leg } return(out) } ) raster/R/validCell.R0000644000176200001440000000115214160021141013762 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 validCell <- function(object, cell) { cell <- round(cell) valid <- rep(FALSE, times=length(cell)) valid[cell > 0 & cell <= ncell(object)] <- TRUE return(valid) } validRow <- function(object, rownr) { rownr <- round(rownr) valid <- rep(FALSE, times=length(rownr)) valid[rownr > 0 & rownr <= object@nrows] <- TRUE return(valid) } validCol <- function(object, colnr) { colnr <- round(colnr) valid <- rep(FALSE, times=length(colnr)) valid[colnr > 0 & colnr <= object@ncols] <- TRUE return(valid) } raster/R/cellFromLine.R0000644000176200001440000000154314160021141014442 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 cellFromLine <- function(object, lns) { spbb <- sp::bbox(lns) rsbb <- bbox(object) addres <- 2 * max(res(object)) nlns <- length( lns@lines ) res <- list() res[[nlns+1]] = NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { return(res[1:nlns]) } rr <- raster(object) for (i in 1:nlns) { pp <- lns[i,] spbb <- sp::bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # always TRUE? res[[i]] <- cellFromXY(object, xy) } } } return( res[1:nlns] ) } raster/R/adjacent.R0000644000176200001440000001045414160021141013641 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2011 # Version 1.0 # Licence GPL v3 .adjacentUD <- function(x, cells, ngb, include) { # ngb should be a matrix with # one and only one cell with value 0 (the focal cell), # at least one cell with value 1 (the adjacent cells) # cells with other values are ignored (not considered adjacent) rs <- res(x) rn <- raster(ngb) center <- which(values(rn)==0) if (include) { ngb[center] <- 1 } rc <- rowFromCell(rn, center) cc <- colFromCell(rn, center) xngb <- yngb <- ngb xngb[] <- rep(1:ncol(ngb), each=nrow(ngb)) - cc yngb[] <- rep(nrow(ngb):1, ncol(ngb)) - (nrow(ngb)-rc+1) ngb[ngb != 1] <- NA xngb <- stats::na.omit(as.vector( xngb * rs[1] * ngb)) yngb <- stats::na.omit(as.vector( yngb * rs[2] * ngb)) xy <- xyFromCell(x, cells) X <- apply(xy[,1,drop=FALSE], 1, function(z) z + xngb ) Y <- apply(xy[,2,drop=FALSE], 1, function(z) z + yngb ) c(as.vector(X), as.vector(Y)) } setMethod("adjacent", signature(x="BasicRaster"), function(x, cells, directions=4, pairs=TRUE, target=NULL, sorted=FALSE, include=FALSE, id=FALSE, ...) { if (is.character(directions)) { directions <- tolower(directions) } x <- raster(x) r <- res(x) xy <- xyFromCell(x, cells) mat <- FALSE if (is.matrix(directions)) { stopifnot(length(which(directions==0)) == 1) stopifnot(length(which(directions==1)) > 0) d <- .adjacentUD(x, cells, directions, include) directions <- sum(directions==1, na.rm=TRUE) mat <- TRUE } else if (directions==4) { if (include) { d <- c(xy[,1], xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions==8) { if (include) { d <- c(xy[,1], rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1], xy[,2], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions==16) { r2 <- r * 2 if (include) { d <- c(xy[,1], rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2), rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5), xy[,1], xy[,1], xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2), rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2), rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5), xy[,1], xy[,1], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2), rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions=='bishop') { if (include) { d <- c(xy[,1], rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2)) } else { d <- c(rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2)) } directions <- 4 # to make pairs } else { stop('directions should be one of: 4, 8, 16, "bishop", or a matrix') } if (include) directions <- directions + 1 d <- matrix(d, ncol=2) if (.isGlobalLonLat(x)) { # normalize longitude to -180..180 d[,1] <- (d[,1] + 180) %% 360 - 180 } if (pairs) { if (mat) { cell <- rep(cells, each=directions) } else { cell <- rep(cells, directions) } if (id) { if (mat) { ID <- rep(1:length(cells), each=directions) } else { ID <- rep(1:length(cells), directions) } d <- stats::na.omit(cbind(ID, cell, cellFromXY(x, d))) attr(d, 'na.action') <- NULL colnames(d) <- c('id', 'from', 'to') if (! is.null(target)) { d <- d[d[,3] %in% target, ] } } else { d <- stats::na.omit(cbind(cell, cellFromXY(x, d))) attr(d, 'na.action') <- NULL colnames(d) <- c('from', 'to') if (! is.null(target)) { d <- d[d[,2] %in% target, ] } } if (sorted) { d <- d[order(d[,1], d[,2]),] } } else { d <- as.vector(unique(stats::na.omit(cellFromXY(x, d)))) if (! is.null(target)) { d <- intersect(d, target) } if (sorted) { d <- sort(d) } } d } ) raster/R/math.R0000644000176200001440000000767014160021141013027 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("Math", signature(x='Raster'), function(x){ if (!hasValues(x)) { return(x) } #funname <- as.character(sys.call(sys.parent())[[1]]) funname <- .Generic nl <- nlayers(x) if (nl > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (substr(funname, 1, 3) == 'cum' ) { if (nl == 1) { if (canProcessInMemory(r, 3)) { r <- setValues(r, do.call(funname, list(values(x)))) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) x <- readStart(x) last <- 0 for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (i==1) { v <- do.call(funname, list(v)) } else { v <- do.call(funname, list(c(last, v)))[-1] } last <- v[length(v)] r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } if (canProcessInMemory(r, 3)) { r <- setValues(r, t( apply(getValues(x), 1, funname)) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- t( apply(getValues(x, row=tr$row[i], nrows=tr$nrows[i]), 1, funname) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { r <- setValues(r, methods::callGeneric(getValues(x))) } else { if (funname %in% c('floor', 'ceiling', 'trunc')) { datatype <- 'INT4S' } else { datatype <- .datatype() } tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- methods::callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } } return(r) } ) setMethod("Math2", signature(x='Raster'), function (x, digits=0) { digits <- round(digits) if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, methods::callGeneric( getValues(x), digits)) } else { if (digits <= 0) { datatype <- 'INT4S' } else { datatype <- .datatype() } tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, format=.filetype(), overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- methods::callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), digits ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } ) if (!isGeneric("log")) { setGeneric("log", function(x, ...) standardGeneric("log")) } setMethod("log", signature(x='Raster'), function(x, base=exp(1)){ nl <- nlayers(x) if (nl > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, log(values(x), base=base)) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, '', overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- log( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), base=base ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } ) raster/R/geom.R0000644000176200001440000000563614160021141013025 0ustar liggesusers setMethod("geom", signature(x="SpatialPolygons"), function(x, sepNA=FALSE, ...) { nobs <- length(x@polygons) objlist <- list() cnt <- 0 if (sepNA) { sep <- rep(NA,5) for (i in 1:nobs) { nsubobs <- length(x@polygons[[i]]@Polygons) ps <- list() last <- 0 for (j in 1:nsubobs) { if (!x@polygons[[i]]@Polygons[[j]]@hole) { last <- last + 1 hole <- 0 } else { hole <- max(1, last) } ps[[j]] <- rbind(cbind(j, j+cnt, hole, x@polygons[[i]]@Polygons[[j]]@coords),sep) } objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobs } } else { for (i in 1:nobs) { nsubobs <- length(x@polygons[[i]]@Polygons) ps <- list() last <- 0 for (j in 1:nsubobs) { if (!x@polygons[[i]]@Polygons[[j]]@hole) { last <- last + 1 hole <- 0 } else { hole <- max(1, last) } ps[[j]] <- cbind(j, j+cnt, hole, x@polygons[[i]]@Polygons[[j]]@coords) } objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobs } } obs <- do.call(rbind, objlist) colnames(obs) <- c("object", "part", "cump", "hole", "x", "y") rownames(obs) <- NULL if (sepNA) { obs[is.na(obs[,2]), ] <- NA } return( obs ) } ) setMethod("geom", signature(x="SpatialLines"), function(x, sepNA=FALSE, ...) { nobs <- length(x@lines) objlist <- list() cnt <- 0 if (sepNA) { sep <- rep(NA, 4) for (i in 1:nobs) { nsubobj <- length(x@lines[[i]]@Lines) ps <- lapply(1:nsubobj, function(j) rbind(cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords), sep) ) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobj } } else { for (i in 1:nobs) { nsubobj <- length(x@lines[[i]]@Lines) ps <- lapply(1:nsubobj, function(j) cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords)) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobj } } obs <- do.call(rbind, objlist) colnames(obs) <- c("object", "part", "cump", "x", "y") rownames(obs) <- NULL if (sepNA) { obs[is.na(obs[,2]), ] <- NA } return (obs) } ) setMethod("geom", signature(x="SpatialPoints"), function(x, ...) { xy <- sp::coordinates(x)[,1:2,drop=FALSE] xy <- cbind(1:nrow(xy), xy) colnames(xy) <- c("object", "x", "y") return(xy) } ) setMethod("geom", signature(x="data.frame"), function(x, d, gt, crs, ...) { if (gt == "polygons") { sp <- as(x, "SpatialPolygons") if (NROW(d) > 0) { sp <- sp::SpatialPolygonsDataFrame(sp, d) } } else if (gt == "lines") { sp <- as(x, "SpatialLines") if (NROW(d) > 0) { sp <- sp::SpatialLinesDataFrame(sp, d) } } else { sp <- sp::SpatialPoints(x[,c("x", "y")]) if (NROW(d) > 0) { sp <- sp::SpatialPointsDataFrame(sp, d) } } crs(sp)<- crs sp } ) raster/R/adjacency.R0000644000176200001440000003501314160021141014007 0ustar liggesusers# Author: Jacob van Etten jacobvanetten@yahoo.com # Date : January 2009 # Version 0.9 # Licence GPL v3 .cs <- function(a,b) { aRep <- rep(a,times=length(b)) cbind(aRep,as.integer(aRep+rep(b,each=length(a))),deparse.level=0) } .adjacency <- function(x, ...) { warning('function "adjaceny" is obsolete and will be removed from the "raster" package.\nUse function "adjacent" in stead') dots <- list(...) fromCells <- dots$fromCells toCells <- dots$toCells directions <- dots$directions if (is.character(directions)) { directions <- tolower(directions) } stopifnot(directions %in% c(4,8,16) | directions=='bishop') x <- raster(x) outerMeridianConnect <- .isGlobalLonLat(x) if (directions=="bishop") { return(.adjBishop(x, fromCells, toCells, outerMeridianConnect)) } nCols <- ncol(x) nCells <- ncell(x) left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) right <- seq(2*nCols,nCells-nCols,by=nCols) upper <- 2:(nCols-1) lower <- seq((nCells-nCols+2),(nCells-1),by=1) upperleft <- 1 upperright <- nCols lowerleft <- nCells-nCols+1 lowerright <- nCells fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright)))) fromCellsUpper <- as.integer(intersect(fromCells,upper)) fromCellsLower <- as.integer(intersect(fromCells,lower)) fromCellsLeft <- as.integer(intersect(fromCells,left)) fromCellsRight <- as.integer(intersect(fromCells,right)) fromCellUpperleft <- as.integer(intersect(fromCells,upperleft)) fromCellUpperright <- as.integer(intersect(fromCells,upperright)) fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft)) fromCellLowerright <- as.integer(intersect(fromCells,lowerright)) rook <- c(1,-1,nCols,-nCols) coreFromToRook <- .cs(fromCellsCore,rook) upperFromToRook <- .cs(fromCellsUpper,rook[1:3]) lowerFromToRook <- .cs(fromCellsLower,rook[c(1,2,4)]) leftFromToRook <- .cs(fromCellsLeft,rook[c(1,3,4)]) rightFromToRook <- .cs(fromCellsRight,rook[2:4]) upperleftFromToRook <- .cs(fromCellUpperleft,rook[c(1,3)]) upperrightFromToRook <- .cs(fromCellUpperright,rook[2:3]) lowerleftFromToRook <- .cs(fromCellLowerleft,rook[c(1,4)]) lowerrightFromToRook <- .cs(fromCellLowerright,rook[c(2,4)]) fromto1 <- rbind(coreFromToRook,upperFromToRook,lowerFromToRook,leftFromToRook,rightFromToRook,upperleftFromToRook,upperrightFromToRook,lowerleftFromToRook,lowerrightFromToRook) if (outerMeridianConnect) { meridianFromLeft <- rbind( cbind(fromCellsLeft,as.integer(fromCellsLeft+nCols-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft+nCols-1)) ) meridianFromRight <- rbind( cbind(fromCellsRight,as.integer(fromCellsRight-nCols+1)), cbind(fromCellUpperright,as.integer(fromCellUpperright-nCols+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-nCols+1)) ) fromto1 <- rbind(fromto1,meridianFromLeft,meridianFromRight) } fromto <- subset(fromto1,fromto1[,2] %in% toCells) if (directions > 4) { bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1)) coreFromToBishop <- .cs(fromCellsCore,bishop) upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4]) lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2]) leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)]) rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)]) upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4]) upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3]) lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2]) lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1]) fromto2 <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop) if (outerMeridianConnect) { meridianFromLeft <- rbind( .cs(fromCellsLeft,c(2*nCols-1,-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1)) ) meridianFromRight <- rbind( cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))), cbind(fromCellUpperright,as.integer(fromCellUpperright+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1)) ) fromto2 <- rbind(fromto2,meridianFromLeft,meridianFromRight) } fromto2 <- subset(fromto2,fromto2[,2] %in% toCells) fromto <- rbind(fromto,fromto2) } if (directions > 8) { leftOuter <- seq(2*nCols+1,nCells-3*nCols+1,by=nCols) rightOuter <- seq(3*nCols,nCells-2*nCols,by=nCols) upperOuter <- seq(3,nCols-2,by=1) lowerOuter <- seq(nCells-nCols+3,nCells-2,by=1) upperleftUnder <- nCols+1 upperrightLeft <- nCols-1 lowerleftUp <- nCells-2*nCols+1 lowerrightUp <- nCells-nCols upperleftRight <- 2 upperrightUnder <- 2*nCols lowerleftRight <- nCells-nCols+2 lowerrightLeft <- nCells-1 leftInner <- seq(2*nCols+2,(nCells-3*nCols+2),by=nCols) rightInner <- seq(3*nCols-1,nCells-2*nCols-1,by=nCols) upperInner <- seq(nCols+3,2*nCols-2,by=1) lowerInner <- seq(nCells-2*nCols+3,nCells-nCols-2,by=1) upperleftInner <- nCols+2 upperrightInner <- 2*nCols-1 lowerleftInner <- nCells-2*nCols+2 lowerrightInner <- nCells-nCols-1 fromCellsCoreInner <- setdiff(fromCells,(c(leftOuter,rightOuter,upperOuter,lowerOuter,upperleft,upperright,lowerleft,lowerright, upperleftUnder, upperrightLeft, lowerleftUp, lowerrightUp, upperleftRight, upperrightUnder, lowerleftRight, lowerrightLeft, leftInner, rightInner, upperInner, lowerInner, upperleftInner, upperrightInner, lowerleftInner, lowerrightInner))) fromCellsUpperInner <- as.integer(intersect(fromCells,upperInner)) fromCellsLowerInner <- as.integer(intersect(fromCells,lowerInner)) fromCellsLeftInner <- as.integer(intersect(fromCells,leftInner)) fromCellsRightInner <- as.integer(intersect(fromCells,rightInner)) fromCellUpperleftInner <- as.integer(intersect(fromCells,upperleftInner)) fromCellUpperrightInner <- as.integer(intersect(fromCells,upperrightInner)) fromCellLowerleftInner <- as.integer(intersect(fromCells,lowerleftInner)) fromCellLowerrightInner <- as.integer(intersect(fromCells,lowerrightInner)) fromCellsLeftOuter <- as.integer(intersect(fromCells,leftOuter)) fromCellsRightOuter <- as.integer(intersect(fromCells,rightOuter)) fromCellsUpperOuter <- as.integer(intersect(fromCells,upperOuter)) fromCellsLowerOuter <- as.integer(intersect(fromCells,lowerOuter)) fromCellUpperleftUnder <- as.integer(intersect(fromCells,upperleftUnder)) fromCellUpperrightLeft <- as.integer(intersect(fromCells,upperrightLeft)) fromCellLowerleftUp <- as.integer(intersect(fromCells,lowerleftUp)) fromCellLowerrightUp <- as.integer(intersect(fromCells,lowerrightUp)) fromCellUpperleftRight <- as.integer(intersect(fromCells,upperleftRight)) fromCellUpperrightUnder <- as.integer(intersect(fromCells,upperrightUnder)) fromCellLowerleftRight <- as.integer(intersect(fromCells,lowerleftRight)) fromCellLowerrightLeft <- as.integer(intersect(fromCells,lowerrightLeft)) knight <- c(-2*nCols-1, -2*nCols+1, -nCols-2, -nCols+2, nCols-2, nCols+2, 2*nCols-1, 2*nCols+1) coreInnerFromToKnight <- .cs(fromCellsCoreInner, knight) upperInnerFromToKnight <- .cs(fromCellsUpperInner, knight[3:8]) lowerInnerFromToKnight <- .cs(fromCellsLowerInner, knight[1:6]) leftInnerFromToKnight <- .cs(fromCellsLeftInner, knight[c(1,2,4,6:8)]) rightInnerFromToKnight <- .cs(fromCellsRightInner, knight[c(1:3,5,7,8)]) upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knight[c(4,6:8)]) upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knight[c(3,5,7,8)]) lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knight[c(1,2,4,6)]) lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knight[c(1:3,5)]) leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knight[c(2,4,6,8)]) rightOuterFromToKnight <- .cs(fromCellsRightOuter, knight[c(1,3,5,7)]) upperOuterFromToKnight <- .cs(fromCellsUpperOuter, knight[5:8]) lowerOuterFromToKnight <- .cs(fromCellsLowerOuter, knight[1:4]) upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knight[c(4,6,8)]) upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knight[c(5,7,8)]) lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knight[c(2,4,6)]) lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knight[c(1,3,5)]) upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knight[6:8]) upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knight[c(3,5,7)]) lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knight[c(1,2,4)]) lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knight[1:3]) upperleftFromToKnight <- .cs(fromCellUpperleft, knight[c(6,8)]) upperrightFromToKnight <- .cs(fromCellUpperright, knight[c(5,7)]) lowerleftFromToKnight <- .cs(fromCellLowerleft, knight[c(2,4)]) lowerrightFromToKnight <- .cs(fromCellLowerright, knight[c(1,3)]) fromto3 <- rbind(coreInnerFromToKnight, upperInnerFromToKnight, lowerInnerFromToKnight, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperOuterFromToKnight, lowerOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight) fromto3 <- subset(fromto3,fromto3[,2] %in% toCells) if (outerMeridianConnect) { knightLeft <- c(-nCols-1, -2, +2*nCols-2, 3*nCols-1) knightRight <- c(-3*nCols+1, -2*nCols+2, +2, nCols+1) leftInnerFromToKnight <- .cs(fromCellsLeftInner, knightLeft[c(2,3)]) rightInnerFromToKnight <- .cs(fromCellsRightInner, knightRight[c(2,3)]) upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knightLeft[c(2,3)]) upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knightRight[c(2,3)]) lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knightLeft[c(2,3)]) lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knightRight[c(2,3)]) leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knightLeft) rightOuterFromToKnight <- .cs(fromCellsRightOuter, knightRight) upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knightLeft[2:4]) upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knightRight[3]) lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knightLeft[1:3]) lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knightRight[1:3]) upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knightLeft[c(3)]) upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knightRight[2:4]) lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knightLeft[2]) lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knightRight[2]) upperleftFromToKnight <- .cs(fromCellUpperleft, knightLeft[c(3,4)]) upperrightFromToKnight <- .cs(fromCellUpperright, knightRight[c(3,4)]) lowerleftFromToKnight <- .cs(fromCellLowerleft, knightLeft[c(1,2)]) lowerrightFromToKnight <- .cs(fromCellLowerright, knightRight[c(1,2)]) fromto3 <- rbind(fromto3, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight) } fromto3 <- subset(fromto3,fromto3[,2] %in% toCells) fromto <- rbind(fromto,fromto3) } colnames(fromto) <- c("from","to") return(fromto) } .adjBishop <- function(raster, fromCells, toCells, outerMeridianConnect) { nCols <- ncol(raster) nCells <- ncell(raster) left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) right <- seq(2*nCols,nCells-nCols,by=nCols) upper <- 2:(nCols-1) lower <- seq((nCells-nCols+2),(nCells-1),by=1) upperleft <- 1 upperright <- nCols lowerleft <- nCells-nCols+1 lowerright <- nCells fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright)))) fromCellsUpper <- as.integer(intersect(fromCells,upper)) fromCellsLower <- as.integer(intersect(fromCells,lower)) fromCellsLeft <- as.integer(intersect(fromCells,left)) fromCellsRight <- as.integer(intersect(fromCells,right)) fromCellUpperleft <- as.integer(intersect(fromCells,upperleft)) fromCellUpperright <- as.integer(intersect(fromCells,upperright)) fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft)) fromCellLowerright <- as.integer(intersect(fromCells,lowerright)) bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1)) coreFromToBishop <- .cs(fromCellsCore,bishop) upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4]) lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2]) leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)]) rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)]) upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4]) upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3]) lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2]) lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1]) fromto <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop) if (outerMeridianConnect) { meridianFromLeft <- rbind( .cs(fromCellsLeft,c(2*nCols-1,-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1)) ) meridianFromRight <- rbind( cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))), cbind(fromCellUpperright,as.integer(fromCellUpperright+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1)) ) fromto <- rbind(fromto,meridianFromLeft,meridianFromRight) } fromto <- subset(fromto,fromto[,2] %in% toCells) return(fromto) } raster/R/alignExtent.R0000644000176200001440000000626414160021141014356 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 alignExtent <- function(extent, object, snap='near') { snap <- tolower(snap) stopifnot(snap %in% c('near', 'in', 'out')) extent <- extent(extent) if (!inherits(object, 'BasicRaster')) { stop('object should inherit from BasicRaster') } res <- res(object) orig <- origin(object) # snap points to pixel boundaries if (snap == 'near') { xmn <- round((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- round((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- round((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- round((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } else if (snap == 'out') { xmn <- floor((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- ceiling((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- floor((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- ceiling((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } else if (snap == 'in') { xmn <- ceiling((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- floor((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- ceiling((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- floor((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } if (xmn == xmx) { if (xmn <= extent@xmin) { xmx <- xmx + res[1] } else { xmn <- xmn - res[1] } } if (ymn == ymx) { if (ymn <= extent@ymin) { ymx <- ymx + res[2] } else { ymn <- ymn - res[2] } } e <- extent(xmn, xmx, ymn, ymx) #intersect(e, extent(object)) return(e) } .Old.alignExtent <- function(extent, object) { object <- raster(object) oldext <- extent(object) e <- extent(extent) e@xmin <- min(e@xmin, oldext@xmin) e@xmax <- max(e@xmax, oldext@xmax) e@ymin <- min(e@ymin, oldext@ymin) e@ymax <- max(e@ymax, oldext@ymax) col <- colFromX(object, e@xmin) mn <- xFromCol(object, col) - 0.5 * xres(object) mx <- xFromCol(object, col) + 0.5 * xres(object) if (abs(e@xmin - mn) > abs(e@xmin - mx)) { e@xmin <- mx } else { e@xmin <- mn } col <- colFromX(object, e@xmax) if (is.na(col)) mn <- xFromCol(object, col) - 0.5 * xres(object) mx <- xFromCol(object, col) + 0.5 * xres(object) if (abs(e@xmax - mn) > abs(e@xmax - mx)) { e@xmax <- mx } else { e@xmax <- mn } row <- rowFromY(object, e@ymin) mn <- yFromRow(object, row) - 0.5 * yres(object) mx <- yFromRow(object, row) + 0.5 * yres(object) if (abs(e@ymin - mn) > abs(e@ymin - mx)) { e@ymin <- mx } else { e@ymin <- mn } row <- rowFromY(object, e@ymax) mn <- yFromRow(object, row) - 0.5 * yres(object) mx <- yFromRow(object, row) + 0.5 * yres(object) if (abs(e@ymax - mn) > abs(e@ymax - mx)) { e@ymax <- mx } else { e@ymax <- mn } if ( e@ymin == e@ymax ) { if (oldext@ymax > e@ymax) { e@ymax = e@ymax + yres(object) } if (oldext@ymin < e@ymin) { e@ymin = e@ymin - yres(object) } } if ( e@xmin == e@xmax ) { if (oldext@xmax > e@xmax) { e@xmax = e@xmax + xres(object) } if (oldext@xmin < e@xmin) { e@xmin = e@xmin - xres(object) } } return(e) } raster/R/boxplot.R0000644000176200001440000000241714160021141013557 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 setMethod('boxplot', signature(x='RasterStackBrick'), function(x, maxpixels=100000, ...) { nl <- nlayers(x) cn <- names(x) if ( canProcessInMemory(x)) { x <- getValues(x) } else { warning('taking a sample of ', maxpixels, ' cells') x <- sampleRegular(x, maxpixels, useGDAL=TRUE) } colnames(x) <- cn boxplot(x, ...) } ) setMethod('boxplot', signature(x='RasterLayer'), function(x, y=NULL, maxpixels=100000, ...) { if (is.null(y)) { cn <- names(x) if ( canProcessInMemory(x)) { x <- getValues(x) } else { warning('taking a sample of ', maxpixels, ' cells') x = sampleRegular(x, maxpixels, useGDAL=TRUE) } x <- matrix(x) colnames(x) <- cn boxplot(x, ...) } else { s <- stack(x, y) if ( canProcessInMemory(s)) { s <- getValues(s) } else { warning('taking a sample of ', maxpixels, ' cells') s <- sampleRegular(s, maxpixels, useGDAL=TRUE) } cn <- colnames(s) if (is.null(cn)) { #apparently this can happen. cn <- c('layer1', 'layer2') colnames(s) <- cn } f <- stats::as.formula(paste(cn[1], '~', cn[2])) boxplot(f, data=s, ...) } } ) raster/R/gdal.R0000644000176200001440000000203214160021141012770 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 .requireRgdal <- function(stopIfAbsent=TRUE) { y <- getOption('rasterGDALLoaded') suppressWarnings(x <- isTRUE( try( requireNamespace("rgdal", quietly=TRUE ) ) )) if (! isTRUE(y) ) { if (x) { #pkg.info <- utils::packageDescription('rgdal') #test <- utils::compareVersion(pkg.info[["Version"]], "0.7-21") > 0 #if (!test) { # stop('you use rgdal version: ', pkg.info[["Version"]], '\nYou need version 0.7-22 or higher') #} options('rasterGDALLoaded'=TRUE) return(TRUE) } else if (stopIfAbsent) { stop("package 'rgdal' is not available") } else { return(FALSE) } } return(TRUE) } .useproj6 <- function() { pkg.info <- utils::packageDescription('rgdal') new_rgdal <- utils::compareVersion(pkg.info[["Version"]], "1.5-7") > 0 if (new_rgdal) { if (rgdal::new_proj_and_gdal()) { return (TRUE) } else { return (FALSE) } } else { return (FALSE) } } raster/R/intersect_sp.R0000644000176200001440000002455014160235776014621 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 .checkGEOS <- function() { stopifnot(requireNamespace("rgeos")) gval <- rgeos::get_RGEOS_CheckValidity() rgeos::set_RGEOS_CheckValidity(2L) gval } setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) # threshold <- get_RGEOS_polyThreshold() # on.exit(set_RGEOS_polyThreshold(threshold)) # minarea <- min(apply(bbox(union(extent(x), extent(y))), 1, diff) / 1000000, 0.00001) # set_RGEOS_polyThreshold(minarea) # slivers <- get_RGEOS_dropSlivers() # on.exit(set_RGEOS_dropSlivers(slivers)) # set_RGEOS_dropSlivers(TRUE) x <- sp::spChFIDs(x, as.character(1:length(x))) y <- sp::spChFIDs(y, as.character(1:length(y))) subs <- rgeos::gIntersects(x, y, byid=TRUE) if (sum(subs)==0) { warning('polygons do not intersect') return(NULL) } xdata <-.hasSlot(x, 'data') ydata <-.hasSlot(y, 'data') dat <- NULL if (xdata & ydata) { nms <- .goodNames(c(colnames(x@data), colnames(y@data))) colnames(x@data) <- xnames <- nms[1:ncol(x@data)] colnames(y@data) <- ynames <- nms[(ncol(x@data)+1):length(nms)] dat <- cbind(x@data[NULL, ,drop=FALSE], y@data[NULL, ,drop=FALSE]) } else if (xdata) { dat <- x@data[NULL, ,drop=FALSE] xnames <- colnames(dat) } else if (ydata) { dat <- y@data[NULL, ,drop=FALSE] ynames <- colnames(dat) } subsx <- apply(subs, 2, any) subsy <- apply(subs, 1, any) int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_lower_td=TRUE) # if (inherits(int, "SpatialCollections")) { # if (is.null(int@polyobj)) { # merely touching, no intersection # #warning('polygons do not intersect') # return(NULL) # } # int <- int@polyobj # } if (!inherits(int, 'SpatialPolygons')) { # warning('polygons do not intersect') return(NULL) } if (!is.null(dat)) { ids <- do.call(rbind, strsplit(row.names(int), ' ')) rows <- 1:length(ids[,1]) if (xdata) { idsx <- match(ids[,1], rownames(x@data)) dat[rows, xnames] <- x@data[idsx, ] } if (ydata) { idsy <- match(ids[,2], rownames(y@data)) dat[rows, ynames] <- y@data[idsy, ] } rownames(dat) <- 1:nrow(dat) int <- sp::spChFIDs(int, as.character(1:nrow(dat))) int <- sp::SpatialPolygonsDataFrame(int, dat) } if (length(int) > 0) { w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) j <- rgeos::gIsValid(int, byid=TRUE, reason=FALSE) if (!all(j)) { bad <- which(!j) for (i in bad) { # it could be that a part of a polygon is a sliver, but that other parts are OK a <- sp::disaggregate(int[i, ]) if (length(a) > 1) { jj <- which(rgeos::gIsValid(a, byid=TRUE, reason=FALSE)) a <- a[jj, ] if (length(a) > 0) { int@polygons[i] <- aggregate(a)@polygons j[i] <- TRUE } } } int <- int[j,] } } int@proj4string <- prj int } ) setMethod('intersect', signature(x='SpatialPolygons', y='SpatialLines'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) gval <- rgeos::get_RGEOS_CheckValidity() if (gval != 2) { on.exit(rgeos::set_RGEOS_CheckValidity(gval)) rgeos::set_RGEOS_CheckValidity(2L) } prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) subs <- rgeos::gIntersects(x, y, byid=TRUE) if (sum(subs)==0) { warning('lines and polygons do not intersect') return(NULL) } if (inherits(x, "Spatial")) { x@proj4string <- prj } i <- which(apply(subs, 2, any)) x[i, ] } ) setMethod('intersect', signature(x='SpatialLines', y='SpatialPolygons'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) gval <- rgeos::get_RGEOS_CheckValidity() if (gval != 2) { on.exit(rgeos::set_RGEOS_CheckValidity(gval)) rgeos::set_RGEOS_CheckValidity(2L) } prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) x <- sp::spChFIDs(x, as.character(1:length(x))) y <- sp::spChFIDs(y, as.character(1:length(y))) if (! identical( .proj4string(x), .proj4string(y)) ) { warning('non identical crs') y@proj4string <- x@proj4string } subs <- rgeos::gIntersects(x, y, byid=TRUE) if (sum(subs)==0) { warning('lines and polygons do not intersect') return(NULL) } xdata <-.hasSlot(x, 'data') ydata <-.hasSlot(y, 'data') dat <- NULL if (xdata & ydata) { nms <- .goodNames(c(colnames(x@data), colnames(y@data))) colnames(x@data) <- xnames <- nms[1:ncol(x@data)] colnames(y@data) <- ynames <- nms[(ncol(x@data)+1):length(nms)] dat <- cbind(x@data[NULL, ,drop=FALSE], y@data[NULL, ,drop=FALSE]) } else if (xdata) { dat <- x@data[NULL, ,drop=FALSE] xnames <- colnames(dat) } else if (ydata) { dat <- y@data[NULL, ,drop=FALSE] ynames <- colnames(dat) } subsx <- apply(subs, 2, any) subsy <- apply(subs, 1, any) int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_lower_td=TRUE) # if (inherits(int, "SpatialCollections")) { # if (is.null(int@polyobj)) { # merely touching, no intersection # #warning('polygons do not intersect') # return(NULL) # } # int <- int@polyobj # } if (!inherits(int, 'SpatialLines')) { # warning('polygons do not intersect') return(NULL) } if (!is.null(dat)) { ids <- do.call(rbind, strsplit(row.names(int), ' ')) rows <- 1:length(ids[,1]) if (xdata) { idsx <- match(ids[,1], rownames(x@data)) dat[rows, xnames] <- x@data[idsx, ] } if (ydata) { idsy <- match(ids[,2], rownames(y@data)) dat[rows, ynames] <- y@data[idsy, ] } rownames(dat) <- 1:nrow(dat) int <- sp::spChFIDs(int, as.character(1:nrow(dat))) int <- sp::SpatialLinesDataFrame(int, dat) } if (length(int) > 0) { j <- which(rgeos::gIsValid(int, byid=TRUE, reason=FALSE)) int <- int[j, ] } int@proj4string <- prj int } ) setMethod('intersect', signature(x='SpatialLines', y='SpatialLines'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) gval <- rgeos::get_RGEOS_CheckValidity() if (gval != 2) { on.exit(rgeos::set_RGEOS_CheckValidity(gval)) rgeos::set_RGEOS_CheckValidity(2L) } prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) xdata <-.hasSlot(x, 'data') ydata <-.hasSlot(y, 'data') x <- sp::spChFIDs(x, as.character(1:length(x))) y <- sp::spChFIDs(y, as.character(1:length(y))) if (! any(c(xdata, ydata))) { z <- rgeos::gIntersection(x, y, byid=TRUE) if (is.null(z)) { z <- sp::SpatialPoints(cbind(0,0), proj4string=prj) z <- sp::SpatialPointsDataFrame(z,data.frame(x=0, y=0)) return( z[-1, ] ) } rn <- rownames(z@coords) d <- data.frame(matrix(as.integer(unlist(strsplit(rn, ' '))), ncol=2, byrow=TRUE)) colnames(d) <- c('x', 'y') rownames(z@coords) <- NULL z <- sp::SpatialPointsDataFrame(z, d) z@proj4string <- prj return(z) } z <- rgeos::gIntersection(y, x, byid=TRUE) if (is.null(z)) { z <- sp::SpatialPoints(cbind(0,0), proj4string=prj) return( z[-1, ] ) } if (inherits(z, 'SpatialCollections')) { z <- z@pointobj } s <- strsplit(sp::spChFIDs(z), ' ') s <- matrix(as.integer(unlist(s)), ncol=2, byrow=TRUE) if (xdata & ydata) { nms <- .goodNames(c(colnames(x@data), colnames(y@data))) xnames <- nms[1:ncol(x@data)] ynames <- nms[(ncol(x@data)+1):length(nms)] xd <- x@data[s[,2], ] yd <- y@data[s[,1], ] d <- cbind(xd, yd) colnames(d) <- c(xnames, ynames) } else if (xdata) { d <- x@data[s[,2], ] } else if (ydata) { d <- y@data[s[,1], ] } row.names(d) <- NULL row.names(z) <- as.character(1:length(z)) z@proj4string <- prj sp::SpatialPointsDataFrame(z, d) } ) setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPoints'), function(x, y) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) gval <- rgeos::get_RGEOS_CheckValidity() if (gval != 2) { on.exit(rgeos::set_RGEOS_CheckValidity(gval)) rgeos::set_RGEOS_CheckValidity(2L) } prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) i <- rgeos::gIntersects(x, y, byid=TRUE) i <- which(apply(i, 2, any)) if (inherits(x, "Spatial")) { x@proj4string <- prj } x[i, ] } ) setMethod('intersect', signature(x='SpatialPoints', y='ANY'), function(x, y) { if (inherits(y, 'SpatialLines')) { stop('intersect of SpatialPoints and Lines is not supported because of numerical inaccuracies.\nUse "buffer", to create SpatialPoygons from the lines and use that in intersect.\nOr see rgeos::gIntersection') } if (inherits(y, 'SpatialPolygons')) { valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) gval <- rgeos::get_RGEOS_CheckValidity() if (gval != 2) { on.exit(rgeos::set_RGEOS_CheckValidity(gval)) rgeos::set_RGEOS_CheckValidity(2L) } prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) i <- rgeos::gIntersects(y, x, byid=TRUE) j <- cbind(1:length(y), rep(1:length(x), each=length(y)), as.vector(t(i))) j <- j[j[,3] == 1, -3, drop=FALSE] j <- j[order(j[,2]), ,drop=FALSE] x <- x[j[,2], ] if (.hasSlot(y, 'data')) { d <- y@data[j[,1], ] if (!.hasSlot(x, 'data')) { x <- sp::SpatialPointsDataFrame(x, d) } else { x@data <- cbind(x@data, d) } } x@proj4string <- prj return(x) } else { y <- extent(y) xy <- sp::coordinates(x)[,1:2,drop=FALSE] i <- xy[,1] >= y@xmin & xy[,1] <= y@xmax & xy[,2] >= y@ymin & xy[,2] <= y@ymax x[i, ] } } ) setMethod('intersect', signature(x='SpatialPolygons', y='ANY'), function(x, y) { y <- extent(y) y <- as(y, 'SpatialPolygons') intersect(x, y) } ) raster/R/dataProperties.R0000644000176200001440000000315614160021141015057 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 #dataSize <- function(object) {return(object@file@datasize)} dataSize <- function(object) { if (class(object) != 'character'){ object <- dataType(object) } return( as.integer (substr(object, 4, 4)) ) } dataSigned <- function(object) { if (class(object) != 'character') { object <- dataType(object) } ifelse(substr(object, 5, 5) == 'U', FALSE, TRUE ) } .shortDataType <- function(object) { if (class(object) != 'character') { object <- dataType(object) } return( substr(object, 1, 3)) } dataType <- function(x) { if (inherits(x, 'RasterStack')) { return(sapply(x@layers, function(x) x@file@datanotation)) } else { return(x@file@datanotation) } } ..dataIndices <- function(object) { # return(object@data@indices) } fromDisk <- function(x) { if (inherits( x, 'RasterStack' )) { return( all( sapply( x@layers, function(x) x@data@fromdisk ))) } else { return( x@data@fromdisk ) } } setMethod("inMemory", signature(x="BasicRaster"), function(x) { if (class(x) == 'BasicRaster') { return(TRUE) } if (inherits( x, 'RasterStack' )) { return( all( sapply( x@layers, function(x) x@data@inmemory ))) } else { return( x@data@inmemory ) } } ) setMethod("hasValues", signature(x="BasicRaster"), function(x) { if (class(x) == 'BasicRaster') { return(FALSE) } if (inherits(x, 'RasterStack')) { if (nlayers(x) > 0) return(TRUE) else return(FALSE) } if ( fromDisk(x) | inMemory(x) ) { return(TRUE) } else { return(FALSE) } } ) raster/R/quad.R0000644000176200001440000000233014160021141013014 0ustar liggesusers # if (!isGeneric(".quad")) { # setGeneric(".quad", function(x, ...) # standardGeneric(".quad")) # } # setMethod('.quad', signature(x='missing'), # function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, levels=1, steps=1, crs) { # e <- extent(xmn, xmx, ymn, ymx) # if (missing(crs)) { # if (e@xmin > -400 & e@xmax < 400 & e@ymin > -90.1 & e@ymax < 90.1) { # crs <- "+proj=longlat +datum=WGS84" # } else { # crs <- "" # } # } # b <- .quad(e, nrows=nrows, ncols=ncols, crs=crs, levels=levels, steps=steps) # return(b) # } # ) # setMethod('.quad', signature(x='Extent'), # function(x, nrows=10, ncols=10, levels=1, steps=1, crs='') { # bb <- extent(x) # nr = as.integer(round(nrows)) # nc = as.integer(round(ncols)) # if (nc < 1) { stop("ncols should be > 0") } # if (nr < 1) { stop("nrows should be > 0") } # b <- methods::new("RasterQuadBrick", extent=bb, ncols=nc, nrows=nr) # projection(b) <- sp::CRS # levels <- as.integer(max(round(levels), 0)) # steps <- as.integer(max(round(steps), 0)) # nl <- levels * steps # b@nlevels <- levels # b@nsteps <- steps # b@data@nlayers <- as.integer(nl) # return(b) # } # ) raster/R/readRasterBrick.R0000644000176200001440000001644414160021141015144 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 1.0 # Licence GPL v3 .readRasterBrickValues <- function(object, startrow, nrows=1, startcol=1, ncols=ncol(object)) { if (nrows < 1) { stop("nrows should be > 1") } startrow <- min(max(1, round(startrow)), object@nrows) endrow <- min(object@nrows, startrow+nrows-1) nrows <- endrow - startrow + 1 if (ncols < 1) { stop("ncols should be > 1") } startcol <- min(max(1, round(startcol)), object@ncols) endcol <- min(object@ncols, startcol+ncols-1) ncols <- endcol - startcol + 1 if (.isNativeDriver(object@file@driver)) { getBSQData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) { if (c==1 & ncols==raster@ncols ) { if (r==1 & nrows==raster@nrows) { nc <- nrows*ncols*raster@data@nlayers seek(raster@file@con, raster@file@offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) dim(result) <- c(nrows*ncols, raster@data@nlayers) } else { ncells <- nrows*ncols result <- matrix(nrow=ncells, ncol=raster@data@nlayers) for (b in 1:raster@data@nlayers) { offset <- raster@file@offset + (b-1) * raster@ncols * raster@nrows + (r-1) * raster@ncols seek(raster@file@con, offset * dsize) result[,b] <- readBin(raster@file@con, what=dtype, n=ncells, dsize, dsign, endian=raster@file@byteorder) } } } else { nc <- nrows*ncols result <- matrix(nrow=nc, ncol=raster@data@nlayers) res <- matrix(ncol=nrows, nrow=ncols) for (b in 1:raster@data@nlayers) { offset <- raster@file@offset + (b-1) * raster@ncols * raster@nrows + (r-1) * raster@ncols + (c-1) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols seek(raster@file@con, off * dsize) res[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } result[,b] <- as.vector(res) } } return( result ) } getBilData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) { if (c==1 & ncols==raster@ncols ) { nc <- nrows*ncols*raster@data@nlayers if (r==1 & nrows==raster@nrows) { seek(raster@file@con, raster@file@offset * dsize) res <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } else { offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) seek(raster@file@con, offset * dsize) res <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } } else { res <- matrix(ncol=nrows*raster@data@nlayers, nrow=ncols) offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) + (c-1) for (i in 1:ncol(res)) { off <- offset + (i-1) * raster@ncols seek(raster@file@con, off * dsize) res[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } res <- as.vector(res) } result <- matrix(nrow=ncols*nrows, ncol=nlayers(raster)) dim(res) <- c(ncols, raster@data@nlayers*nrows) a <- rep(1:raster@data@nlayers, nrows) for (b in 1:raster@data@nlayers) { result[,b] <- as.vector(res[,a==b]) } return(result) } getBipData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) { if (c==1 & ncols==raster@ncols ) { nc <- nrows*ncols*raster@data@nlayers if (r==1 & nrows==raster@nrows) { seek(raster@file@con, raster@file@offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } else { offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) seek(raster@file@con, offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } } else { nc <- ncols*raster@data@nlayers result <- matrix(ncol=nrows, nrow=ncols*raster@data@nlayers) offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) for (i in 1:nrows) { off <- offset + (i-1) * raster@data@nlayers * raster@ncols + (c-1) * raster@data@nlayers seek(raster@file@con, off * dsize) result[,i] <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } result <- as.vector(result) } dim(result) <- c(raster@data@nlayers, nrows*ncols) t(result) } if (! object@file@toptobottom ) { stop('bottom-to-top data not supported for RasterBrick objects') } dtype <- substr(object@file@datanotation, 1, 3) if (dtype == "INT" | dtype == "LOG" ) { dtype <- "integer" } else { dtype <- "numeric" } dsize <- dataSize(object@file@datanotation) dsign <- dataSigned(object@file@datanotation) if (dsize > 2) { dsign <- TRUE } is.open <- object@file@open if (!is.open) { object <- readStart(object) } if (object@data@nlayers > 1) { bo <- object@file@bandorder if (bo == 'BSQ') { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } else if (bo == 'BIL') { result <- getBilData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } else if (bo == 'BIP') { result <- getBipData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } } else { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } if (!is.open) { object <- readStop(object) } # result[is.nan(result)] <- NA if (object@file@datanotation == 'INT4U') { i <- !is.na(result) & result < 0 result[i] <- 2147483647 - result[i] } if (dtype == 'numeric') { result[result <= (0.999999 * object@file@nodatavalue)] <- NA result[is.nan(result)] <- NA } else { result[result == object@file@nodatavalue ] <- NA } if (dtype == 'logical') { result <- as.logical(result) } } else if (object@file@driver == 'netcdf') { result <- .readRowsBrickNetCDF(object, startrow, nrows, startcol, ncols) # } else if (object@file@driver == 'big.matrix') { # # b <- attr(object@file, 'big.matrix') # start <- cellFromRowCol(object, startrow, startcol) # end <- cellFromRowCol(object, endrow, endcol) # result <- b[start:end, ] } else { #use GDAL offs <- c((startrow - 1), (startcol - 1)) reg <- c(nrows, ncols) con <- rgdal::GDAL.open(object@file@name, silent = TRUE) # result <- rgdal::getRasterData(con, offset=offs, region.dim=reg) # result <- do.call(cbind, lapply(1:nlayers(object), function(i) as.vector(result[,,i]))) # just as fast, it seems: result <- matrix(nrow = ncols * nrows, ncol = nlayers(object)) for (b in 1:object@data@nlayers) { result[, b] <- rgdal::getRasterData(con, offset = offs, region.dim = reg, band = b) } rgdal::closeDataset(con) result[result == object@file@nodatavalue] <- NA } if (object@data@gain != 1 | object@data@offset != 0) { result <- result * object@data@gain + object@data@offset } colnames(result) <- names(object) return(result) } raster/R/replaceProperties.R0000644000176200001440000000257214160021141015562 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("ncol<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { dim(x) <- c(nrow(x), value) return(x) } ) setMethod("nrow<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { dim(x) <- c(value, ncol(x)) return(x) } ) setMethod("xmin<-", signature('Extent', 'numeric'), function(x, ..., value) { x@xmin <- value return(x) } ) setMethod("xmax<-", signature('Extent', 'numeric'), function(x, ..., value) { x@xmax <- value return(x) } ) setMethod("ymin<-", signature('Extent', 'numeric'), function(x, ..., value) { x@ymin <- value return(x) } ) setMethod("ymax<-", signature('Extent', 'numeric'), function(x, ..., value) { x@ymax <- value return(x) } ) setMethod("xmin<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@xmin <- value return(x) } ) setMethod("xmax<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@xmax <- value return(x) } ) setMethod("ymin<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@ymin <- value return(x) } ) setMethod("ymax<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@ymax <- value return(x) } ) raster/R/origin.R0000644000176200001440000000205314160021141013353 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod('origin', signature(x='BasicRaster'), function(x, ...) { e <- x@extent r <- res(x) x <- e@xmin - r[1]*(round(e@xmin / r[1])) y <- e@ymax - r[2]*(round(e@ymax / r[2])) if (isTRUE(all.equal((r[1] + x), abs(x)))) { x <- abs(x) } if (isTRUE(all.equal((r[2] + y), abs(y)))) { y <- abs(y) } return(c(x, y)) } ) setMethod("origin<-", signature('BasicRaster'), function(x, value) { value <- rep(value, length.out=2) dif <- value - origin(x) res <- res(x) dif[1] <- dif[1] %% res[1] dif[2] <- dif[2] %% res[2] for (i in 1:2) { if (dif[i] < 0) { if ((dif[i] + res[i]) < abs(dif[i])) { dif[i] <- dif[i] + res[i] } } else { if (abs(dif[i] - res[i]) < dif[i]) { dif[i] <- dif[i] - res[i] } } } e <- extent(x) e@xmin <- e@xmin + dif[1] e@xmax <- e@xmax + dif[1] e@ymin <- e@ymin + dif[2] e@ymax <- e@ymax + dif[2] x@extent <- e return(x) } ) raster/R/coerce.R0000644000176200001440000003274714160021141013341 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 ### from terra setAs("SpatRaster", "Raster", function(from) { b <- sources(from, bands=TRUE) nl <- nlyr(from) e <- as.vector(ext(from)) prj <- crs(from) if (nl == 1) { if (b$source == "") { r <- raster::raster(ncols=ncol(from), nrows=nrow(from), crs=crs(from), xmn=e[1], xmx=e[2], ymn=e[3], ymx=e[4]) if (hasValues(from)) { raster::values(r) <- values(from) } } else { r <- raster::raster(b$source, band=b$bands) } } else { usid <- unique(b$sid) if ((length(usid) == 1) & (b$source[1] != "")) { if ((nl == nrow(b)) && (b$bands[1] == 1) && (all(diff(b$bands) == 1))) { r <- raster::brick(b$source[1]) } else { r <- raster::stack(b$source[1], bands=b$bands) } } else if (all(b$source=="")) { r <- raster::brick(ncol=ncol(from), nrow=nrow(from), crs=prj, xmn=e[1], xmx=e[2], ymn=e[3], ymx=e[4], nl=nlyr(from)) if (hasValues(from)) { raster::values(r) <- values(from) } } else { x <- raster::raster(ncol=ncol(from), nrow=nrow(from), crs=prj, xmn=e[1], xmx=e[2], ymn=e[3], ymx=e[4]) r <- list() for (i in 1:nl) { if (b$source[i] == "") { r[[i]] <- raster::setValues(x, values(from[[i]])) } else { bands <- b$bands[b$sid == i] r[[i]] <- raster::stack(b$source[i], bands=bands) } } r <- raster::stack(r) } } try(levels(r) <- cats(from), silent=TRUE) try(names(r) <- names(from)) return(r) } ) ## to terra .fromRasterLayerBrick <- function(from) { if (raster::fromDisk(from)) { f <- raster::filename(from) if (from@file@driver == "netcdf") { v <- attr(from@data, "zvar") r <- rast(f, v) } else { r <- try(rast(f), silent=TRUE) if (inherits(r, "try-error")) { r <- rast(from + 0) levs <- levels(from)[[1]] if (!is.null(levs)) { levels(r) <- levs } } crs(r) <- raster::wkt(from) } if (from@file@NAchanged) { NAflag(r) <- from@file@nodatavalue } } else { crsobj <- from@crs if (is.na(crsobj)) { prj <- "" } else { crscom <- comment(crsobj) if (is.null(crscom)) { prj <- crsobj@projargs } else { prj <- crscom } } r <- rast( nrows=nrow(from), ncols=ncol(from), nlyrs=raster::nlayers(from), crs=prj, extent=raster::extent(from)) if (raster::hasValues(from)) { values(r) <- values(from) } levs <- levels(from)[[1]] if (!is.null(levs)) { levels(r) <- levs } } names(r) <- names(from) r } .fromRasterStack <- function(from) { x <- from[[1]] n <- raster::nbands(x) nl <- raster::nlayers(from) if ((n > 1) & (n == nl)) { ff <- lapply(1:nl, function(i) { raster::filename(from[[i]]) }) if (length(unique(ff)) == 1) { r <- rast(raster::filename(x)) return(r) } } s <- lapply(1:raster::nlayers(from), function(i) { x <- from[[i]] .fromRasterLayerBrick(x)[[raster::bandnr(x)]] }) s <- do.call(c, s) names(s) <- names(from) s } setAs("Raster", "SpatRaster", function(from) { if (inherits(from, "RasterLayer") || inherits(from, "RasterBrick")) { .fromRasterLayerBrick(from) } else { .fromRasterStack(from) } } ) # To sp pixel/grid objects setAs("Raster", "GridTopology", function(from) { rs <- res(from) orig <- bbox(from)[,1] + 0.5 * rs sp::GridTopology(orig, rs, dim(from)[2:1] ) } ) setAs("GridTopology", "RasterLayer", function(from) { raster(extent(from), nrows=from@cells.dim[2], ncols=from@cells.dim[1]) } ) setAs("Raster", "SpatialPixels", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the 'rectify' function") } sp <- rasterToPoints(from, fun=NULL, spatial=FALSE) r <- raster(from) sp <- sp::SpatialPoints(sp[,1:2,drop=FALSE], proj4string= .getCRS(r)) grd <- as(r, "GridTopology") sp::SpatialPixels(points=sp, grid=grd) } ) setAs("Raster", "SpatialPixelsDataFrame", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the 'rectify' function") } v <- rasterToPoints(from, fun=NULL, spatial=FALSE) r <- raster(from) sp <- sp::SpatialPoints(v[,1:2,drop=FALSE], proj4string= .getCRS(r)) grd <- as(r, "GridTopology") if (ncol(v) > 2) { v <- data.frame(v[, 3:ncol(v), drop = FALSE]) if (any(is.factor(from))) { f <- levels(from) for (i in 1:length(f)) { if (!is.null(f[[i]])) { v[,i] <- as.factor(f[[i]][v[,i]]) } } } sp::SpatialPixelsDataFrame(points=sp, data=v, grid=grd) } else { warning("object has no values, returning a 'SpatialPixels' object") sp::SpatialPixels(points=sp, grid=grd) } } ) setAs("Raster", "SpatialGrid", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the 'rectify' function") } r <- raster(from) grd <- as(r, "GridTopology") sp::SpatialGrid(grd, proj4string=.getCRS(r)) } ) setAs("Raster", "SpatialGridDataFrame", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the 'rectify' function") } r <- raster(from) grd <- as(r, "GridTopology") if (hasValues(from)) { sp <- sp::SpatialGridDataFrame(grd, proj4string=.getCRS(r), data=as.data.frame(from)) } else { warning("object has no values, returning a 'SpatialGrid' object") sp <- sp::SpatialGrid(grd, proj4string=.getCRS(r)) } sp } ) # To sp vector objects setAs("Raster", "SpatialPolygons", function(from){ r <- rasterToPolygons(from[[1]]) as(r, "SpatialPolygons") } ) setAs("Raster", "SpatialPolygonsDataFrame", function(from){ return( rasterToPolygons(from) ) } ) setAs("Raster", "SpatialPoints", function(from) { sp::SpatialPoints(rasterToPoints(from, spatial=FALSE)[,1:2], proj4string=.getCRS(from)) } ) setAs("Raster", "SpatialPointsDataFrame", function(from) { rasterToPoints(from, spatial=TRUE) } ) setAs("Extent", "SpatialPolygons", function(from){ p <- rbind(c(from@xmin, from@ymin), c(from@xmin, from@ymax), c(from@xmax, from@ymax), c(from@xmax, from@ymin), c(from@xmin, from@ymin) ) sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(p)), "1"))) } ) setAs("Extent", "SpatialLines", function(from){ p <- rbind(c(from@xmin, from@ymin), c(from@xmin, from@ymax), c(from@xmax, from@ymax), c(from@xmax, from@ymin), c(from@xmin, from@ymin) ) sp::SpatialLines(list(sp::Lines(list(sp::Line(p)), "1"))) } ) setAs("Extent", "SpatialPoints", function(from){ p <- cbind( x=c( from@xmin, from@xmin, from@xmax, from@xmax), y=c(from@ymin, from@ymax, from@ymin, from@ymax) ) sp::SpatialPoints(p) } ) # to RasterLayer setAs("SpatialGrid", "RasterLayer", function(from){ return(raster (from)) } ) setAs("SpatialPixels", "RasterLayer", function(from){ return(raster (from)) } ) setAs("SpatialGrid", "BasicRaster", function(from){ to <- methods::new("BasicRaster") to@extent <- extent(from) crs(to) <- from@proj4string dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1]) return(to) } ) setAs("SpatialPixels", "BasicRaster", function(from){ to <- methods::new("BasicRaster") to@extent <- extent(from) crs(to) <- from@proj4string dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1]) return(to) } ) # to RasterStack setAs("SpatialGrid", "RasterStack", function(from){ stack(from) } ) setAs("SpatialPixels", "RasterStack", function(from){ stack(from) } ) # to RasterBrick setAs("SpatialGrid", "RasterBrick", function(from){ return(brick(from)) } ) setAs("SpatialPixels", "RasterBrick", function(from){ return(brick(from)) } ) setAs("STFDF", "RasterBrick", function(from) { time <- from@time nc <- ncol(from@data) r <- raster(from@sp) b <- brick(r, nl=length(time) * nc) b <- setZ(b, rep(time, nc)) # rep changes some time formats names(b) <- paste(rep(colnames(from@data), each=length(time)), as.character(time), sep="") # need to improve this for character, factor variables m <- as.numeric(as.matrix(from@data)) setValues(b, m) } ) setAs("STSDF", "RasterBrick", function(from) { from <- as(from, "STFDF") as(from, "RasterBrick") } ) # Between Raster objects setAs("RasterStack", "RasterLayer", function(from){ return( raster(from)) } ) setAs("RasterBrick", "RasterLayer", function(from){ return( raster(from)) } ) setAs("RasterStack", "RasterBrick", function(from){ return( brick(from)) } ) setAs("RasterBrick", "RasterStack", function(from){ return( stack(from)) } ) setAs("RasterLayer", "RasterStack", function(from){ return( stack(from)) } ) setAs("RasterLayer", "RasterBrick", function(from){ return( brick(from)) } ) setAs("matrix", "RasterLayer", function(from){ return(raster(from)) } ) setAs("RasterLayer", "matrix", function(from){ return( getValues(from, format="matrix")) } ) # "image" .rasterToImage <- function(r) { x <- xFromCol(r,1:ncol(r)) y <- yFromRow(r, nrow(r):1) z <- t(as.matrix(r)[nrow(r):1,]) list(x=x, y=y, z=z) } # spatstat setAs("im", "RasterLayer", function(from) { r <- raster(nrows=from$dim[1], ncols=from$dim[2], xmn=from$xrange[1], xmx=from$xrange[2], ymn=from$yrange[1], ymx=from$yrange[2], crs="") r <- setValues(r, from$v) flip(r, direction="y") } ) # adehabitat setAs("asc", "RasterLayer", function(from) { d <- t(from[]) d <- d[nrow(d):1, ] type <- attr(from, "type") if (type == "factor") { warning("factor type converted to numeric") } cz <- attr(from, "cellsize") xmn <- attr(from, "xll") - 0.5 * cz ymn <- attr(from, "yll") - 0.5 * cz xmx <- xmn + ncol(d) * cz ymx <- ymn + nrow(d) * cz e <- extent(xmn, xmx, ymn, ymx) d <- raster(d) extent(d) = e return(d) } ) setAs("RasterLayer", "asc", function(from) { asc <- getValues(from, format="matrix") asc <- asc[nrow(asc):1, ] attr(asc, "cellsize") <- xres(from) attr(asc, "xll") <- xmin(from) + 0.5 * xres(from) attr(asc, "yll") <- ymin(from) + 0.5 * yres(from) attr(asc, "type") <- "numeric" class(asc) <- "asc" return(asc) } ) setAs("kasc", "RasterBrick", function(from) { names <- colnames(from) cz <- attr(from, "cellsize") ncol <- attr(from, "ncol") nrow <- attr(from, "nrow") xmn <- attr(from, "xll") - 0.5 * cz ymn <- attr(from, "yll") - 0.5 * cz xmx <- xmn + ncol * cz ymx <- ymn + nrow * cz e <- extent(xmn, xmx, ymn, ymx) b <- brick(e, nrow=nrow, ncol=ncol) m = matrix(NA, ncol=ncol(from), nrow=nrow(from)) for (i in 1:ncol(m)) { m[,i] <- as.numeric(from[,i]) } dim(m) <- dim(from) b <- setValues(b, m) names(b) <- names return(b) } ) setAs("kasc", "RasterStack", function(from) { names <- colnames(from) cz <- attr(from, "cellsize") ncol <- attr(from, "ncol") nrow <- attr(from, "nrow") xmn <- attr(from, "xll") - 0.5 * cz ymn <- attr(from, "yll") - 0.5 * cz xmx <- xmn + ncol * cz ymx <- ymn + nrow * cz e <- extent(xmn, xmx, ymn, ymx) r <- raster(e, nrow=nrow, ncol=ncol) r <- setValues(r, as.numeric(from[,1])) names(r) <- names[1] s <- stack(r) if (ncol(from) > 1) { for (i in 2:ncol(from)) { r <- setValues(r, as.numeric(from[,i])) names(r) <- names[i] s <- addLayer(s, r) } } return(s) } ) # kernel density estimate (kde) from package ks setAs("kde", "RasterLayer", function(from) { x <- t(from$estimate) x <- x[nrow(x):1,] raster(x, xmn=min(from$eval.points[[1]]), xmx=max(from$eval.points[[1]]), ymn=min(from$eval.points[[2]]), ymx=max(from$eval.points[[2]]) ) } ) setAs("grf", "RasterBrick", function(from) { x <- from$data if (!is.matrix(x)) { x <- matrix(x) } ncell <- nrow(x) nl <- ncol(x) nc <- nr <- as.integer(sqrt(ncell)) dim(x) <- c(nr, nc, nl) x = aperm(x, perm=c(2,1,3)) b <- brick(x) b <- flip(b, "y") extent(b) <- extent(as.vector(apply(from$coords, 2, range))) b } ) setAs("grf", "RasterLayer", function(from) { x <- from$data if (is.matrix(x)) { x <- x[,1] } ncell <- length(x) nc <- nr <- as.integer(sqrt(ncell)) dim(x) <- c(nr, nc) x <- t(x)[nrow(x):1,] r <- raster(x) extent(r) <- extent(as.vector(apply(from$coords, 2, range))) r } ) # setAs("RasterStackBrick", "big.matrix", # function(from, filename="") { # b <- big.matrix(ncell(from), nlayers(from), backingfile=filename ) # names(b) <- colnames(from) # op <- options("bigmemory.allow.dimnames") # options(bigmemory.allow.dimnames=TRUE) # colnames(b) <- names(from) # options(bigmemory.allow.dimnames=op) # if (canProcessInMemory(from)) { # b[] <- as.matrix(from) # } else { # nc <- ncol(from) # tr <- blockSize(from) # for (i in 1:tr$n) { # start <- ((tr$row[i]-1) * nc) + 1 # end <- start + (tr$nrows[i] * nc) - 1 # b[start:end, ] <- getValues(from, row=tr$row[i], nrows=tr$nrows[i]) # } # } # b # } raster/R/arith_sp.R0000644000176200001440000000145014160021141013675 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod("+", signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ union(e1, e2) } ) setMethod("*", signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ intersect(e1, e2) } ) setMethod("-", signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ erase(e1, e2) } ) #setMethod("^", signature(e1='SpatialPolygons', e2='SpatialPolygons'), # function(e1, e2){ # crop(e1, e2) # } #) setMethod("+", signature(e1='SpatialPoints', e2='SpatialPoints'), function(e1, e2){ bind(e1, e2) } ) setMethod("+", signature(e1='SpatialLines', e2='SpatialLines'), function(e1, e2){ bind(e1, e2) } ) raster/R/hdrWorldFile.R0000644000176200001440000000105314160021141014450 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .worldFile <- function(raster, extension=".wld") { hdrfile <- filename(raster) extension(hdrfile) <- extension thefile <- file(hdrfile, "w") cat(as.character(xres(raster)), "\n", file = thefile) cat("0\n", file = thefile) cat("0\n", file = thefile) cat(-1 * yres(raster), "\n", file = thefile) cat(xmin(raster) + 0.5 * xres(raster), "\n", file = thefile) cat(ymax(raster) - 0.5 * yres(raster), "\n", file = thefile) close(thefile) } raster/R/atan2.R0000644000176200001440000000146214160021141013074 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2011 # Version 1.0 # Licence GPL v3 setMethod("atan2", signature(y='Raster', x='Raster'), function(y, x) { compareRaster(x, y) ny <- nlayers(y) nx <- nlayers(x) nl <- max(ny, nx) if (nl > 1) { r <- brick(x, values=FALSE, nl=nl) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, atan2(getValues(y), getValues(x))) } else { tr <- blockSize(x) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile()) for (i in 1:tr$n) { v <- atan2(getValues(y, row=tr$row[i], nrows=tr$nrows[i]), getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) raster/R/summary.R0000644000176200001440000000414114160021141013561 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("summary")) { setGeneric("summary", function(object, ...) standardGeneric("summary")) } setMethod('summary', signature(object='RasterLayer'), function(object, maxsamp=100000, ...) { if ( inMemory(object) ) { sm <- as.matrix( stats::quantile( values(object), na.rm=TRUE) ) sm <- c(sm, sum(is.na( values(object) ))) } else if ( fromDisk(object) ) { if (ncell(object) > maxsamp) { v <- sampleRegular(object, maxsamp) nas <- round(sum(is.na(v)) * ncell(object) / maxsamp) warning(paste('summary is an estimate based on a sample of ', maxsamp, ' cells (', round(100*maxsamp/ncell(object), 2), '% of all cells)\n', sep='')) } else { v <- getValues(object) nas <- sum(is.na(v)) } sm <- stats::quantile(v, na.rm=TRUE) sm <- c(sm, nas) } else { sm <- NA } values <- matrix(sm, ncol=1, nrow=6) rownames(values) <- c('Min.', '1st Qu.', 'Median', '3rd Qu.', 'Max.', "NA's") colnames(values) <- names(object) return(values) } ) setMethod('summary', signature(object='RasterStackBrick'), function(object, maxsamp=100000, ...) { if ( inMemory(object) & inherits(object, "RasterBrick")) { sm <- apply(object@data@values, 2, quantile, na.rm=TRUE) nas <- apply(is.na(object@data@values), 2, sum) values <- rbind(sm, nas) } else if ( fromDisk(object) ) { nc <- ncell(object) if (nc > maxsamp) { v <- sampleRegular(object, maxsamp) nas <- round(apply(is.na(v), 2, sum) * nc / maxsamp) warning(paste('summary is an estimate based on a sample of ', maxsamp, ' cells (', round(100*maxsamp/nc, 2), '% of all cells)\n', sep='')) } else { v <- getValues(object) nas <- apply(is.na(v), 2, sum) } sm <- apply(v, 2, quantile, na.rm=T) values <- rbind(sm, nas) } else { stop('no cell values associated with this RasterBrick') } rownames(values) <- c('Min.', '1st Qu.', 'Median', '3rd Qu.', 'Max.', "NA's") return(values) } ) raster/R/bind.R0000644000176200001440000002064114160230057013013 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric("bind")) { setGeneric("bind", function(x, y, ...) standardGeneric("bind")) } setMethod('bind', signature(x='data.frame', y='missing'), function(x, y, ..., variables=NULL) { if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } } return(x) } ) setMethod('bind', signature(x='data.frame', y='data.frame'), function(x, y, ..., variables=NULL) { x <- .frbind(x, y) if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } else { variables <- NULL } } dots <- list(...) if (length(dots) > 1) { for (i in 1:length(dots)) { d <- dots[[i]] if (!inherits(d, 'data.frame')) { next } if (!is.null(variables)) { d <- d[, which(colnames(d) %in% variables), drop=FALSE] } if (nrow(d) > 0) { x <- .frbind(x, d) } } } x } ) setMethod('bind', signature(x='matrix', y='missing'), function(x, y, ..., variables=NULL) { if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } } return(x) } ) setMethod('bind', signature(x='matrix', y='matrix'), function(x, y, ..., variables=NULL) { x <- .frbindMatrix(x, y) if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } else { variables <- NULL } } dots <- list(...) if (length(dots) > 1) { for (i in 1:length(dots)) { d <- dots[[i]] if (!inherits(d, 'data.frame')) { next } if (!is.null(variables)) { d <- d[, which(colnames(d) %in% variables), drop=FALSE] } if (nrow(d) > 0) { x <- .frbindMatrix(x, d) } } } x } ) setMethod('bind', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ..., keepnames=FALSE) { prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x <- list(x, y, ...) for (i in 1:length(x)) { if (!inherits(x[[i]], "SpatialPolygons")) { stop("all additional arguments must be SpatialPolygons") } x[[i]]@proj4string <- sp::CRS(as.character(NA)) } rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn, use.names = FALSE)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialPolygons')) { x <- do.call( rbind, x) if (inherits(x, "Spatial")) { x@proj4string <- prj } return(x) } if (all(cls == 'SpatialPolygonsDataFrame')) { dat <- lapply( x, function(x) { methods::slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialPolygons')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) x <- sp::SpatialPolygonsDataFrame(x, dat) x@proj4string <- prj return(x) } dat <- NULL # dataFound <- FALSE for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { # dataFound <- TRUE if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:length(x[[i]]@polygons),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat) + length(x[[i]])),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialPolygons')) x <- do.call(rbind, x) x <- sp::SpatialPolygonsDataFrame(x, dat, match.ID=FALSE) x@proj4string <- prj x } ) setMethod('bind', signature(x='SpatialLines', y='SpatialLines'), function(x, y, ..., keepnames=FALSE) { prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x <- list(x, y, ...) for (i in 1:length(x)) { if (!inherits(x[[i]], "SpatialLines")) { stop("all additional arguments must be SpatialLines") } x[[i]]@proj4string <- sp::CRS(as.character(NA)) } rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn, use.names = FALSE)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialLines')) { x <- do.call( rbind, x) x@proj4string <- prj return(x) } if (all(cls == 'SpatialLinesDataFrame')) { dat <- lapply( x, function(x) { methods::slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialLines')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) x <- sp::SpatialLinesDataFrame(x, dat) x@proj4string <- prj return(x) } dat <- NULL # dataFound <- FALSE for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { # dataFound <- TRUE if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:length(x[[i]]@lines),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat) + length(x[[i]])), ] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialLines')) x <- do.call(rbind, x) x <- sp::SpatialLinesDataFrame(x, dat, match.ID=FALSE) x@proj4string <- prj x } ) setMethod('bind', signature(x='SpatialPoints', y='SpatialPoints'), function(x, y, ..., keepnames=FALSE) { x <- list(x, y, ...) rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn, use.names = FALSE)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialPoints')) { return( do.call( rbind, x)) } if (all(cls == 'SpatialPointsDataFrame')) { dat <- lapply( x, function(x) { methods::slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialPoints')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) return( sp::SpatialPointsDataFrame(x, dat) ) } dat <- NULL for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:nrow(x[[i]]@coords),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat)+nrow(x[[i]]@coords)),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialPoints')) x <- do.call(rbind, x) sp::SpatialPointsDataFrame(x, dat) } ) setMethod('bind', signature(x='list', y='missing'), function(x, y, ..., keepnames=FALSE) { if (length(x) < 2) { return(unlist(x)) } names(x)[1:2] <- c('x', 'y') x$keepnames <- keepnames do.call(bind, x) } ) raster/R/plot.R0000644000176200001440000001005114160021141013037 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod("plot", signature(x='Raster', y='ANY'), function(x, y, maxpixels=500000, col, alpha=NULL, colNA=NA, add=FALSE, ext=NULL, useRaster=TRUE, interpolate=FALSE, addfun=NULL, nc, nr, maxnl=16, main, npretty=0, ...) { hasNoCol <- missing(col) if (hasNoCol) { col <- rev(terrain.colors(255)) } if (!is.null(alpha)) { if (inherits(alpha, 'RasterLayer')) { if (!compareRaster(x, alpha)) { alpha <- NULL } } else { alpha <- pmax(pmin(alpha, 1), 0) if (length(alpha) == 1) { alpha <- alpha * 255 + 1 a <- c(0:9, LETTERS[1:6]) alpha <- paste(rep(a, each=16), rep(a, times=16), sep='')[alpha] col <- paste(substr(col, 1, 7), alpha, sep="") alpha <- NULL } } } nl <- nlayers(x) if (nl == 0) { stop('Raster object has no cell values') } if (nl == 1) { if (inherits(x, 'RasterStackBrick')) { x <- raster(x, 1) } facvar <- 0 if (!missing(y)) { if (is.factor(x)) { facvar <- max(y, 0) } } if ( (length(x@legend@colortable) > 0) & hasNoCol) { .plotCT(x, maxpixels=maxpixels, ext=ext, interpolate=interpolate, main=main, add=add, addfun=addfun, ...) } else if (! useRaster) { .plotraster(x, col=col, maxpixels=maxpixels, add=add, ext=ext, main=main, addfun=addfun, ...) } else { .plotraster2(x, col=col, maxpixels=maxpixels, add=add, ext=ext, interpolate=interpolate, colNA=colNA, main=main, addfun=addfun, facvar=facvar, alpha=alpha, npretty=npretty, ...) #.plot2(x, col=col, maxpixels=maxpixels, ...) } return(invisible(NULL)) } if (missing(main)) { main <- names(x) } if (missing(y)) { y <- 1:nl if (length(y) > maxnl) { y <- 1:maxnl } } else { if (is.character(y)) { y <- match(y, names(x)) } y <- unique(as.integer(round(y))) y <- stats::na.omit(y) } if (length(y) == 1) { x <- raster(x, y) if ( (length(x@legend@colortable) > 0) & hasNoCol) { .plotCT(x, maxpixels=maxpixels, ext=ext, interpolate=interpolate, main=main[y], addfun=addfun, ...) } else if (useRaster) { .plotraster2(x, col=col, colNA=colNA, maxpixels=maxpixels, main=main[y], ext=ext, interpolate=interpolate, addfun=addfun, , alpha=alpha, ...) } else { .plotraster(x, col=col, maxpixels=maxpixels, main=main[y], ext=ext, addfun=addfun, ...) } } else { nl <- length(y) if (missing(nc)) { nc <- ceiling(sqrt(nl)) } else { nc <- max(1, min(nl, round(nc))) } if (missing(nr)) { nr <- ceiling(nl / nc) } else { nr <- max(1, min(nl, round(nr))) nc <- ceiling(nl / nr) } old.par <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(old.par)) graphics::par(mfrow=c(nr, nc), mar=c(2, 2, 2, 4)) xa='n' rown=1 coln=0 maxpixels=maxpixels/nl if (missing(main)) { main <- names(x) } for (i in 1:nl) { coln = coln + 1 if (coln > nc) { coln <- 1 rown = rown + 1 } if (rown==nr) xa='s' if (coln==1) ya='s' else ya='n' obj <- raster(x, y[i]) if ((length(obj@legend@colortable) > 0) & hasNoCol) { .plotCT(obj, maxpixels=maxpixels, ext=ext, interpolate=interpolate, main=main, addfun=addfun, ...) } else if (useRaster) { .plotraster2(obj, col=col, maxpixels=maxpixels, xaxt=xa, yaxt=ya, main=main[y[i]], ext=ext, interpolate=interpolate, colNA=colNA, addfun=addfun, alpha=alpha, ...) } else { .plotraster(obj, col=col, maxpixels=maxpixels, xaxt=xa, yaxt=ya, main=main[y[i]], ext=ext, interpolate=interpolate, addfun=addfun, ...) } } } return(invisible(NULL)) } ) setMethod("lines", signature(x='RasterLayer'), function(x, ...) { if(prod(dim(x)) < 50000) { stop('too many lines') } x <- as(x, 'SpatialPolygons') lines(x, ...) } ) setMethod("lines", signature(x='Extent'), function(x, ...) { plot(x, add=TRUE, ...) } ) raster/R/movingFun.R0000644000176200001440000000207414160021141014037 0ustar liggesusers# Author: Robert Hijmans # November 2009 # License GPL3 # First versions were based on the rollFun function implemented by Diethelm Wuertz in the # fTrading package # Version: 2100.76 # Published: 2009-09-29 movingFun <- function(x, n, fun=mean, type='around', circular=FALSE, na.rm=FALSE) { n <- round(abs(n)) if (n == 0) { stop('n == 0') } x = as.vector(x) lng <- length(x) if (type == 'around') { hn <- floor(n/2) if (circular) { x <- c(x[(lng-hn+1):lng], x, x[1:hn]) } else { x <- c(rep(NA, hn), x, rep(NA, hn)) } } else if (type == 'to') { if (circular) { x <- c(x[(lng-n+2):lng], x) } else { x <- c(rep(NA, n-1), x) } } else if (type == 'from') { if (circular) { x <- c(x, x[1:n]) } else { x <- c(x, rep(NA, n)) } } else { stop('unknown type; should be "around", "to", or "from"') } m <- matrix(ncol=n, nrow=lng) for (i in 1:n) { m[,i] <- x[i:(lng+i-1)] } apply(m, MARGIN=1, FUN=fun, na.rm=na.rm) } .roll <- function(x, n) { # by Josh O'Brien x[(seq_along(x) - (n+1)) %% length(x) + 1] } raster/R/multiCore.R0000644000176200001440000000451714160021141014036 0ustar liggesusers# Author: Matteo Mattiuzzi and Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 .recvOneData <- eval(parse(text="parallel:::recvOneData")) beginCluster <- function(n, type='SOCK', nice, exclude=NULL) { if (! requireNamespace("parallel") ) { stop('you need to install the "parallel" package') } if (exists('raster_Cluster_raster_Cluster', envir=.GlobalEnv)) { endCluster() } if (missing(n)) { n <- parallel::detectCores() message(n, ' cores detected, using ', n-1) n <- n-1 } # if (missing(type)) { # type <- getClusterOption("type") # message('cluster type:', type) # } cl <- parallel::makeCluster(n, type) cl <- .addPackages(cl, exclude=exclude) options(rasterClusterObject = cl) options(rasterClusterCores = length(cl)) options(rasterCluster = TRUE) options(rasterClusterExclude = exclude) if (!missing(nice)){ if (.Platform$OS.type == 'unix') { cmd <- paste("renice",nice,"-p") foo <- function() system(paste(cmd, Sys.getpid())) parallel::clusterCall(cl,foo) } else { warning("argument 'nice' only supported on UNIX like operating systems") } } } endCluster <- function() { options(rasterCluster = FALSE) cl <- options('rasterClusterObject')[[1]] if (! is.null(cl)) { parallel::stopCluster( cl ) options(rasterClusterObject = NULL) } } .doCluster <- function() { if ( isTRUE( getOption('rasterCluster')) ) { return(TRUE) } return(FALSE) } getCluster <- function() { cl <- getOption('rasterClusterObject') if (is.null(cl)) { stop('no cluster available, first use "beginCluster"') } cl <- .addPackages(cl, exclude=c('raster', 'sp', getOption('rasterClusterExclude'))) options( rasterClusterObject = cl ) options( rasterCluster = FALSE ) return(cl) } returnCluster <- function() { cl <- getOption('rasterClusterObject') if (is.null(cl)) { stop('no cluster available') } options( rasterCluster = TRUE ) } .addPackages <- function(cl, exclude=NULL) { pkgs <- .packages() i <- which( pkgs %in% c(exclude, "stats", "graphics", "grDevices", "utils", "datasets", "methods", "base") ) pkgs <- rev( pkgs[-i] ) for ( pk in pkgs ) { parallel::clusterCall(cl, library, pk, character.only=TRUE ) } return(cl) } raster/R/extent.R0000644000176200001440000001136314160021141013377 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .ext2bb <- function(e) { matrix(as.vector(e), ncol=2, byrow=TRUE) } #setMethod("bbox", signature(obj="SpatRaster"), # function(obj){ # .ext2bb(ext(obj)) # } #) #setMethod("bbox", signature(obj="SpatVector"), # function(obj){ # .ext2bb(ext(obj)) # } #) setMethod('extent', signature(x='Extent'), function(x){ return(x) } ) setMethod('extent', signature(x='BasicRaster'), function(x, r1, r2, c1, c2){ e <- x@extent r <- res(x) if (! missing(c1) ) { xn <- xFromCol(x, c1) - 0.5 * r[1] if (is.na(xn)) { warning('invalid first colummn') xn <- e@xmin } } else { xn <- e@xmin } if (! missing(c2) ) { xx <- xFromCol(x, c2) + 0.5 * r[1] if (is.na(xx)) { warning('invalid second colummn') xx <- e@xmax } } else { xx <- e@xmax } if (! missing(r1) ) { yx <- yFromRow(x, r1) + 0.5 * r[2] if (is.na(yx)) { warning('invalid first row') yx <- e@ymax } } else { yx <- e@ymax } if (! missing(r2) ) { yn <- yFromRow(x, r2) - 0.5 * r[2] if (is.na(yn)) { warning('invalid second row') yn <- e@ymin } } else { yn <- e@ymin } if (xn == xx) { stop('min and max x are the same') } if (yn == yx) { stop('min and max y are the same') } if (xn > xx) { warning('min x larger than max x') } if (yn > yx) { warning('min y larger than max y') } e <- extent(sort(c(xn, xx)), sort(c(yn, yx))) if (methods::validObject(e)) { return(e) } } ) setMethod('extent', signature(x='Spatial'), function(x){ bndbox <- sp::bbox(x) e <- methods::new('Extent') e@xmin <- bndbox[1,1] e@xmax <- bndbox[1,2] e@ymin <- bndbox[2,1] e@ymax <- bndbox[2,2] return(e) } ) setMethod('extent', signature(x='bbox'), function(x){ e <- methods::new('Extent') e@xmin <- x[1] e@xmax <- x[3] e@ymin <- x[2] e@ymax <- x[4] return(e) } ) setMethod('extent', signature(x='sf'), function(x){ if (!requireNamespace("sf")) { stop('Cannot do this because sf is not available') } b <- sf::st_bbox(x) e <- methods::new('Extent') e@xmin <- b[1] e@xmax <- b[3] e@ymin <- b[2] e@ymax <- b[4] return(e) } ) setMethod('extent', signature(x='matrix'), function(x){ d <- dim(x) if (min(d) < 2) { stop('matrix should have dimensions of at least 2 by 2') } if (d[2] > 2) { stop('matrix should not have more than 2 columns') } e <- methods::new('Extent') if (nrow(x) == 2) { # assuming a 'sp' bbox object e@xmin <- min(x[1,]) e@xmax <- max(x[1,]) e@ymin <- min(x[2,]) e@ymax <- max(x[2,]) } else { a <- as.vector(apply(x, 2, range, na.rm=TRUE)) e@xmin <- a[1] e@xmax <- a[2] e@ymin <- a[3] e@ymax <- a[4] } if (validObject(e)) return(e) } ) setMethod('extent', signature(x='numeric'), function(x, ...){ dots <- unlist(list(...)) x <- c(x, dots) if (length(x) < 4) { stop('insufficient number of elements (should be 4)') } if (length(x) > 4) { warning('more elements than expected (should be 4)') } names(x) <- NULL e <- methods::new('Extent') e@xmin <- x[1] e@xmax <- x[2] e@ymin <- x[3] e@ymax <- x[4] if (validObject(e)) return(e) } ) # contributed by Etienne Racine setMethod('extent', signature(x='list'), function(x, ...) { stopifnot(c("x", "y") %in% names(x)) stopifnot(lapply(x[c("x", "y")], length) >= 2) lim <- c(range(x$x), (range(x$y))) return(extent(lim,...)) } ) setMethod('extent', signature(x='GridTopology'), # contributed by Michael Sumner function(x){ cco <- x@cellcentre.offset cs <- x@cellsize cdim <- x@cells.dim e <- methods::new('Extent') e@xmin <- cco[1] - cs[1]/2 e@xmax <- e@xmin + cs[1] * cdim[1] e@ymin <- cco[2] - cs[2]/2 e@ymax <- e@ymin + cs[2] * cdim[2] return(e) } ) setMethod("[", c("Extent", "numeric", "missing"), function(x, i, j, ... ,drop=TRUE) { x <- as.vector(x) i <- as.integer(i) i <- i[i %in% 1:4] x[i] }) setMethod("[", c("Extent", "missing", "missing"), function(x, i, j, ... ,drop=TRUE) { as.vector(x) }) setReplaceMethod("[", c("Extent","numeric","missing"), function(x, i, j, value) { i <- as.integer(i) i <- i[i %in% 1:4] if (length(i) == 0) { return(x) } y <- as.vector(x) y[i] <- value if (y[1] >= y[2]) { stop('invalid extent. xmin should be greater than xmax') } if (y[3] >= y[4]) { stop('invalid extent. ymin should be greater than ymax') } x@xmin <- y[1] x@xmax <- y[2] x@ymin <- y[3] x@ymax <- y[4] return(x) } ) raster/R/writeValues.R0000644000176200001440000001261614160021141014404 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 1.0 # Licence GPL v3 setMethod("writeValues", signature(x="RasterLayer", v="vector"), function(x, v, start, ...) { v[is.infinite(v)] <- NA datanotation <- x@file@datanotation if (substr(datanotation,1,1) != "F") { v <- round(v) size <- substr(datanotation,4,4) if (substr(datanotation, 1, 3) == "LOG") { v[v != 1] <- 0 } else if (substr(datanotation, 5, 5) == "U") { v[v < 0] <- NA if (size == "1") { v[v > 255] <- NA } else if (size == "2") { v[v > 65535] <- NA } else { v[v > 4294967295] <- NA } } else { if (size == "1") { v[v < -128] <- NA v[v > 127] <- NA } else if (size == "2") { v[v < -32768] <- NA v[v > 32767] <- NA } else { v[v < -2147483648] <- NA v[v > 2147483647] <- NA } } } rsd <- stats::na.omit(v) # min and max values if (length(rsd) > 0) { x@data@min <- min(x@data@min, rsd) x@data@max <- max(x@data@max, rsd) } driver <- x@file@driver if ( driver == "gdal" ) { off <- c(start-1, 0) v[is.na(v)] <- x@file@nodatavalue v <- matrix(v, nrow=x@ncols) gd <- rgdal::putRasterData(x@file@transient, v, band=1, offset=off) } else if ( driver %in% .nativeDrivers() ) { if (x@file@dtype == "FLT" ) { # v may be integers, while the filetype is FLT v <- as.numeric( v ) if (driver != "raster") { v[is.na(v)] <- x@file@nodatavalue } } else { v[is.na(v)] <- as.integer(x@file@nodatavalue) v <- as.integer(v) } start <- (start-1) * x@ncols * x@file@dsize seek(x@file@con, start, rw="w") # print(v) writeBin(v, x@file@con, size=x@file@dsize ) } else if ( driver == "netcdf") { x <- .writeValuesCDF(x, v, start) # } else if ( driver == "big.matrix") { # # b <- attr(x@file, "big.matrix") # nrows <- length(v) / ncol(x) # # b[rowColFromCell(x, start:(start+length(v)-1))] <- v # b[start:(start+nrows-1), ] <- matrix(v, nrow=nrows, byrow=TRUE) } else if ( driver == "ascii") { opsci = options("scipen") if (x@file@dtype == "INT") { options(scipen=10) v <- round(v) } v[is.na(v)] <- x@file@nodatavalue if (x@file@dtype == "FLT") { # hack to make sure that ArcGIS does not # assume values are integers if the first # values have no decimal point v <- as.character(v) v[1] <- formatC(as.numeric(v[1]), 15, format="f") } v <- matrix(v, ncol=ncol(x), byrow=TRUE) utils::write.table(v, x@file@name, append = TRUE, quote = FALSE, sep = " ", eol = "\n", dec = ".", row.names = FALSE, col.names = FALSE) options(scipen=opsci) } else { stop("was writeStart used?") } return(x) } ) setMethod("writeValues", signature(x="RasterBrick", v="matrix"), function(x, v, start, ...) { v[is.infinite(v)] <- NA if (is.logical(v)) { v[] <- as.integer(v) } w <- getOption("warn") options("warn"=-1) rng <- apply(v, 2, range, na.rm=TRUE) x@data@min <- pmin(x@data@min, rng[1,]) x@data@max <- pmax(x@data@max, rng[2,]) options("warn"= w) driver <- x@file@driver if ( driver %in% .nativeDrivers() ) { #if (!is.matrix(v)) v <- matrix(v, ncol=1) if (x@file@dtype == "INT") { v[is.na(v)] <- x@file@nodatavalue dm <- dim(v) v <- as.integer(round(v)) dim(v) <- dm } else if ( x@file@dtype =="LOG" ) { v[v != 1] <- 0 v[is.na(v)] <- x@file@nodatavalue dm <- dim(v) v <- as.integer(round(v)) dim(v) <- dm } else { # if (!is.numeric(v)) { v[] <- as.numeric( v ) } if (x@file@bandorder=="BIL") { start <- (start-1) * x@ncols * x@file@dsize * nlayers(x) seek(x@file@con, start, rw="w") loop <- nrow(v) / x@ncols start <- 1 for (i in 1:loop) { end <- start + x@ncols - 1 writeBin(as.vector(v[start:end,]), x@file@con, size=x@file@dsize ) start <- end + 1 } } else if (x@file@bandorder=="BIP") { start <- (start-1) * x@ncols * x@file@dsize * nlayers(x) seek(x@file@con, start, rw="w") writeBin(as.vector(t(v)), x@file@con, size=x@file@dsize ) } else if (x@file@bandorder=="BSQ") { start <- (start-1) * x@ncols * x@file@dsize nc <- ncell(x) * x@file@dsize for (i in 1:ncol(v)) { pos <- start + nc * (i-1) seek(x@file@con, pos, rw="w") writeBin(v[,i], x@file@con, size=x@file@dsize ) } } else { stop("unknown band order") } } else if ( driver == "netcdf") { x <- .writeValuesBrickCDF(x, v, start) } else if ( driver == "big.matrix") { b <- attr(x@file, "big.matrix") startcell <- cellFromRowCol(x, start, 1) endcell <- startcell+nrow(v)-1 b[startcell:endcell, ] <- v } else { # rgdal off <- c(start-1, 0) if (x@file@datanotation == "INT1U") { v[v < 0] <- NA } v[is.na(v)] <- x@file@nodatavalue for (i in 1:nlayers(x)) { vv <- matrix(v[,i], nrow=ncol(x)) gd <- rgdal::putRasterData(x@file@transient, vv, band=i, offset=off) } } return(x) } ) .getTransientRows <- function(x, r, n=1) { reg = c(n, ncol(x)) off = c(r-1,0) as.vector((rgdal::getRasterData(x@file@transient, region.dim=reg, offset=off))) } raster/R/netCDFtoStack.R0000644000176200001440000000316614160021141014526 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 / revised June 2010 # Version 1.0 # Licence GPL v3 .stackCDF <- function(filename, varname='', bands='') { stopifnot(requireNamespace("ncdf4")) nc <- ncdf4::nc_open(filename, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) zvar <- .varName(nc, varname) dims <- nc$var[[zvar]]$ndims dim3 <- 3 if (dims== 1) { stop('variable only has a single dimension; I cannot make a RasterLayer from this') } else if (dims > 3) { dim3 <- dims warning(zvar, ' has ', dims, ' dimensions, I am using the last one') } else if (dims == 2) { return( stack ( raster(filename, varname=zvar ) ) ) } if (is.null(bands)) { bands <- ''} if (bands[1] == '') { bands = 1 : nc$var[[zvar]]$dim[[dim3]]$len } r <- raster(filename, varname=zvar, band=bands[1]) st <- stack( r ) st@title <- names(r) if (length(bands) > 1) { ## to enable suppress_dimvals ##st@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals[bands] ) dim3_vals <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dim3]]$name), silent = TRUE) if (inherits(dim3_vals, "try-error")) { dim3_vals <- seq_len(nc$var[[zvar]]$dim[[dim3]]$len) } st@z <- list(dim3_vals[bands]) names(st@z) <- nc$var[[zvar]]$dim[[dim3]]$units if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) { try( st <- .doTime(st, nc, zvar, dim3) ) } nms <- as.character(st@z[[1]]) st@layers <- lapply(bands, function(x){ r@data@band <- x; r@data@names <- nms[x]; return(r)} ) } return( st ) } #s = .stackCDF(f, varname='uwnd') raster/R/stackFile.R0000644000176200001440000000257214160021141013777 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 stackOpen <- function(stackfile) { f <- utils::read.table(stackfile, as.is=FALSE, strip.white=TRUE) if (dim(f)[2] > 1) { s <- stack(as.vector(f[,1]), bands=as.vector(f[,2])) } else { s <- stack(as.vector(f[,1])) } s@filename <- stackfile return(s) } ..stackOpen <- function(stackfile, quick=FALSE) { f <- utils::read.table(stackfile, as.is=FALSE, strip.white=TRUE) if (quick) { if (dim(f)[2] > 1) { s <- .quickStack(f[,1], f[,2], f[,3]) } else { s <- .quickStack(f[,1]) } } else { if (dim(f)[2] > 1) { s <- stack(as.vector(f[,1]), bands=as.vector(f[,2])) } else { s <- stack(as.vector(f[,1])) } } s@filename <- stackfile return(s) } stackSave <- function(x, filename) { filename <- trim(filename) if (filename == "") { stop('Provide a non empty filename.') } info <- t( sapply(x@layers, function(i) c(i@file@name, i@file@nbands, i@data@band)) ) if (any(info[,1] == '')) { stop("cannot save a RasterStack that has layers that only exist in memory. Use writeRaster first/instead.") } if (any(info[,2] != '1')) { utils::write.table(info, filename, row.names=FALSE, col.names=FALSE) } else { utils::write.table(info[,1], filename, row.names=FALSE, col.names=FALSE) } x@filename <- filename return(x) } raster/R/head.R0000644000176200001440000000314414160021141012767 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2010 # Version 0.9 # Licence GPL v3 setMethod('head', signature(x='RasterLayer'), function(x, cols=20, rows=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) v <- getValuesBlock(x, 1, nrows=nr, ncols=nc, format='matrix') return(v) } ) setMethod('tail', signature(x='RasterLayer'), function(x, cols=20, rows=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) sr <- x@nrows - nr + 1 sc <- x@ncols - nc + 1 v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc, format='matrix') return(v) } ) setMethod('head', signature(x='RasterStackBrick'), function(x, cols=10, rows=2, layers=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) nl <- min(nlayers(x), max(1, layers)) v <- getValuesBlock(x, 1, nrows=nr, ncols=nc) return(v) } ) setMethod('tail', signature(x='RasterStackBrick'), function(x, cols=10, rows=2, layers=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) nl <- min(nlayers(x), max(1, layers)) sr <- x@nrows - nr + 1 sc <- x@ncols - nc + 1 v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc) return(v) } ) setMethod('head', signature(x='Spatial'), function(x, n=6L,...) { if (.hasSlot(x, 'data')) { head(x@data, n=n, ...) } else { x[1,] } } ) setMethod('tail', signature(x='Spatial'), function(x, n=6L, ...) { if (.hasSlot(x, 'data')) { tail(x@data, n=n, ...) } else { x[length(x),] } } ) raster/R/brick.R0000644000176200001440000001536214160021141013165 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('brick', signature(x='missing'), function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, nl=1, crs) { e <- extent(xmn, xmx, ymn, ymx) if (missing(crs)) { if (e@xmin > -400 & e@xmax < 400 & e@ymin > -90.1 & e@ymax < 90.1) { crs ="+proj=longlat +datum=WGS84" } else { crs="" } } b <- brick(e, nrows=nrows, ncols=ncols, crs=crs, nl=nl) return(b) } ) setMethod('brick', signature(x='character'), function(x, ...) { .rasterObjectFromFile(x, objecttype='RasterBrick', ...) } ) setMethod('brick', signature(x='RasterLayer'), function(x, ..., values=TRUE, nl=1, filename='') { nl <- max(round(nl), 0) if (!hasValues(x)) { values <- FALSE } if (!values) { b <- brick(x@extent, nrows=nrow(x), ncols=ncol(x), crs=x@crs, nl=nl) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } return(b) } filename <- trim(filename) dots <- list(...) fformat <- dots$format if (is.null(fformat)) { fformat <- .filetype(filename=filename) } datatype <- dots$datatype if (is.null(datatype)) { datatype <- .datatype() } overwrite <- dots$overwrite if (is.null(overwrite)) { overwrite <- .overwrite() } progress <- dots$progress if (is.null(progress)) { progress <- .progress() } x <- stack(x, ...) brick(x, values=values, filename=filename, format=fformat, datatype=datatype, overwrite=overwrite, progress=progress) } ) setMethod('brick', signature(x='RasterStack'), function(x, values=TRUE, nl, filename='', ...){ e <- x@extent b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=x@crs) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } if (missing(nl)) { nl <- nlayers(x) if (nl < 1) { values <- FALSE } } else { nl <- max(round(nl), 0) values <- FALSE } b@data@nlayers <- as.integer(nl) filename <- trim(filename) if (values) { b@data@names <- names(x)[1:nl] if (canProcessInMemory(b, nl*2)) { b <- setValues( b, getValues(x)[,1:nl]) if (any(is.factor(x))) { b@data@isfactor <- is.factor(x) b@data@attributes <- levels(x) } if (filename != '') { b <- writeRaster(b, filename, ...) } return(b) } else { b <- writeStart(b, filename=filename, ...) tr <- blockSize(b) pb <- pbCreate(tr$n, ...) x <- readStart(x) for (i in 1:tr$n) { vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, vv, tr$row[i]) pbStep(pb, i) } pbClose(pb) b <- writeStop(b) x <- readStop(x) return(b) } } else { b@data@min <- rep(Inf, b@data@nlayers) b@data@max <- rep(-Inf, b@data@nlayers) return(b) } } ) setMethod('brick', signature(x='RasterBrick'), function(x, nl, ...){ if (missing(nl)) { nl <- nlayers(x) } e <- x@extent b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=x@crs) b@data@nlayers <- as.integer(nl) b@data@min <- rep(Inf, nl) b@data@max <- rep(-Inf, nl) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } return(b) } ) setMethod('brick', signature(x='Extent'), function(x, nrows=10, ncols=10, crs="", nl=1) { nr = as.integer(round(nrows)) nc = as.integer(round(ncols)) if (nc < 1) { stop("ncols should be > 0") } if (nr < 1) { stop("nrows should be > 0") } b <- methods::new("RasterBrick", extent=x, ncols=nc, nrows=nr) prj <- sp::CRS(as.character(NA), doCheckCRSArgs=FALSE) try(prj <- .getCRS(crs)) projection(b) <- prj nl <- max(round(nl), 0) b@data@nlayers <- as.integer(nl) b@data@isfactor <- rep(FALSE, nl) return(b) } ) setMethod('brick', signature(x='SpatialGrid'), function(x){ b <- brick() extent(b) <- extent(x) crs(b) <- x@proj4string dim(b) <- c(x@grid@cells.dim[2], x@grid@cells.dim[1]) if (class(x) == 'SpatialGridDataFrame') { x <- x@data b@data@isfactor <- rep(FALSE, ncol(x)) isfact <- sapply(x, function(i) is.factor(i) | is.character(i)) b@data@isfactor <- isfact if (any(isfact)) { for (i in which(isfact)) { rat <- data.frame(table(x[[i]])) rat <- data.frame(1:nrow(rat), rat[,2], rat[,1]) colnames(rat) <- c("ID", "COUNT", colnames(x)[i]) b@data@attributes[[i]] <- rat x[,i] <- as.integer(x[,i]) } } b <- setValues(b, as.matrix(x)) b@data@names <- colnames(x) } return(b) } ) setMethod('brick', signature(x='SpatialPixels'), function(x) { if (inherits( x, 'SpatialPixelsDataFrame')) { x <- as(x, 'SpatialGridDataFrame') } else { x <- as(x, 'SpatialGrid') } return(brick(x)) } ) setMethod('brick', signature(x='array'), function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", transpose=FALSE) { dm <- dim(x) if (is.matrix(x)) { stop('cannot coerce a matrix to a RasterBrick') } if (length(dm) != 3) { stop('array has wrong number of dimensions (needs to be 3)') } b <- brick(xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs, nl=dm[3]) names(b) <- dimnames(x)[[3]] if (transpose) { dim(b) <- c(dm[2], dm[1], dm[3]) } else { dim(b) <- dm # aperm etc suggested by Justin McGrath # https://r-forge.r-project.org/forum/message.php?msg_id=4312 x = aperm(x, perm=c(2,1,3)) } attributes(x) <- list() dim(x) <- c(dm[1] * dm[2], dm[3]) setValues(b, x) } ) # setMethod('brick', signature(x='big.matrix'), # function(x, template, filename='', ...) { # stopifnot(inherits(template, 'BasicRaster')) # stopifnot(nrow(x) == ncell(template)) # r <- brick(template) # filename <- trim(filename) # names(r) <- colnames(x) # if (canProcessInMemory(r)) { # r <- setValues(r, x[]) # if (filename != '') { # r <- writeRaster(r, filename, ...) # } # } else { # tr <- blockSize(r) # pb <- pbCreate(tr$n, ...) # r <- writeStart(r, filename, ...) # for (i in 1:tr$n) { # r <- writeValues(r, x[tr$row[i]:(tr$row[i]+tr$nrows[i]-1), ], tr$row[i] ) # pbStep(pb) # } # r <- writeStop(r) # pbClose(pb) # } # return(r) # } # ) setMethod('brick', signature(x='kasc'), function(x) { as(x, 'RasterBrick') } ) setMethod('brick', signature(x='grf'), function(x) { as(x, 'RasterBrick') } ) setMethod('brick', signature(x='list'), function(x) { x <- stack(x) brick(x) } ) setMethod('brick', signature(x='SpatRaster'), function(x) { as(x, "Raster") } ) raster/R/netCDFread.R0000644000176200001440000001147714160021141014035 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .readRowsNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1)) { if ( x@file@toptobottom ) { row <- x@nrows - row - nrows + 2 } is.open <- x@file@open if (is.open) { nc <- x@file@con } else { nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) } zvar <- x@data@zvar if (nc$var[[zvar]]$ndims == 1) { # for GMT ncx <- ncol(x) start <- (row-1) * ncx + 1 count <- nrows * ncx d <- ncdf4::ncvar_get( nc, varid=zvar, start=start, count=count ) if (col > 1 | ncols < ncx) { d <- matrix(d, ncol=ncx, byrow=TRUE) d <- d[, col:(col+ncols-1)] d <- as.vector(t(d)) } } else if (nc$var[[zvar]]$ndims == 2) { start <- c(col, row) count <- c(ncols, nrows) d <- ncdf4::ncvar_get( nc, varid=zvar, start=start, count=count ) } else if (nc$var[[zvar]]$ndims == 3) { start <- c(col, row, x@data@band) count <- c(ncols, nrows, 1) d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { if (x@data@dim3 == 4) { start <- c(col, row, x@data@level, x@data@band) count <- c(ncols, nrows, 1, 1) d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { start <- c(col, row, x@data@band, x@data@level) count <- c(ncols, nrows, 1, 1) d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA } #d <- x@data@add_offset + d * x@data@scale_factor if (length(dim(d)) > 1) { if ( x@file@toptobottom ) { d <- d[, ncol(d):1] } } d <- as.vector(d) d[d == x@file@nodatavalue] <- NA return(d) } .readRowsBrickNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) { # RH removed because of bug with RasterLayer specific slots # if (nlayers(x) == 1) { # return(.readRowsNetCDF(x=x, row=row, nrows=nrows, col=col, ncols=ncols) ) # } is.open <- x@file@open if ( x@file@toptobottom ) { row <- x@nrows - row - nrows + 2 } navalue <- x@file@nodatavalue #n the true number of layers #nn the span of layers between the first and the last #alyrs, the layers requested, scaled to start at one. n <- nn <- nlayers(x) if (missing(lyrs)) { layer <- 1 lyrs <- 1:n } else { lyrs <- lyrs[lyrs %in% 1:n] if (length(lyrs) == 0) { stop("no valid layers") } layer <- lyrs[1] n <- length(lyrs) nn <- lyrs[length(lyrs)] - lyrs[1] + 1 } alyrs <- lyrs - lyrs[1] + 1 lns <- names(x)[lyrs] nrows <- min(round(nrows), x@nrows-row+1) ncols <- min((x@ncols-col+1), ncols) stopifnot(nrows > 0) stopifnot(ncols > 0) if (is.open) { nc <- x@file@con } else { nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) } zvar <- x@data@zvar if (nc$var[[zvar]]$ndims == 4) { if (x@data@dim3 == 4) { start <- c(col, row, x@data@level, layer) count <- c(ncols, nrows, 1, nn) } else { start <- c(col, row, layer, x@data@level) count <- c(ncols, nrows, nn, 1) } } else if (nc$var[[zvar]]$ndims == 2) { start <- c(col, row) count <- c(ncols, nrows) } else { start <- c(col, row, layer) count <- c(ncols, nrows, nn) } d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA } #d <- x@data@add_offset + d * x@data@scale_factor if (nlayers(x) > 1) { dims = dim(d) if (length(dims) == 3) { if ( x@file@toptobottom ) { v <- matrix(nrow=nrows*ncols, ncol=n) for (i in 1:length(alyrs)) { x <- d[,,alyrs[i]] v[,i] <- as.vector( x[, ncol(x):1] ) } } else { dim(d) = c(dims[1] * dims[2], dims[3]) d <- d[, alyrs, drop=FALSE] d[d == x@file@nodatavalue] <- NA return(d) } } else if (length(dims) == 2) { if (nrows==1) { d <- d[ , alyrs,drop=FALSE] d[d == navalue] <- NA return(d) } else if (n==1) { v <- matrix(nrow=nrows*ncols, ncol=n) if ( x@file@toptobottom ) { v[] <- as.vector(d[,ncol(d):1]) } else { v[] <- as.vector(d) } } else if (ncols==1) { if ( x@file@toptobottom ) { d <- d[nrow(d):1, ] } d <- d[ , alyrs, drop=FALSE] d[d == navalue] <- NA return(d) } } else { # length(dims) == 1 v <- matrix(nrow=nrows*ncols, ncol=n) if ( x@file@toptobottom & nrows > 1) { d <- rev(d) } v[] <- d # d[, alyrs, drop=FALSE] } } else { if ( x@file@toptobottom ) { if (is.matrix(d)) { d <- d[, ncol(d):1] } } v <- matrix(as.vector(d), ncol=1) #v <- v[,lyrs,drop=FALSE] } v[v == navalue] <- NA colnames(v) <- lns return(v) } raster/R/flowpath.R0000644000176200001440000000414114160021141013710 0ustar liggesusers# drain.R # This script calculates the drainage of a point on a DEM - in R! # written by A. Shortridge, 10/2013 # changes by Robert Hijmans flowPath <- function(x, p, ...) { r <- raster(x) if (length(p) > 1) { p <- cellFromXY(r, p[1:2]) } cell <- p row <- rowFromCell(r, cell) col <- colFromCell(r, cell) nr <- nrow(r) nc <- ncol(r) path <- NULL while (!is.na(x[cell])) { path <- c(path, cell) fd <- x[cell] row <- if(fd %in% c(32, 64, 128)) row - 1 else if(fd %in% c(8, 4, 2)) row + 1 else row col <- if(fd %in% c(32, 16, 8)) col - 1 else if(fd %in% c(128, 1, 2)) col + 1 else col cell <- cellFromRowCol(r, row, col) # Don't drain off the raster or drain NA cells on x! if (is.na(x[cell])) break # avoid cell i draining to j and j draining to i traps if (cell %in% path) break } return(path) } .flowPath1 <- function(x, p) { # This function creates a raster with 1s representing a path from # the start cell to the end of the flowpath. x is a flow raster # created with the terrain() function in raster. Returns a raster # where 1 represents a part of this path and 0 is off-path. out <- raster(x) if (length(p) > 1) { p <- cellFromXY(out, p[1:2]) } row <- rowFromCell(out, p) col <- colFromCell(out, p) out[row, col] <- 1 while (!is.na(x[row, col])) { # not in a pit out[row, col] <- 1 fdval <- x[row, col] col <- if(fdval %in% c(32, 16, 8)) col - 1 else if(fdval %in% c(128, 1, 2)) col + 1 else col row <- if(fdval %in% c(32, 64, 128)) row - 1 else if(fdval %in% c(8, 4, 2)) row + 1 else row # Don't drain off the raster! if (row < 1 || row > dim(x)[1] || col < 1 || col > dim(x)[2]) break # Don't drain NA cells on x! if (is.na(x[row, col])) break # avoid cell i draining to j and j draining to i traps if (!is.na(out[row, col])) break } return(out) } raster/R/sampleRegular.R0000644000176200001440000001274514160021141014700 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 setMethod('sampleRegular', signature(x='Raster'), function( x, size, ext=NULL, cells=FALSE, xy=FALSE, asRaster=FALSE, sp=FALSE, useGDAL=FALSE, ...) { stopifnot(hasValues(x) | isTRUE(xy)) size <- round(size) stopifnot(size > 0) nl <- nlayers(x) rotated <- rotated(x) if (is.null(ext)) { rcut <- raster(x) firstrow <- 1 lastrow <- nrow(rcut) firstcol <- 1 lastcol <- ncol(rcut) } else { rcut <- crop(raster(x), ext) ext <- extent(rcut) yr <- yres(rcut) xr <- xres(rcut) firstrow <- rowFromY(x, ext@ymax-0.5 *yr) lastrow <- rowFromY(x, ext@ymin+0.5*yr) firstcol <- colFromX(x, ext@xmin+0.5*xr) lastcol <- colFromX(x, ext@xmax-0.5*xr) } allx <- FALSE if (size >= ncell(rcut)) { if (!is.null(ext)) { x <- crop(x, ext) } if (asRaster & !rotated) { return(x) } nr <- nrow(rcut) nc <- ncol(rcut) allx <- TRUE } else { Y <- X <- sqrt(ncell(rcut)/size) nr <- max(1, floor((lastrow - firstrow + 1) / Y)) nc <- max(1, floor((lastcol - firstcol + 1) / X)) rows <- (lastrow - firstrow + 1)/nr * 1:nr + firstrow - 1 rows <- rows - (0.5 * (lastrow - firstrow + 1)/nr) cols <- (lastcol - firstcol + 1)/nc * 1:nc + firstcol - 1 cols <- cols - (0.5 * (lastcol - firstcol + 1)/nc) cols <- unique(round(cols)) rows <- unique(round(rows)) cols <- cols[cols > 0] rows <- rows[rows > 0] nr <- length(rows) nc <- length(cols) } hv <- hasValues(x) if (fromDisk(x) & useGDAL & hv) { if ( any(rotated | .driver(x, FALSE) != 'gdal') ) { useGDAL <- FALSE } else { offs <- c(firstrow,firstcol)-1 reg <- c(nrow(rcut), ncol(rcut))-1 if ( nl > 1 ) { v <- matrix(NA, ncol=nl, nrow=prod(nr, nc)) for (i in 1:nl) { xx <- x[[i]] con <- rgdal::GDAL.open(xx@file@name, silent=TRUE) band <- bandnr(xx) vv <- rgdal::getRasterData(con, band=band, offset=offs, region.dim=reg, output.dim=c(nr, nc)) rgdal::closeDataset(con) if (xx@data@gain != 1 | xx@data@offset != 0) { vv <- vv * xx@data@gain + xx@data@offset } if (xx@file@nodatavalue < 0) { vv[vv <= xx@file@nodatavalue] <- NA } else { vv[vv == xx@file@nodatavalue] <- NA } v[, i] <- vv } } else { band <- bandnr(x) con <- rgdal::GDAL.open(x@file@name, silent=TRUE) v <- rgdal::getRasterData(con, band=band, offset=offs, region.dim=reg, output.dim=c(nr, nc)) rgdal::closeDataset(con) v <- matrix(v, ncol=1) colnames(v) <- names(x) if (x@data@gain != 1 | x@data@offset != 0) { v <- v * x@data@gain + x@data@offset } if (.naChanged(x)) { if (x@file@nodatavalue < 0) { v[v <= x@file@nodatavalue] <- NA } else { v[v == x@file@nodatavalue] <- NA } } } if (asRaster) { if (is.null(ext)) { outras <- raster(x) } else { outras <- raster(ext) crs(outras) <- crs(x) } nrow(outras) <- nr ncol(outras) <- nc if (nl > 1) { outras <- brick(outras, nl=nl) outras <- setValues(outras, v) } else { outras <- setValues(outras, as.vector(v)) } names(outras) <- names(x) if (any(is.factor(x))) { levels(outras) <- levels(x) } return(outras) } else { if (cells) { warning("'cells=TRUE' is ignored when 'useGDAL=TRUE'") } if (xy) { warning("'xy=TRUE' is ignored when 'useGDAL=TRUE'") } if (sp) { warning("'sp=TRUE' is ignored when 'useGDAL=TRUE'") } return( v ) } } } if (allx) { cell <- 1:ncell(rcut) } else { cell <- cellFromRowCol(x, rep(rows, each=nc), rep(cols, times=nr)) } if (asRaster) { if (rotated) { if (is.null(ext)) { outras <- raster(extent(x)) } else { outras <- raster(ext) crs(outras) <- crs(x) } ncol(outras) <- nc nrow(outras) <- nr xy <- xyFromCell(outras, 1:ncell(outras)) if (hv) { m <- .xyValues(x, xy) } else { m <- NA } } else { if (allx) { if (!is.null(ext)) { return(crop(x, ext)) } else { return(x) } } cell <- cellFromRowCol(x, rep(rows, each=nc), rep(cols, times=nr)) if (hv) { m <- .cellValues(x, cell) } else { m <- NA } if (is.null(ext)) { outras <- raster(x) } else { outras <- raster(ext) crs(outras) <- crs(x) } nrow(outras) <- nr ncol(outras) <- nc } if (nl > 1) { outras <- brick(outras, nl=nl) } outras <- setValues(outras, m) names(outras) <- names(x) if (any(is.factor(x))) { levels(outras) <- levels(x) } return(outras) } else { if (allx) { cell <= 1:ncell(rcut) } else { cell <- cellFromRowCol(x, rep(rows, each=nc), rep(cols, times=nr)) } m <- NULL nstart <- 1 if (xy) { m <- xyFromCell(x, cell) nstart <- 3 } if (cells) { m <- cbind(m, cell=cell) nstart <- nstart + 1 } if (hv) { m <- cbind(m, .cellValues(x, cell)) colnames(m)[nstart:(nstart+nl-1)] <- names(x) } if (sp) { if (hv) { m <- sp::SpatialPointsDataFrame(xyFromCell(x, cell), data.frame(m), proj4string=.getCRS(x)) } else { m <- sp::SpatialPoints(xyFromCell(x, cell), proj4string=.getCRS(x)) } } return(m) } } ) raster/R/writeStartStopGDAL.R0000644000176200001440000000361414160021141015536 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .startGDALwriting <- function(x, filename, options, setStatistics=TRUE, ...) { temp <- .getGDALtransient(x, filename=filename, options=options, ...) attr(x@file, "transient") <- temp[[1]] x@file@nodatavalue <- temp[[2]] attr(x@file, "options") <- temp[[3]] attr(x@file, "stats") <- setStatistics x@data@min <- rep(Inf, nlayers(x)) x@data@max <- rep(-Inf, nlayers(x)) x@data@haveminmax <- FALSE x@file@datanotation <- .getRasterDType(temp[[4]]) x@file@driver <- 'gdal' x@data@fromdisk <- TRUE x@file@name <- filename return(x) } .stopGDALwriting <- function(x, stat=cbind(NA,NA)) { nl <- nlayers(x) statistics <- cbind(x@data@min, x@data@max) if (substr(x@file@datanotation, 1, 1) != 'F') { statistics <- round(statistics) } if (isTRUE( attr(x@file, "stats") ) ) { statistics <- cbind(statistics, stat[,1], stat[,2]) # could do wild guesses to avoid problems in other software # but not sure if this cure would be worse. Could have an option to do this #i <- is.na(statistics[,3]) #if (sum(i) > 0) { # statistics[i, 3] <- (statistics[i, 1] + statistics[i, 2]) / 2 # statistics[i, 4] <- statistics[i, 3] * 0.2 #} for (i in 1:nl) { b <- methods::new("GDALRasterBand", x@file@transient, i) rgdal::GDALcall(b, "SetStatistics", as.double(statistics[i,])) } } if(x@file@options[1] != "") { rgdal::saveDataset(x@file@transient, x@file@name, options=x@file@options) } else { rgdal::saveDataset(x@file@transient, x@file@name) } rgdal::GDAL.close(x@file@transient) if (nl > 1) { out <- brick(x@file@name) } else { out <- raster(x@file@name) } if (! out@data@haveminmax ) { out@data@min <- statistics[, 1] out@data@max <- statistics[, 2] out@data@haveminmax <- TRUE } return(out) } raster/R/addFiles.R0000644000176200001440000000125114160021141013576 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .addFiles <- function(x, rasterfiles, bands=rep(1, length(rasterfiles))) { if (length(bands) == 1) { bands=rep(bands, length(rasterfiles)) } rasters <- list() for (i in 1:length(rasterfiles)) { if (bands[[i]] < 1) { r <- raster(rasterfiles[[i]], band=1) rasters <- c(rasters, r) if (nbands(r) > 1) { for (j in 2:nbands(r)) { r <- raster(rasterfiles[[i]], band=j) rasters <- c(rasters, r) } } } else { rasters <- c(rasters, raster(rasterfiles[[i]], FALSE, band=bands[[i]])) } } x <- addLayer(x, rasters) return(x) } raster/R/aggregate_3d.R0000644000176200001440000001224514160021141014404 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 # October 2012: Major overhaul (including C interface) # November 2012: fixed bug with expand=F # June 2014: support for aggregation over z (layers) in addition to x and y setMethod('aggregate', signature(x='Raster'), function(x, fact, fun='mean', expand=TRUE, na.rm=TRUE, filename="", ...) { fact <- round(fact) lf <- length(fact) if (lf == 1) { fact <- c(fact, fact, 1) } else if (lf == 2) { fact <- c(fact, 1) } else if (lf > 3) { stop('fact should have length 1, 2, or 3') } if (any(fact < 1)) { stop('fact should be > 0') } if (! any(fact > 1)) { warning('all fact(s) were 1, nothing to aggregate') return(x) } xfact <- fact[1] yfact <- fact[2] zfact <- fact[3] ncx <- ncol(x) nrx <- nrow(x) nlx <- nlayers(x) if (xfact > ncx) { warning('aggregation factor is larger than the number of columns') xfact <- ncx if (!na.rm) xfact <- xfact + 1 } if (yfact > nrx) { warning('aggregation factor is larger than the number of rows') yfact <- nrx if (!na.rm) yfact <- yfact + 1 } if (zfact > nlx) { warning('aggregation factor is larger than the number of layers') zfact <- nlx if (!na.rm) zfact <- zfact + 1 } if (expand) { rsteps <- as.integer(ceiling(nrx/yfact)) csteps <- as.integer(ceiling(ncx/xfact)) lsteps <- as.integer(ceiling(nlx/zfact)) lastcol <- ncx lastrow <- nrx lastlyr <- lsteps * zfact lyrs <- 1:nlx } else { rsteps <- as.integer(floor(nrx/yfact)) csteps <- as.integer(floor(ncx/xfact)) lsteps <- as.integer(floor(nlx/zfact)) lastcol <- min(csteps * xfact, ncx) lastrow <- min(rsteps * yfact, nrx) lastlyr <- min(lsteps * zfact, nlx) lyrs <- 1:lastlyr } ymn <- ymax(x) - rsteps * yfact * yres(x) xmx <- xmin(x) + csteps * xfact * xres(x) if (lsteps > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } extent(out) <- extent(xmin(x), xmx, ymn, ymax(x)) dim(out) <- c(rsteps, csteps, lsteps) ncout <- ncol(out) nlout <- nlayers(out) if (zfact == 1) { names(out) <- names(x) } if (! hasValues(x) ) { return(out) } fun <- .makeTextFun(fun) if (class(fun)[1] == 'character') { op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1) } else { op <- NA } # note that it is yfact, xfact, zfact dims <- as.integer(c(lastrow, lastcol, length(lyrs), yfact, xfact, zfact)) if (is.na(op)) { if ( canProcessInMemory(x)) { v <- getValuesBlock(x, 1, lastrow, 1, lastcol, lyrs, format='m') v <- .Call("_raster_aggregate_get", v, as.integer(dims), PACKAGE='raster') v <- apply(v, 1, fun, na.rm=na.rm) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, n=nlayers(x)*xfact*yfact, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 #tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { dims[1] <- as.integer(tr$nrows[i]) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol, lyrs, format='m') vals <- .Call("_raster_aggregate_get", vals, as.integer(dims), PACKAGE='raster') vals <- apply(vals, 1, fun, na.rm=na.rm) out <- writeValues(out, matrix(vals, ncol=nlout), tr$write[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } # else if (!is.na(op)) { if ( canProcessInMemory(x)) { x <- getValuesBlock(x, 1, lastrow, 1, lastcol, format='m') out <- setValues(out, .Call("_raster_aggregate_fun", x, dims, as.integer(na.rm), op, PACKAGE='raster')) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 #tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { dims[1] = tr$nrows[i] vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol, format='m') vals <- .Call("_raster_aggregate_fun", vals, dims, na.rm, op, PACKAGE='raster') out <- writeValues(out, vals, tr$write[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } ) raster/R/rasterFromGDAL.R0000644000176200001440000002064514160214773014666 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .gdFixGeoref <- function(mdata) { gdversion <- getOption('rasterGDALVersion') test <- gdversion < '1.8.0' if (test) { if (! is.null(mdata) ) { for (i in 1:length(mdata)) { if (mdata[i] == "AREA_OR_POINT=Area") { return(FALSE) } else if (mdata[i] == "AREA_OR_POINT=Point") { return(TRUE) } } } } return(FALSE) } .rasterFromGDAL <- function(filename, band, type, sub=0, RAT=TRUE, silent=TRUE, warn=TRUE, crs="", ...) { .requireRgdal() if (sub > 0) { gdalinfo <- rgdal::GDALinfo(filename, silent=TRUE, returnRAT=FALSE, returnCategoryNames=FALSE) sub <- round(sub) subdsmdata <- attr(gdalinfo, 'subdsmdata') i <- grep(paste("SUBDATASET_", sub, "_NAME", sep=''), subdsmdata) if (length(i) > 0) { x <- subdsmdata[i[1]] filename <- unlist(strsplit(x, '='))[2] } else { stop(paste('subdataset "sub=', sub, '" not available', sep='')) } } suppressWarnings( gdalinfo <- try ( rgdal::GDALinfo(filename, silent=silent, returnRAT=RAT, returnCategoryNames=RAT) ) ) if ( inherits(gdalinfo, "try-error")) { gdalinfo <- rgdal::GDALinfo(filename, silent=silent, returnRAT=FALSE, returnCategoryNames=FALSE) warning('Could not read RAT or Category names') } nc <- as.integer(gdalinfo[["columns"]]) nr <- as.integer(gdalinfo[["rows"]]) xn <- gdalinfo[["ll.x"]] xn <- round(xn, digits=9) xx <- xn + gdalinfo[["res.x"]] * nc xx <- round(xx, digits=9) yn <- gdalinfo[["ll.y"]] yn <- round(yn, digits=9) yx <- yn + gdalinfo[["res.y"]] * nr yx <- round(yx, digits=9) nbands <- as.integer(gdalinfo[["bands"]]) if (isTRUE(attr(gdalinfo, "ysign") == 1)) { warning("data seems flipped. Consider using: flip(x, direction='y')") } rotated <- FALSE if (gdalinfo['oblique.x'] != 0 | gdalinfo['oblique.y'] != 0) { rotated <- TRUE ## adapted from rgdal::getGeoTransFunc if (warn) { warning('\n\n This file has a rotation\n Support for such files is limited and results of data processing might be wrong.\n Proceed with caution & consider using the "rectify" function\n') } rotMat <- matrix(gdalinfo[c('res.x', 'oblique.x', 'oblique.y', 'res.y')], 2) ysign <- attr(gdalinfo, 'ysign') rotMat[4] <- rotMat[4] * ysign invMat <- solve(rotMat) offset <- c(xn, yx) trans <- function(x, inv=FALSE) { if (inv) { x <- t(t(x) - c(offset[1], offset[2])) x <- round( x %*% invMat + 0.5 ) x[x < 1] <- NA x[x[,1] > nc | x[,2] > nr, ] <- NA } else { x <- (x - 0.5) %*% rotMat x <- t(t(x) + c(offset[1], offset[2])) } return(x) } crd <- trans(cbind(c(0, 0, nc, nc), c(0, nr, 0, nr))+0.5) rot <- methods::new(".Rotation") gtr <- gdalinfo[c('ll.x', 'res.x', 'oblique.x', NA, 'oblique.y', 'res.y')] gtr[4] <- yx gtr[6] <- gtr[6] * ysign rot@geotrans <- gtr rot@transfun <- trans xn <- min(crd[,1]) xx <- max(crd[,1]) yn <- min(crd[,2]) yx <- max(crd[,2]) } mdata <- attr(gdalinfo, 'mdata') fixGeoref <- FALSE try( fixGeoref <- .gdFixGeoref(mdata), silent=TRUE ) # for ENVI files bnames <- unique(mdata[grep("Band_", mdata)]) if (length(bnames) > 0) { bn <- sapply(strsplit(bnames, '='), function(x) x[2]) bi <- gsub("Band_", "", sapply(strsplit(bnames, '='), function(x) x[1])) bnames <- try(bn[order(as.integer(bi))], silent=TRUE) if ( inherits(bnames, "try-error") ) { bnames <- NULL } } else { gobj <- rgdal::GDAL.open(filename) bnames <- rep("", nbands) for (i in 1:nbands) { objbnd <- rgdal::getRasterBand(gobj, i) bnames[i] <- rgdal::getDescription(objbnd) } rgdal::GDAL.close(gobj) } if (type == 'RasterBrick') { r <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs="") r@file@nbands <- r@data@nlayers <- nbands band <- 1:nbands #RAT <- FALSE } else { r <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs="") r@file@nbands <- as.integer(nbands) band <- as.integer(band) if ( band > nbands(r) ) { stop(paste("band too high. Should be between 1 and", nbands)) #if (warn) { #stop("band too high. Set to nbands") #} #band <- nbands(r) } if ( band < 1) { stop(paste("band should be 1 or higher")) #if (warn) { #stop("band too low. Set to 1") #} #band <- 1 } r@data@band <- as.integer(band) nbands <-1 } if (rotated) { r@rotated <- TRUE r@rotation <- rot } prj <- attr(gdalinfo, 'projection') if (!is.na(prj)) { prjcom <- attr(prj, 'comment') if ((!is.null(prjcom) && !is.na(prjcom))) { prj <- prjcom } } crs <- .getProj(prj, crs) r@crs <- .CRS(crs, TRUE) #r@crs <- .CRS(crs, FALSE) # F to avoid warnings about other than WGS84 datums or ellipsoids # r@history[[1]] <- mdata bi <- attr(gdalinfo, 'df') GDType <- as.character(bi[['GDType']]) hasNoDataValues <- bi[['hasNoDataValue']] NoDataValue <- bi[['NoDataValue']] # if (getOption('rasterNewRGDALVersion')) { # sbi <- attr(gdalinfo, 'sdf') # Bmin <- sbi[['Bmin']] # Bmax <- sbi[['Bmax']] # } else { Bmin <- bi[['Bmin']] Bmax <- bi[['Bmax']] # } RATlist <- attr(gdalinfo, 'RATlist') CATlist <- attr(gdalinfo, 'CATlist') blockrows <- integer(nbands) blockcols <- integer(nbands) x <- rgdal::GDAL.open(filename, silent=TRUE) ct <- rgdal::getColorTable( x ) if (! is.null(ct)) { r@legend@colortable <- ct } for (i in 1:nbands) { bs <- rgdal::getRasterBlockSize( rgdal::getRasterBand(x, i) ) blockrows[i] <- bs[1] blockcols[i] <- bs[2] } rgdal::GDAL.close(x) r@file@blockrows <- blockrows r@file@blockcols <- blockcols if (fixGeoref) { message('Fixing "AREA_OR_POINT=Point" georeference') rs <- res(r) xmin(r) <- xmin(r) - 0.5 * rs[1] xmax(r) <- xmax(r) - 0.5 * rs[1] ymin(r) <- ymin(r) + 0.5 * rs[2] ymax(r) <- ymax(r) + 0.5 * rs[2] } if (type == 'RasterBrick') { ub <- unique(bnames) if ((!all(ub == "")) && (length(ub) == nlayers(r))) { names(r) <- bnames } else { names(r) <- rep(gsub(" ", "_", extension(basename(filename), "")), nbands) } } else { lnames <- gsub(" ", "_", extension(basename(filename), "")) if (nbands > 1) { lnames <- paste0(lnames, '_', band) } names(r) <- lnames } r@file@name <- filename r@file@driver <- 'gdal' r@data@fromdisk <- TRUE datatype <- "FLT4S" minv <- rep(Inf, nlayers(r)) maxv <- rep(-Inf, nlayers(r)) try ( minv <- as.numeric( Bmin ) , silent=TRUE ) try ( maxv <- as.numeric( Bmax ) , silent=TRUE ) minv[minv == -4294967295] <- Inf maxv[maxv == 4294967295] <- -Inf try ( datatype <- .getRasterDType ( GDType[1] ), silent=TRUE ) if ( all(c(is.finite(minv), is.finite(maxv)))) { r@data@haveminmax <- TRUE } r@file@datanotation <- datatype r@data@min <- minv[band] r@data@max <- maxv[band] rats <- ! sapply(RATlist, is.null) if (any(rats)) { att <- vector(length=nlayers(r), mode='list') for (i in 1:length(RATlist)) { if (! is.null(RATlist[[i]])) { dr <- data.frame(RATlist[[i]], stringsAsFactors=TRUE) wv <- which(colnames(dr)=='VALUE') if (length(wv) > 0) { if (wv != 1) { dr <- data.frame(dr[,wv,drop=FALSE], dr[,-wv,drop=FALSE]) } colnames(dr)[1] <- 'ID' } else { if (all((colnames(dr) %in% c('Red', 'Green', 'Blue', 'Opacity', 'Histogram')))) { # this is really a color table rats[i] <- FALSE if (is.null(ct)) { r@legend@colortable <- grDevices::rgb(dr$Red, dr$Green, dr$Blue, dr$Opacity) } next } else { j <- which(colnames(dr) == 'Histogram') if (isTRUE(j>0) & ncol(dr) > 1) { dr <- data.frame(ID=0:(nrow(dr)-1), COUNT=dr[,j], dr[,-j,drop=FALSE]) } else { dr <- data.frame(ID=0:(nrow(dr)-1), dr) } } } att[[i]] <- dr } } r@data@attributes <- att[band] r@data@isfactor <- rats[band] } else { cats <- ! sapply(CATlist, is.null) if (any(cats)) { att <- vector(length=nlayers(r), mode='list') for (i in 1:length(CATlist)) { if (! is.null(CATlist[[i]])) { att[[i]] <- data.frame(ID=(1:length(CATlist[[i]]))-1, category=CATlist[[i]], stringsAsFactors=TRUE) } } r@data@attributes <- att[band] r@data@isfactor <- cats[band] } } return(r) } raster/R/netCDFtoRasterGMT.R0000644000176200001440000000230214160021141015260 0ustar liggesusers# Author: Robert J. Hijmans # Date: March 2013 # Version 1.0 # Licence GPL v3 .rasterObjectFromCDF_GMT <- function(nc) { stopifnot(requireNamespace("ncdf4")) dims <- ncdf4::ncvar_get(nc, "dimension", 1) xr <- ncdf4::ncvar_get(nc, "x_range", 1) yr <- ncdf4::ncvar_get(nc, "y_range", 1) zr <- ncdf4::ncvar_get(nc, "z_range", 1) sp <- ncdf4::ncvar_get(nc, "spacing", 1) zvar = 'z' crs <- NA if (xr[1] > -181 & xr[2] < 181 & yr[1] > -91 & yr[2] < 91 ) { crs <- "+proj=longlat +datum=WGS84" } dif1 <- abs(((xr[2] - xr[1]) / dims[1]) - sp[2]) dif2 <- abs(((xr[2] - xr[1]) / (dims[1]-1)) - sp[2]) if (dif1 < dif2) { # 30 sec GEBCO data r <- raster(xmn=xr[1], xmx=xr[2], ymn=yr[1], ymx=yr[2], ncol=dims[1], nrow=dims[2], crs=crs) } else { # 1 min data resx <- (xr[2] - xr[1]) / (dims[1]-1) resy <- (yr[2] - yr[1]) / (dims[2]-1) r <- raster(xmn=xr[1]-(0.5*resx), xmx=xr[2]+(0.5*resx), ymn=yr[1]-(0.5*resy), ymx=yr[2]+(0.5*resy), ncol=dims[1], nrow=dims[2], crs=crs) } r@file@name <- nc$filename r@file@toptobottom <- FALSE attr(r@data, "zvar") <- zvar attr(r@data, "dim3") <- 1 r@file@driver <- "netcdf" r@data@fromdisk <- TRUE return(r) } raster/R/extract.R0000644000176200001440000000056414160021141013543 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='vector'), function(x, y, ...){ y <- round(y) return( .cellValues(x, y, ...) ) }) setMethod('extract', signature(x='Raster', y='sf'), function(x, y, ...){ y <- .sf2sp(y) #if (is.list(x)) {} extract(x, y, ...) } ) raster/R/xyResolution.R0000644000176200001440000000253414160021141014614 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod('xres', signature(x='BasicRaster'), function(x) { if (rotated(x)) { return(x@rotation@geotrans[3]) } else { e <- x@extent return ( (e@xmax - e@xmin) / x@ncols ) } } ) setMethod('yres', signature(x='BasicRaster'), function(x) { if (rotated(x)) { return(x@rotation@geotrans[5]) } else { e <- x@extent return ( (e@ymax - e@ymin) / x@nrows ) } } ) setMethod('res', signature(x='BasicRaster'), function(x) { if (rotated(x)) { return(x@rotation@geotrans[c(2,6)]) } else { e <- x@extent xr <- (e@xmax - e@xmin) / x@ncols yr <- (e@ymax - e@ymin) / x@nrows return( c(xr, yr) ) } } ) setMethod('res<-', signature(x='BasicRaster'), function(x, value) { if (rotated(x)) { stop('cannot set the resolution of a rotated raster') } if (length(value) == 1) { xr=value yr=value } else { xr=value[1] yr=value[2] } bb <- extent(x) nc <- max(1, round( (bb@xmax - bb@xmin) / xr )) nr <- max(1, round( (bb@ymax - bb@ymin) / yr )) if (nr != x@nrows | nc != x@ncols) { if (methods::extends(class(x), "Raster")) { x <- clearValues(x) } } bb@xmax <- bb@xmin + nc * xr bb@ymin <- bb@ymax - nr * yr extent(x) <- bb dim(x) <- c(nr, nc) return(x) } ) raster/R/as.matrix.R0000644000176200001440000000202514160021141013771 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('as.matrix', signature(x='RasterLayer'), function(x, maxpixels, ...) { if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } return( getValues(x, format='matrix') ) }) setMethod('as.matrix', signature(x='RasterStackBrick'), function(x, maxpixels, ...){ if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } return( getValues(x) ) }) setMethod('as.matrix', signature(x='Extent'), function(x, ...) { b <- bbox(x) rownames(b) <- c('x', 'y') b }) # mode argument is ignored as mode=mode gave an error on R-devel setMethod('as.vector', signature(x='Extent'), function(x, mode='any') { as.vector(c(x@xmin, x@xmax, x@ymin, x@ymax)) }) setMethod('as.vector', signature(x='Raster'), function(x, mode='any') { as.vector(getValues(x)) }) raster/R/rasterFromSAGA.R0000644000176200001440000000560314160021141014650 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromSAGAFile <- function(filename, crs="", ...) { valuesfile <- .setFileExtensionValues(filename, "SAGA") if (!file.exists(valuesfile )){ stop( paste(valuesfile, "does not exist")) } filename <- .setFileExtensionHeader(filename, "SAGA") ini <- readIniFile(filename) ini[,2] = toupper(ini[,2]) byteorder <- .Platform$endian ncellvals <- -9 nodataval <- -Inf layernames <- '' toptobottom <- FALSE dfoffset <- as.integer(0) zfactor <- 1 for (i in 1:length(ini[,1])) { if (ini[i,2] == "POSITION_XMIN") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "POSITION_YMIN") { yn <- as.numeric(ini[i,3])} else if (ini[i,2] == "CELLCOUNT_Y") { nr <- as.integer(ini[i,3])} else if (ini[i,2] == "CELLCOUNT_X") { nc <- as.integer(ini[i,3])} else if (ini[i,2] == "CELLSIZE") { cellsize <- as.numeric(ini[i,3])} else if (ini[i,2] == "NODATA_VALUE") { nodataval <- as.numeric(ini[i,3])} else if (ini[i,2] == "DATAFORMAT") { inidatatype <- ini[i,3]} else if (ini[i,2] == "BYTEORDER_BIG") { byteorder <- as.logical(ini[i,3])} # else if (ini[i,2] == "NCELLVALS") {ncellvals <- ini[i,3]} else if (ini[i,2] == "NAME") { layernames <- ini[i,3]} else if (ini[i,2] == "Z_FACTOR") { zfactor <- as.numeric(ini[i,3])} else if (ini[i,2] == "TOPTOBOTTOM") { toptobottom <- as.logical(ini[i,3])} else if (ini[i,2] == "DATAFILE_OFFSET") { dfoffset <- as.integer(ini[i,3])} } xx <- xn + nc * cellsize - (0.5 * cellsize) xn <- xn - (0.5 * cellsize) yx <- yn + nr * cellsize - (0.5 * cellsize) yn <- yn - (0.5 * cellsize) x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) x@file@offset <- dfoffset x@file@toptobottom <- toptobottom if (nchar(layernames) > 1) { lnams <- unlist(strsplit(layernames, ':')) } else { lnams <- gsub(" ", "_", extension(basename(filename), "")) } names(x) <- lnams x@file@name <- filename x@data@haveminmax <- FALSE x@file@nodatavalue <- nodataval if (inidatatype == 'BIT') { stop('cannot process BIT data') } else if (inidatatype == 'BYTE') { dataType(x) <- 'INT1S' } else if (inidatatype == 'BYTE_UNSIGNED') { dataType(x) <- 'INT1U' } else if (inidatatype == 'SHORTINT') { dataType(x) <- 'INT2S' } else if (inidatatype == 'SHORTINT_UNSIGNED') { dataType(x) <- 'INT2U' } else if (inidatatype == 'INTEGER') { dataType(x) <- 'INT4S' } else if (inidatatype == 'INTEGER_UNSIGNED') { dataType(x) <- 'INT4U' } else if (inidatatype == 'FLOAT') { dataType(x) <- 'FLT4S' } else if (inidatatype == 'DOUBLE') { dataType(x) <- 'FLT8S' } if (byteorder) { x@file@byteorder <- 'big' } else { x@file@byteorder <- 'little' } x@data@fromdisk <- TRUE x@data@gain <- zfactor x@file@driver <- 'SAGA' return(x) } raster/R/spplot.R0000644000176200001440000000431114160021141013404 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric("spplot")) { setGeneric("spplot", function(obj, ...) standardGeneric("spplot")) } setMethod("spplot", signature(obj='Raster'), function(obj, ..., maxpixels=50000, as.table=TRUE, zlim) { obj <- sampleRegular(obj, maxpixels, asRaster=TRUE, useGDAL=TRUE) if (!missing(zlim)) { if (length(zlim) != 2) { warning('zlim should be a vector of two elements') } if (length(zlim) >= 2) { zlim <- sort(zlim[1:2]) obj[obj < zlim[1]] <- zlim[1] obj[obj > zlim[2]] <- zlim[2] } } obj <- as(obj, 'SpatialGridDataFrame') #obj@data <- obj@data[, ncol(obj@data):1] spplot(obj, ..., as.table=as.table) } ) # spplot for SpatialPoints object that has no data.frame setMethod('spplot', signature(obj='SpatialPoints'), function(obj, ...) { obj <- sp::SpatialPointsDataFrame(obj, data.frame(ID=1:length(obj))) spplot(obj, ...) }) setMethod('spplot', signature(obj='SpatialPolygons'), function(obj, ...) { obj <- sp::SpatialPolygonsDataFrame(obj, data.frame(ID=1:length(obj))) spplot(obj, ...) }) setMethod('spplot', signature(obj='SpatialLines'), function(obj, ...) { obj <- sp::SpatialLinesDataFrame(obj, data.frame(ID=1:length(obj))) spplot(obj, ...) }) setMethod("lines", signature(x='SpatialPolygons'), function(x, ...) { x <- as(x, 'SpatialLines') lines(x, ...) } ) setMethod("spplot", signature(obj='SpatRaster'), function(obj, ..., maxpixels=50000, as.table=TRUE, zlim) { obj <- as(obj, "Raster") obj <- sampleRegular(obj, maxpixels, asRaster=TRUE) if (!missing(zlim)) { if (length(zlim) != 2) { warning('zlim should be a vector of two elements') } if (length(zlim) >= 2) { obj[obj < zlim[1] | obj > zlim[2]] <- NA } } obj <- as(obj, 'SpatialGridDataFrame') spplot(obj, ..., as.table=as.table) } ) setMethod("spplot", signature(obj="SpatVector"), function(obj, ...) { x <- as(obj, "Spatial") if (.hasSlot(x, "data")) { for (i in 1:ncol(x@data)) { if (is.character(x@data[,i])) { x@data[,i] <- as.factor(x@data[,i]) } } } spplot(x, ...) } ) raster/R/rasterFromASCII.R0000644000176200001440000000630614160215020014767 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromASCIIFile <- function(filename, offset=6, crs="", ...) { offset <- as.integer(offset) stopifnot(offset > 2) splitasc <- function(s) { s <- trim(s) spl <- unlist(strsplit(s, ''), use.names = FALSE) pos <- which(spl==' ')[1] first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } filename <- trim(filename) if (!file.exists(filename)) { stop(paste(filename, " does not exist")) } con <- file(filename, "rt") lines <- readLines(con, n=offset) close(con) ini <- lapply(lines, splitasc) ini <- matrix(unlist(ini, use.names = FALSE), ncol=2, byrow=TRUE) ini[,1] = toupper(ini[,1]) suppressWarnings( test <- sum(as.numeric(ini[,1]), na.rm=TRUE) > 0 ) if (test) { m <- 'The header of this file appears to be incorrect: there are numbers where there should be keywords' if (offset != 6) { m <- paste(m, '\n Are you using a wrong offset?', sep='') } stop(m) } nodataval <- xn <- yn <- d <- nr <- nc <- xc <- yc <- NA for (i in 1:nrow(ini)) { if (ini[i,1] == "NCOLS") { nc <- as.integer(ini[i,2]) } else if (ini[i,1] == "NROWS") { nr <- as.integer(ini[i,2]) } else if (ini[i,1] == "XLLCORNER") { xn <- as.numeric(ini[i,2]) } else if (ini[i,1] == "XLLCENTER") { xc <- as.numeric(ini[i,2]) } else if (ini[i,1] == "YLLCORNER") { yn <- as.numeric(ini[i,2]) } else if (ini[i,1] == "YLLCENTER") { yc <- as.numeric(ini[i,2]) } else if (ini[i,1] == "CELLSIZE") { d <- as.numeric(ini[i,2]) } else if (ini[i,1] == "NODATA_VALUE") { try (nodataval <- as.numeric(ini[i,2]), silent=TRUE) } else if (ini[i,1] == "NODATA") { try (nodataval <- as.numeric(ini[i,2]), silent=TRUE) } } if (is.na(nr)) stop('"NROWS" not detected') if (is.na(nc)) stop('"NCOLS" not detected') if (is.na(nodataval)) { warning('"NODATA_VALUE" not detected. Setting it to -Inf\n You can set it to another value with function "NAvalue"') nodataval <- -Inf } offwarn <- FALSE if (is.na(d)) { warning('"CELLSIZE" not detected. Setting it to 1.'); offwarn = TRUE d <- 1 } else if (d==0) { warning('"CELLSIZE" is reported as zero. Setting it to 1.'); d <- 1 } d <- abs(d) if (is.na(xn)) { if (is.na(xc)) { warning('"XLLCORNER" tag not detected. Setting it to 0.') offwarn = TRUE xn <- 0 } else { xn <- xc - 0.5 * d } } if (is.na(yn)) { if (is.na(yc)) { warning('"YLLCORNER" tag not detected. Setting it to 0.'); offwarn = TRUE yn <- 0 } else { yn <- yc - 0.5 * d } } if (offwarn) { m <- 'The georeference of this object is probably wrong\n' if (offset != 6) { m <- paste(m, ' Are you using a wrong offset? Proceed with caution!\n', sep='') } warning(m) } xx <- xn + nc * d yx <- yn + nr * d x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs='') x@data@fromdisk <- TRUE x@file@offset <- offset x@file@driver <- 'ascii' x@file@nodatavalue <- nodataval x@file@name <- filename if (!is.na(crs)) { projection(x) <- .CRS() } return(x) } raster/R/rasterFromXYZ.R0000644000176200001440000000435014160021141014625 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 rasterFromXYZ <- function(xyz, res=c(NA, NA), crs="", digits=5) { if (length(res) == 1) res = c(res, res) if (inherits(xyz, 'SpatialPoints')) { if (inherits(xyz, 'SpatialPointsDataFrame')) { xyz <- cbind(sp::coordinates(xyz)[,1:2,drop=FALSE], xyz@data[,1]) } else { xyz <- sp::coordinates(xyz)[,1:2,drop=FALSE] } } ln <- colnames(xyz) if (inherits(xyz, 'data.frame')) { xyz <- as.matrix(xyz) xyz <- matrix(as.numeric(xyz), ncol=ncol(xyz), nrow=nrow(xyz)) } xyz <- xyz[(!is.na(xyz[,1])) & (!is.na(xyz[,2])), ] x <- sort(unique(xyz[,1])) dx <- x[-1] - x[-length(x)] if (is.na(res[1])) { if (length(x) < 2) { stop("more than one unique x value needed") } rx <- min(dx) for (i in 1:5) { rx <- rx / i q <- sum(round(dx / rx, digits=digits) %% 1) if ( q == 0 ) { break } } if ( q > 0 ) { stop('x cell sizes are not regular') } } else { rx <- res[1] test <- sum(round(dx / rx, digits=digits) %% 1) if ( test > 0 ) { stop('x cell sizes are not regular') } } y <- sort(unique(xyz[,2])) dy <- y[-1] - y[-length(y)] # probably a mistake to use the line below # Gareth Davies suggested that it be removed # dy <- round(dy, digits) if (is.na(res[2])) { if (length(y) < 2) { stop("more than one unique y value needed") } ry <- min(dy) for (i in 1:5) { ry <- ry / i q <- sum(round(dy / ry, digits=digits) %% 1) if ( q == 0 ) { break } } if ( q > 0 ) { stop('y cell sizes are not regular') } } else { ry <- res[2] test <- sum(round(dy / ry, digits=digits) %% 1) if ( test > 0 ) { stop('y cell sizes are not regular') } } minx <- min(x) - 0.5 * rx maxx <- max(x) + 0.5 * rx miny <- min(y) - 0.5 * ry maxy <- max(y) + 0.5 * ry d <- dim(xyz) if (d[2] <= 3) { r <- raster(xmn=minx, xmx=maxx, ymn=miny, ymx=maxy, crs=crs) } else { r <- brick(xmn=minx, xmx=maxx, ymn=miny, ymx=maxy, crs=crs, nl=d[2]-2) } res(r) <- c(rx, ry) cells <- cellFromXY(r, xyz[,1:2]) if (d[2] > 2) { names(r) <- ln[-c(1:2)] r[cells] <- xyz[,3:d[2]] } return(r) } raster/R/direction.R0000644000176200001440000000371414160021141014051 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # revised October 2011 # Version 1.0 # Licence GPL v3 setMethod('direction', signature(x='RasterLayer'), function(x, filename='', degrees=FALSE, from=FALSE, doEdge=FALSE, ...) { out <- raster(x) if (couldBeLonLat(out)) { longlat=TRUE } else { longlat=FALSE } if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', asNA=TRUE, progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (inherits(pts, "try-error")) { stop('This function has not yet been implemented for very large files') } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a direction)') } filename <- trim(filename) if ( canProcessInMemory(out, 3)) { vals <- getValues(x) i <- which(is.na(vals)) xy <- xyFromCell(out, i) vals[] <- NA vals[i] <- .Call('_raster_directionToNearestPoint', xy, pts, longlat, degrees, from, a=6378137.0, f=1/298.257223563, PACKAGE='raster') out <- setValues(out, vals) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } out <- writeStart(out, filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='direction', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- NA if (length(j) > 0) { vals[j] <- .Call('_raster_directionToNearestPoint', xy[j, ,drop=FALSE], pts, longlat, degrees, from, a=6378137.0, f=1/298.257223563, PACKAGE='raster') } out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) raster/R/hist.R0000644000176200001440000000431514160021141013036 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod('hist', signature(x='Raster'), function(x, layer, maxpixels=100000, plot=TRUE, main, ...) { if (missing(layer)) { y <- 1:nlayers(x) } else if (is.character(layer)) { y <- match(layer, names(x)) } else { y <- layer } y <- unique(as.integer(round(y))) y <- stats::na.omit(y) y <- y[ y >= 1 & y <= nlayers(x) ] nl <- length(y) if (nl == 0) { stop('no layers selected') } if (missing(main)) { main=names(x) } if (nl > 1) { res <- list() if (nl > 16) { warning('only the first 16 layers are plotted') nl <- 16 y <- y[1:16] } nc <- ceiling(sqrt(nl)) nr <- ceiling(nl / nc) mfrow <- graphics::par("mfrow") spots <- mfrow[1] * mfrow[2] if (spots < nl) { graphics::par(mfrow=c(nr, nc)) } for (i in 1:length(y)) { res[[i]] = .hist1(raster(x, y[i]), maxpixels=maxpixels, main=main[y[i]], plot=plot, ...) } } else if (nl==1) { if (nlayers(x) > 1) { x <- x[[y]] main <- main[y] } res <- .hist1(x, maxpixels=maxpixels, main=main, plot=plot, ...) } if (plot) { return(invisible(res)) } else { return(res) } } ) .hist1 <- function(x, maxpixels, main, plot, ...){ if ( inMemory(x) ) { v <- getValues(x) } else if ( fromDisk(x) ) { if (ncell(x) <= maxpixels) { v <- stats::na.omit(getValues(x)) } else { # TO DO: make a function that does this by block and combines all data into a single histogram v <- sampleRandom(x, maxpixels) msg <- paste(round(100 * maxpixels / ncell(x)), "% of the raster cells were used", sep="") if (maxpixels > length(v)) { msg <- paste(msg, " (of which ", 100 - round(100 * length(v) / maxpixels ), "% were NA)", sep="") } warning( paste(msg, ". ",length(v)," values used.", sep="") ) } } else { stop('cannot make a histogram; need data on disk or in memory') } if (.shortDataType(x) == 'LOG') { v <- v * 1 } if (plot) { hist(v, main=main, plot=plot, ...) } else { hist(v, plot=plot, ...) } } raster/R/extractPolygons.R0000644000176200001440000002510014160021141015267 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='SpatialPolygons'), function(x, y, fun=NULL, na.rm=FALSE, exact=FALSE, weights=FALSE, normalizeWeights=TRUE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...){ #px <-.getCRS(x, asText=FALSE) px <-.getCRS(x) comp <- compareCRS(px,.getCRS(y), unknown=TRUE) if (!comp) { .requireRgdal() warning('Transforming SpatialPolygons to the crs of the Raster') y <- sp::spTransform(y, px) } spbb <- sp::bbox(y) rsbb <- bbox(x) addres <- max(res(x)) npol <- length(y@polygons) res <- list() res[[npol+1]] <- NA if (!is.null(fun)) { cellnumbers <- FALSE if (weights || exact) { if (!is.null(fun)) { fun <- match.fun(fun) test <- try(methods::slot(fun, 'generic') == 'mean', silent=TRUE) if (!isTRUE(test)) { warning('"fun" was changed to "mean"; other functions cannot be used when "weights=TRUE"' ) } } fun <- function(x, ...) { # some complexity here because different layers could # have different NA cells if ( is.null(x) ) { return(rep(NA, nl)) } w <- x[,nl+1] x <- x[,-(nl+1), drop=FALSE] x <- x * w w <- matrix(rep(w, nl), ncol=nl) w[is.na(x)] <- NA w <- colSums(w, na.rm=TRUE) x <- apply(x, 1, function(X) { X / w } ) if (!is.null(dim(x))) { rowSums(x, na.rm=na.rm) } else { sum(x, na.rm=na.rm) } } } if (sp) { df <- TRUE } doFun <- TRUE } else { if (sp) { sp <- FALSE df <- FALSE warning('argument sp=TRUE is ignored if fun=NULL') #} else if (df) { # df <- FALSE # warning('argument df=TRUE is ignored if fun=NULL') } doFun <- FALSE } if (missing(layer)) { layer <- 1 } else { layer <- max(min(nlayers(x), layer), 1) } if (missing(nl)) { nl <- nlayers(x) - layer + 1 } else { nl <- max(min(nlayers(x)-layer+1, nl), 1) } if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { if (df) { res <- data.frame(matrix(ncol=1, nrow=0)) colnames(res) <- 'ID' return(res) } return(res[1:npol]) } rr <- raster(x) pb <- pbCreate(npol, label='extract', ...) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(npol, length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() .sendCall <- eval( parse( text="parallel:::sendCall") ) parallel::clusterExport(cl, c('rsbb', 'rr', 'weights', 'exact', 'addres', 'cellnumbers', 'small'), envir=environment()) clFun <- function(i, pp) { spbb <- sp::bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) if (normalizeWeights) { weight <- xy[,3] / sum(xy[,3]) } else { weight <- xy[,3] #/ 100 } xy <- xy[, -3, drop=FALSE] } else if (exact) { erc <- crop(x, rc) xy <- exactextractr::exact_extract(erc, pp, include_cell=cellnumbers, progress=FALSE)[[1]] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) r <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch very small polygons if (exact) { if (weights) { if (normalizeWeights) { xy$coverage_fraction <- xy$coverage_fraction / sum(xy$coverage_fraction) } colnames(xy)[ncol(xy)] <- "weight" } else { xy$coverage_fraction <- NULL } if (cellnumbers) { nms <- colnames(xy) # not good if there is a layer called cell nms <- c("cell", nms[nms != "cell"]) xy <- xy[,nms] } r <- as.matrix(xy) } else { r <- .xyValues(x, xy, layer=layer, nl=nl) if (weights) { if (cellnumbers) { cell <- cellFromXY(x, xy) r <- cbind(cell, r, weight) } else { r <- cbind(r, weight) } } else if (cellnumbers) { cell <- cellFromXY(x, xy) r <- cbind(cell, r) } } } else { if (small) { ppp <- pp@polygons[[1]]@Polygons ishole <- sapply(ppp, function(z)z@hole) xy <- lapply(ppp, function(z)z@coords) xy <- xy[!ishole] if (length(xy) > 0) { cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z)), use.names = FALSE)) value <- .cellValues(x, cell, layer=layer, nl=nl) if (weights | exact) { weight=rep(1/NROW(value), NROW(value)) if (cellnumbers) { r <- cbind(cell, value, weight) } else { r <- cbind(value, weight) } } else if (cellnumbers) { r <- cbind(cell, value) } else { r <- value } } else { r <- NULL } } else { r <- NULL } } } r } for (ni in 1:nodes) { .sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni) } for (i in 1:npol) { d <- .recvOneData(cl) if (! d$value$success) { stop('cluster error at polygon: ', i) } if (doFun) { if (!is.null(d$value$value)) { if (nl > 1 & !(weights | exact)) { res[[d$value$tag]] <- apply(d$value$value, 2, fun, na.rm=na.rm) } else { res[[d$value$tag]] <- fun(d$value$value, na.rm=na.rm) } } } else { res[[d$value$tag]] <- d$value$value } ni <- ni + 1 if (ni <= npol) { .sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni) } pbStep(pb, i) } } else { for (i in 1:npol) { pp <- y[i,] spbb <- sp::bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (exact) { erc <- crop(x, rc) xy <- exactextractr::exact_extract(erc, pp, include_cell=cellnumbers, progress=FALSE)[[1]] } else if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) if (normalizeWeights) { weight <- xy[,3] / sum(xy[,3]) } else { weight <- xy[,3] #/ 100 } xy <- xy[,-3,drop=FALSE] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch holes or very small polygons if (exact) { if (weights) { if (normalizeWeights) { xy$coverage_fraction <- xy$coverage_fraction / sum(xy$coverage_fraction) } colnames(xy)[ncol(xy)] <- "weight" } else { xy$coverage_fraction <- NULL } if (cellnumbers) { nms <- colnames(xy) # not good if there is a layer called cell nms <- c("cell", nms[nms != "cell"]) xy <- xy[,nms] } if (ncol(xy) == 1) { res[[i]] <- unlist(xy, use.names =FALSE) } else { res[[i]] <- as.matrix(xy) } } else if (weights) { value <- .xyValues(x, xy, layer=layer, nl=nl) if (cellnumbers) { cell <- cellFromXY(x, xy) res[[i]] <- cbind(cell, value, weight) } else { res[[i]] <- cbind(value, weight) } } else if (cellnumbers) { value <- .xyValues(x, xy, layer=layer, nl=nl) cell <- cellFromXY(x, xy) res[[i]] <- cbind(cell, value) } else { res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl) } } else if (small) { ppp <- pp@polygons[[1]]@Polygons ishole <- sapply(ppp, function(z)z@hole) xy <- lapply(ppp, function(z)z@coords) xy <- xy[!ishole] if (length(xy) > 0) { cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z))), use.names = FALSE) value <- .cellValues(x, cell, layer=layer, nl=nl) if (weights | exact) { weight <- rep(1/NROW(value), NROW(value)) if (cellnumbers) { res[[i]] <- cbind(cell, value, weight) } else { res[[i]] <- cbind(value, weight) } } else if (cellnumbers) { res[[i]] <- cbind(cell, value) } else { res[[i]] <- value } } # else do nothing; res[[i]] <- NULL } if (doFun) { if (!is.null(res[[i]])) { if (nl > 1 & !(weights | exact)) { res[[i]] <- apply(res[[i]], 2, fun, na.rm=na.rm) } else { res[[i]] <- fun(res[[i]], na.rm=na.rm) } } } } pbStep(pb) } } res <- res[1:npol] pbClose(pb) if (! is.null(fun)) { # try to simplify i <- sapply(res, length) if (length(unique(i[i != 0])) == 1) { if (any(i == 0)) { lng <- length(res) v <- do.call(rbind, res) res <- matrix(NA, nrow=lng, ncol=ncol(v)) res[which(i > 0), ] <- v } else { res <- do.call(rbind, res) } } else { if (sp) { warning('cannot return a sp object because the data length varies between polygons') sp <- FALSE df <- FALSE #} else if (df) { #warning('cannot return a data.frame because the data length varies between polygons') #df <- FALSE } } } if (df) { if (!is.list(res)) { res <- data.frame(ID=1:NROW(res), res) } else { res <- data.frame( do.call(rbind, lapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) } lyrs <- layer:(layer+nl-1) if (cellnumbers) { nms <- c('ID', 'cell', names(x)[lyrs]) } else { nms <- c('ID', names(x)[lyrs]) } if ((weights|exact) & is.null(fun)) { nms <- c(nms, 'weight') } colnames(res) <- nms if (any(is.factor(x)) & factors) { i <- ifelse(cellnumbers, 1:2, 1) v <- res[, -i, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,i,drop=FALSE], v) } } if (sp) { if (nrow(res) != npol) { warning('sp=TRUE is ignored because fun does not summarize the values of each polygon to a single number') return(res) } if (!.hasSlot(y, 'data') ) { y <- sp::SpatialPolygonsDataFrame(y, res[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, res[, -1, drop=FALSE]) } return(y) } res } ) raster/R/hdr.R0000644000176200001440000000370114160021141012642 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 hdr <- function(x, format, extension='.wld', filename='') { if (inherits(x, 'RasterStack')) { stop('Only applicable to RasterLayer and RasterBrick classes (and their derivates)') } if (x@file@name == '') { if (filename == '') { stop('Object has no filename; and none provided as argument') } else { x@file@name = filename } } # if (missing(filename)) { # if (x@file@name == '') { # stop('Object has no filename; please provide a "filename=" argument') # } # } else { # fn <- trim(as.character(filename[1])) # if (nchar(fn) < 1) { # stop('invalid filename') # } # x@file@name == fn # } type <- toupper(format) if (type=="RASTER") { .writeHdrRaster(x) } else if (type=="WORLDFILE") { .worldFile(x, extension) } else if (type=="VRT") { .writeHdrVRT(x) .writeStx(x) } else if (type=="BIL") { .writeHdrBIL(x) .writeStx(x) } else if (type=="BSQ") { .writeHdrBIL(x, "BSQ") .writeStx(x) } else if (type=="BIP") { .writeHdrBIL(x, "BIP") .writeStx(x) } else if (type=="ERDASRAW") { .writeHdrErdasRaw(x) .writeStx(x) } else if (type=="ENVI") { .writeHdrENVI(x) .writeStx(x) } else if (type=="SAGA") { .writeHdrSAGA(x) } else if (type=="IDRISI") { .writeHdrIDRISI(x) } else if (type=="IDRISIold") { .writeHdrIDRISI(x, old=TRUE) } else if (type=="PRJ") { .writeHdrPRJ(x, ESRI=TRUE) } else { stop("This file format is not supported") } return( invisible(TRUE) ) } .writeStx <- function(x, filename='') { if (x@data@haveminmax) { if (filename=='') { filename <- filename(x) } if (filename!='') { extension(filename) <- ".stx" thefile <- file(filename, "w") # open a txt file connectionis cat(1, " ", minValue(x), " ", maxValue(x), "\n", file = thefile) close(thefile) } } return( invisible(TRUE) ) } raster/R/raster.R0000644000176200001440000002647514160215035013411 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2008 # Version 1.0 # Licence GPL v3 setMethod('raster', signature(x='missing'), function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, crs, ext, resolution, vals=NULL) { if (missing(ext)) { ext <- extent(xmn, xmx, ymn, ymx) } if (missing(crs)) { if (ext@xmin > -360.01 & ext@xmax < 360.01 & ext@ymin > -90.01 & ext@ymax < 90.01) { prj <- .CRS("+proj=longlat +datum=WGS84") } else { # if sp >= 1.2.1 crs <- .CRS(as.character(NA), doCheckCRSArgs=FALSE) prj <- .CRS(as.character(NA), doCheckCRSArgs=FALSE) } } else { prj <- .CRS(as.character(NA), doCheckCRSArgs=FALSE) try(prj <- .getCRS(crs)) } if (missing(resolution)) { nrows <- as.integer(max(1, round(nrows))) ncols <- as.integer(max(1, round(ncols))) r <- methods::new('RasterLayer', extent=ext, nrows=nrows, ncols=ncols, crs=prj) } else { r <- methods::new('RasterLayer', extent=ext, crs=prj) res(r) <- resolution } if (!is.null(vals)) { return( setValues(r, vals) ) } else { return( r ) } } ) setMethod('raster', signature(x='list'), function(x, crs) { # list should represent an "image" if (is.null(x$x)) { stop('list has no "x"') } if (is.null(x$y)) { stop('list has no "y"') } if (is.null(x$z)) { stop('list has no "z"') } if (! all(dim(x$z) == c(length(x$x), length(x$y)))) { stop('"z" does not have the right dimensions') } # omitted "-1" bug fix by Barry Rowlingson resx <- ( x$x[length(x$x)] - x$x[1] ) / (length(x$x)-1) resy <- ( x$y[length(x$y)] - x$y[1] ) / (length(x$y)-1) xmn <- min(x$x) - 0.5 * resx xmx <- max(x$x) + 0.5 * resx ymn <- min(x$y) - 0.5 * resy ymx <- max(x$y) + 0.5 * resy dx <- abs(max(abs((x$x[-1] - x$x[-length(x$x)])) / resx) - 1) dy <- abs(max(abs((x$y[-1] - x$y[-length(x$y)])) / resy) - 1) if (is.na(dx) | is.na(dy)) { stop('NA values in coordinates') } if (dx > 0.01 | dy > 0.01) { stop('data are not on a regular grid') } if (missing(crs)) { if (xmn > -360.1 & xmx < 360.1 & ymn > -90.1 & ymx < 90.1) { crs <- .CRS("+proj=longlat +datum=WGS84") } else { crs <- .CRS(as.character(NA)) } } else { crs <- .getCRS(crs) } x <- t(x$z) x <- x[nrow(x):1, ] r <- raster( x, xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs ) return(r) } ) setMethod('raster', signature(x='matrix'), function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", template=NULL) { crs <- .getCRS(crs) if (!is.null(template)) { if (inherits(template, 'Extent')) { r <- raster(template, crs=crs) } else { r <- raster(template) } } else { r <- raster(ncols=ncol(x), nrows=nrow(x), xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs) } r <- setValues(r, as.vector(t(x))) return(r) } ) # setMethod('raster', signature(x='big.matrix'), # function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, template=NULL) { # if (isTRUE(is.na(crs))) { # crs <- as.character(NA) # } # if (!is.null(template)) { # if (inherits(template, 'Extent')) { # r <- raster(template, crs=crs) # } else { # r <- raster(template) # } # } else { # r <- raster(ncols=ncol(x), nrows=nrow(x), xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs) # } # # r@file@driver <- 'big.matrix' # # if (is.filebacked(x)) { # # r@file@name <- bigmemory:::file.name(x) # # } # r@data@fromdisk <- TRUE # r@data@inmemory <- FALSE # attr(r@file, 'big.matrix') <- x # return(r) # } # ) setMethod('raster', signature(x='character'), function(x, band=1, ...) { x <- .fullFilename(x) r <- .rasterObjectFromFile(x, band=band, objecttype='RasterLayer', ...) return(r) } ) setMethod('raster', signature(x='BasicRaster'), function(x) { r <- raster(x@extent, nrows=x@nrows, ncols=x@ncols, crs=.getCRS(x)) if (rotated(x)) { r@rotated <- TRUE r@rotation <- x@rotation } return(r) } ) setMethod('raster', signature(x='RasterLayer'), function(x) { r <- raster(x@extent, nrows=x@nrows, ncols=x@ncols, crs=.getCRS(x)) r@rotated <- x@rotated r@rotation <- x@rotation r@file@blockrows <- x@file@blockrows r@file@blockcols <- x@file@blockcols return(r) } ) setMethod('raster', signature(x='RasterStack'), function(x, layer=0){ newindex = -1 if (nlayers(x) > 0) { if (!is.numeric(layer)) { newindex <- which(names(x) == layer)[1] if (is.na (newindex) ) { warning('variable', layer, 'does not exist') newindex = -1 } layer <- newindex } } if ( layer > 0 ) { dindex <- max(1, min(nlayers(x), layer)) if (dindex != layer) { warning(paste("layer was changed to", dindex))} r <- x@layers[[dindex]] names(r) <- names(x)[dindex] } else { r <- raster(extent(x)) dim(r) <- c(nrow(x), ncol(x)) projection(r) <- .getCRS(x) } extent(r) <- extent(x) # perhaps it was changed by user and different on disk if (rotated(x@layers[[1]])) { r@rotated <- TRUE r@rotation <- x@layers[[1]]@rotation } return(r) } ) setMethod('raster', signature(x='RasterBrick'), function(x, layer=0){ newindex <- -1 if (nlayers(x) > 0) { if (!is.numeric(layer)) { newindex <- which(names(x) == layer)[1] if (is.na (newindex) ) { warning('variable', layer, 'does not exist') newindex = -1 } layer <- newindex } layer <- round(layer) } if (layer > 0) { dindex <- as.integer(max(1, min(nlayers(x), layer))) if ( fromDisk(x) ) { if (dindex != layer) { warning(paste("layer was changed to", dindex))} # better raster(filename(x), band=dindex) ? # with zvar for ncdf files? r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=.getCRS(x)) r@file <- x@file r@file@blockrows <- x@file@blockrows r@file@blockcols <- x@file@blockcols r@data@offset <- x@data@offset r@data@gain <- x@data@gain r@data@inmemory <- FALSE r@data@fromdisk <- TRUE r@data@haveminmax <- x@data@haveminmax r@data@band <- dindex r@data@min <- x@data@min[dindex] r@data@max <- x@data@max[dindex] ln <- x@data@names[dindex] if (! is.na(ln) ) { r@data@names <- ln } #zv <- unlist(x@z[1])[dindex] zv <- NULL try( zv <- x@z[[1]][dindex], silent=TRUE ) if (! is.null(zv) ) { r@z <- list(zv) } # ncdf files zvar <- try(methods::slot(x@data, 'zvar'), silent=TRUE) if (!(inherits(zvar, "try-error"))) { attr(r@data, "zvar") <- zvar attr(r@data, "dim3") <- x@data@dim3 attr(r@data, "level") <- x@data@level } r@data@offset <- x@data@offset r@data@gain <- x@data@gain r@file@nodatavalue <- x@file@nodatavalue } else { r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=.getCRS(x)) if ( inMemory(x) ) { if ( dindex != layer ) { warning(paste("layer was changed to", dindex)) } r <- setValues(r, x@data@values[,dindex]) r@data@names <- names(x)[dindex] } } isf <- is.factor(x)[dindex] if (isTRUE(isf)) { r@data@isfactor <- TRUE r@data@attributes <- levels(x)[dindex] } } else { r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=.getCRS(x)) } if (rotated(x)) { r@rotated <- TRUE r@rotation <- x@rotation } return(r) } ) setMethod('raster', signature(x='Extent'), function(x, nrows=10, ncols=10, crs="", ...) { crs <- .getCRS(crs) raster(xmn=x@xmin, xmx=x@xmax, ymn=x@ymin, ymx=x@ymax, ncols=ncols, nrows=nrows, crs=crs, ...) } ) setMethod('raster', signature(x='sf'), function(x, origin, ...){ sp <- .sf2sp(x) raster(sp, origin, ...) } ) setMethod('raster', signature(x='Spatial'), function(x, origin, ...){ r <- raster(extent(x), ...) crs(r) <- .getCRS(x) if (!missing(origin)) { origin(r) <- origin r <- extend(r, 1) r <- crop(r, x, snap='out') } r } ) setMethod('raster', signature(x='SpatialGrid'), function(x, layer=1, values=TRUE){ r <- raster(extent(x)) projection(r) <-.getCRS(x) dim(r) <- c(x@grid@cells.dim[2], x@grid@cells.dim[1]) if (layer < 1) { values <- FALSE } if (inherits(x, 'SpatialGridDataFrame') & values) { if (dim(x@data)[2] > 0) { layer = layer[1] if (is.numeric(layer)) { dindex <- max(1, min(dim(x@data)[2], layer)) if (dindex != layer) { warning(paste("layer was changed to: ", dindex)) } layer <- dindex names(r) <- colnames(x@data)[layer] } else if (!(layer %in% names(x))) { stop(layer, ' is not a valid name') } else { names(r) <- layer } if (is.character( x@data[[layer]]) ) { x@data[[layer]] <- as.factor(x@data[[layer]]) } if (is.factor( x@data[[layer]]) ) { r@data@isfactor <- TRUE levs <- levels(x@data[[layer]]) r@data@attributes <- list(data.frame(ID=1:length(levs), levels=levs)) r <- setValues(r, as.integer(x@data[[layer]])) } else { r <- setValues(r, x@data[[layer]]) } } } return(r) } ) setMethod('raster', signature(x='SpatialPixels'), function(x, layer=1, values=TRUE){ if (inherits(x, 'SpatialPixelsDataFrame')) { if (layer < 1) { x <- as(x, 'SpatialGrid') } else { x <- as(x[layer], 'SpatialGridDataFrame') return(raster(x, values=values)) } } else { x <- as(x, 'SpatialGrid') return(raster(x)) } return(x) } ) setMethod('raster', signature(x='im'), function(x, crs) { r <- as(x, 'RasterLayer') if (!missing(crs)) { projection(r) <- .CRS() } r } ) setMethod('raster', signature(x='kasc'), function(x, crs) { x <- as(x, 'RasterLayer') if (missing(crs)) { e <- x@extent if (e@xmin > -360.1 & e@xmax < 360.1 & e@ymin > -90.1 & e@ymax < 90.1) { crs <- .CRS("+proj=longlat +datum=WGS84") } else { crs <- as.character(NA) } } projection(x) <- crs return(x) } ) setMethod('raster', signature(x='asc'), function(x, crs) { x <- as(x, 'RasterLayer') if (missing(crs)) { e <- x@extent if (e@xmin > -360.1 & e@xmax < 360.1 & e@ymin > -90.1 & e@ymax < 90.1) { crs <- .CRS("+proj=longlat +datum=WGS84") } else { crs <- .CRS(as.character(NA)) } } projection(x) <- crs return(x) } ) setMethod('raster', signature(x='kde'), function(x, crs) { x <- as(x, 'RasterLayer') if (missing(crs)) { e <- x@extent if (e@xmin > -360.1 & e@xmax < 360.1 & e@ymin > -90.1 & e@ymax < 90.1) { crs <- .CRS("+proj=longlat +datum=WGS84") } else { crs <- .CRS(as.character(NA)) } } projection(x) <- crs return(x) } ) setMethod('raster', signature(x='grf'), function(x, i=1) { i <- max(1, i[1]) if (i != 1) { nc <- NCOL(x$data) if (i <= nc) { x$data <- x$data[,i] } else { stop('i is higher than the number of simulations in x') } } as(x, 'RasterLayer') } ) setMethod('raster', signature(x='GridTopology'), # contributed by Michael Sumner function(x) { raster(extent(x), nrows=x@cells.dim[2], ncols=x@cells.dim[1]) } ) setMethod('raster', signature(x='SpatRaster'), function(x) { as(x[[1]], "Raster") } ) raster/R/which.R0000644000176200001440000000237614160021141013176 0ustar liggesusers# Author: Robert J. Hijmans # Date: November 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("Which")) { setGeneric("Which", function(x, ...) standardGeneric("Which")) } setMethod('Which', signature(x='RasterLayer'), function(x, cells=FALSE, na.rm=TRUE, ...) { if (canProcessInMemory(x, 2)){ if (cells) { return(which(as.logical(getValues(x)) == TRUE)) } else { x <- as.logical(x) if (na.rm) { x[is.na(x)] <- FALSE } return(x) } } else { out <- raster(x) if (cells) { vv <- vector() } else { filename <- rasterTmpFile() out <- writeStart(out, filename=filename, format=.filetype(), datatype='INT2S', overwrite=TRUE) } tr <- blockSize(out, n=2) pb <- pbCreate(tr$n, type=.progress() ) for (i in 1:tr$n) { v <- as.logical( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) if (cells) { offs <- (tr$row[i]-1) * out@ncols vv <- c(vv, which(v==TRUE) + offs) } else { v <- as.logical(v) if (na.rm) { v[is.na(v)] <- 0 } out <- writeValues(out, v, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (cells) { return(vv) } else { out <- writeStop(out) return(out) } } } ) raster/R/hdrPRJ.R0000644000176200001440000000062214160021141013215 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 .writeHdrPRJ <- function(x, ESRI=TRUE) { if (.requireRgdal()) { p4s <- wkt(x) if (! inherits(p4s, "try-error")) { prjfile <- filename(x) extension(prjfile) <- '.prj' cat(p4s, file=prjfile) } else { return(FALSE) } return(invisible(TRUE)) } else { return(FALSE) } } raster/R/rowSums.R0000644000176200001440000000504114160021141013543 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2015 # Version 1.0 # Licence GPL v3 setMethod('rowSums', signature(x='Raster'), function(x, na.rm = FALSE, dims = 1L, ...) { nl <- nlayers(x) if (canProcessInMemory(x)) { if(nl == 1) { # colSums because of row-wise Raster objects and col-wise R matrices and return(.colSums(getValues(x), ncol(x), nrow(x), na.rm=na.rm, ...)) } else { r <- .colSums(getValues(x), ncol(x), nrow(x)*nl, na.rm=na.rm, ...) r <- matrix(r, ncol=nl) colnames(r) <- names(x) return(r) } } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='rowSums', ...) nc <- ncol(x) if(nl == 1) { s <- list() for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) s[[i]] <- .colSums(v, nc, tr$nrows[i], na.rm=na.rm, ...) } return(unlist(s, use.names = FALSE)) } else { s <- list() for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) s[[i]] <- .colSums(v, nc, tr$nrows[i]*nl, na.rm=na.rm, ...) } s <- t(matrix(unlist(s), nrow=nl)) colnames(s) <- names(x) return(s) } } } ) setMethod('colSums', signature(x='Raster'), function(x, na.rm = FALSE, dims = 1L, ...) { nl <- nlayers(x) if (canProcessInMemory(x)) { if(nl == 1) { return(.colSums(as.matrix(x), nrow(x), ncol(x), na.rm=na.rm, ...)) } else { r <- getValues(x) s <- list() nc <- ncol(x) nr <- nrow(x) for (i in 1:nl) { v <- matrix(r[,i], nrow=nc) s[[i]] <- .rowSums(v, nc, nr, na.rm=na.rm, ...) } s <- matrix(unlist(s), ncol=nl) colnames(s) <- names(x) return(s) } } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='colSums', ...) nc <- ncol(x) if(nl == 1) { s <- list() for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) s[[i]] <- .colSums(matrix(v, nrow=tr$nrows[i], byrow=TRUE), tr$nrows[i], nc, na.rm=na.rm, ...) } s <- colSums(matrix(unlist(s), nrow=tr$n, byrow=T)) return(s) } else { s <- matrix(nrow=tr$n, ncol=nc*nl) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) for (j in 1:nl) { k <- (j-1) * nc + 1 k <- k:(k+nc-1) s[i, k] <- .colSums(matrix(v[,j], nrow=tr$nrows[i], byrow=TRUE), tr$nrows[i], nc, na.rm=na.rm, ...) } } s <- matrix(.colSums(s, nrow(s), ncol(s), na.rm=na.rm), ncol=nl) colnames(s) <- names(x) return(s) } } } ) raster/R/writeStartStopRaster.R0000644000176200001440000000763314160021141016274 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .startRasterWriting <- function(x, filename, NAflag, update=FALSE, ...) { filename <- trim(filename) if (filename == "") { stop('missing filename') } filetype <- .filetype(filename=filename, ...) filename <- .setFileExtensionHeader(filename, filetype) fnamevals <- .setFileExtensionValues(filename, filetype) if (length(colortable(x)) > 1) { if (is.null(list(...)$datatype)) { datatype <- 'INT1U' } else { datatype <- .datatype(...) } } else { datatype <- .datatype(...) } if (filetype %in% c('SAGA', 'IDRISI')) { if (datatype == 'FLT8S') { datatype = 'FLT4S' } else if (filetype == 'IDRISI') { if (datatype == 'INT2U') { datatype = 'INT2S' warning('IDRISI does not support INT2U. datatype changed to INT2S') } else if (datatype == 'INT4S') { datatype = 'INT2S' warning('IDRISI does not support INT4S. datatype changed to INT2S') } else if (datatype == 'INT1S') { datatype = 'INT1U' warning('IDRISI does not support INT1S. datatype changed to INT1U') } else if (datatype == 'LOG1S') { datatype = 'INT1U' warning('IDRISI does not support LOG1S. datatype changed to INT2S') } } if (filetype == 'SAGA') { resdif <- abs((yres(x) - xres(x)) / yres(x) ) if (resdif > 0.01) { stop( paste( "x has unequal horizontal and vertical resolutions. Such data cannot be stored in SAGA format" ) ) } } } dataType(x) <- datatype if (!missing(NAflag)) { x@file@nodatavalue <- NAflag } if (datatype == 'INT4U') { x@file@nodatavalue <- min(x@file@nodatavalue, 2147483647) # because as.integer returns SIGNED INT4s } overwrite <- .overwrite( ...) if (filetype == 'raster') { if (!overwrite & file.exists(filename)) { stop(paste(filename,"exists.","use 'overwrite=TRUE' if you want to overwrite it")) } } else { if (!overwrite & (file.exists(filename) | file.exists(fnamevals))) { stop(paste(filename,"or", fnamevals, "exists.","use 'overwrite=TRUE' if you want to overwrite it")) } } if (update) { attr(x@file, "con") <- file(fnamevals, "r+b") } else { attr(x@file, "con") <- file(fnamevals, "wb") } attr(x@file, "dsize") <- dataSize(x@file@datanotation) attr(x@file, "dtype") <- .shortDataType(x@file@datanotation) x@data@min <- rep(Inf, nlayers(x)) x@data@max <- rep(-Inf, nlayers(x)) x@data@haveminmax <- FALSE x@file@driver <- filetype x@file@name <- filename if ( filetype %in% c("BIL", "BSQ", "BIP") ) { bandorder <- filetype } else { bandorder <- 'BIL' if (nlayers(x) > 1) { bo <- list(...)$bandorder if (! is.null(bo)) { if (! bo %in% c('BIL', 'BIP', 'BSQ')) { warning('bandorder must be one of "BIL", "BSQ", or "BIP". Set to "BIL"') } else { bandorder <- bo } } } } x@file@bandorder <- bandorder x@file@byteorder <- .Platform$endian return(x) } .stopRasterWriting <- function(x) { close(x@file@con) # fnamevals <- .setFileExtensionValues(x@file@name) # attr(x@file, "con") <- file(fnamevals, "rb") x@data@haveminmax <- TRUE if (x@file@dtype == "INT") { x@data@min <- round(x@data@min) x@data@max <- round(x@data@max) } else if ( x@file@dtype =='LOG' ) { # x@data@min <- as.logical(x@data@min) # x@data@max <- as.logical(x@data@max) } #x@data@min[!is.finite(x@data@min)] <- NA #x@data@max[!is.finite(x@data@max)] <- NA hdr(x, .driver(x)) filename <- .setFileExtensionValues(filename(x), x@file@driver) if (inherits(x, 'RasterBrick')) { r <- brick(filename, native=TRUE) } else { r <- raster(filename, native=TRUE) } if (! r@data@haveminmax) { r@data@min <- x@data@min r@data@max <- x@data@max r@data@haveminmax <- TRUE } h <- .addHeader() if (h != '') { try( hdr(r, h), silent=TRUE ) } return(r) } raster/R/match.R0000644000176200001440000000111514160021141013156 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2011 # October 2011 # version 1 # Licence GPL v3 setMethod("%in%", signature(x='Raster', table='ANY'), function(x, table) { calc(x, function(x) x %in% table) } ) if (!isGeneric("match")) { setGeneric("match", function(x, table, nomatch=NA_integer_, incomparables=NULL) standardGeneric("match")) } setMethod("match", signature(x='Raster', table='ANY', nomatch='ANY', incomparables='ANY'), function(x, table, nomatch, incomparables) { calc(x, function(x) match(x, table, nomatch, incomparables)) } ) raster/R/makeRasterList.R0000644000176200001440000000317314160021141015022 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2008 # Version 0.9 # Licence GPL v3 .addToList <- function(x, r, compare, giveError, unstack) { if (class(r) == 'character') { r <- raster(r) # or r <- unstack(stack(r, -1)) ??? if (compare & length(x)>0) { compareRaster(x[[1]], r) } return( c(x, r) ) } else if (! methods::extends(class(r), 'Raster')) { if (giveError) { stop('... arguments must be a filename or objects that extend the Raster class') } else { return(x) } } else if (unstack & inherits(r, 'RasterStackBrick')) { if ( compare & length(x) > 0 ) { compareRaster(x[[1]], r) } return( c(x, unstack(r)) ) } else { if (compare & length(x) > 0) { compareRaster(x[[1]], r) } return( c(x, r) ) } } .makeRasterList <- function(..., compare=FALSE, giveError=FALSE, unstack=TRUE) { arg <- list(...) x <- list() for (i in seq(along.with=arg)) { if (class(arg[[i]]) == 'list') { for (j in seq(along.with=arg[[i]])) { x <- .addToList(x, arg[[i]][[j]], compare=compare, giveError=giveError, unstack=unstack) } } else { x <- .addToList(x, arg[[i]], compare=compare, giveError=giveError, unstack=unstack) } } fdim <- sapply(x, fromDisk) & sapply(x, inMemory) if (sum(fdim) > 0) { x[fdim] <- sapply(x[fdim], clearValues) } hv <- sapply(x, hasValues) if (sum(hv) < length(x)) { if (sum(hv) == 0) { x <- x[1] } else { x <- x[hv] warning('layer(s) with no data ignored') } } return(x) } setMethod('as.list', signature(x='Raster'), function(x, ...) { .makeRasterList(x, ...) } ) raster/R/weighted.mean.R0000644000176200001440000000313014160021141014600 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 setMethod('weighted.mean', signature(x='RasterStackBrick', w='vector'), function(x, w, na.rm=FALSE, filename='', ...) { stopifnot(length(w) == nlayers(x)) calc(x, fun=function(i) weighted.mean(i, w=w, na.rm=na.rm), filename=filename, ...) } ) setMethod('weighted.mean', signature(x='RasterStackBrick', w='RasterStackBrick'), function(x, w, na.rm=FALSE, filename='', ...) { nlx <- nlayers(x) if (nlayers(w) != nlx) { stop('nlayers of x and w should be the same') } out <- raster(x) filename <- trim(filename) sumw <- sum(w) if (canProcessInMemory(x, nlx*2)) { w <- getValues(w) x <- getValues(x) if (na.rm) { w[is.na(x)] <- NA x[is.na(w)] <- NA } sumw <- apply(w, 1, sum, na.rm=na.rm) w <- apply(w * x, 1, sum, na.rm=na.rm) / sumw w <- setValues(out, w) if (filename != '') { writeRaster(w, filename, ...) } return(w) } else { tr <- blockSize(x, n=nlx*2) pb <- pbCreate(tr$n, , label='weighted.mean', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { ww <- getValues(w, row=tr$row[i], nrows=tr$nrows[i]) xx <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (na.rm) { ww[is.na(xx)] <- NA xx[is.na(ww)] <- NA } wx <- apply(ww * xx, 1, sum, na.rm=na.rm) / apply(ww, 1, sum, na.rm=na.rm) out <- writeValues(out, wx, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/shp.R0000644000176200001440000000464114160021141012663 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.1 # Licence GPL v3 if (!isGeneric("shapefile")) { setGeneric("shapefile", function(x, ...) standardGeneric("shapefile")) } setMethod('shapefile', signature(x='character'), function(x, stringsAsFactors=FALSE, verbose=FALSE, warnPRJ=TRUE, ...) { .requireRgdal() x <- normalizePath(x, winslash = "/", mustWork = FALSE) stopifnot(file.exists(extension(x, '.shp'))) stopifnot(file.exists(extension(x, '.shx'))) stopifnot(file.exists(extension(x, '.dbf'))) if (warnPRJ & !file.exists(extension(x, '.prj'))) { warning('.prj file is missing') } fn <- extension(basename(x), '') rgdal::readOGR(dirname(x), fn, stringsAsFactors=stringsAsFactors, verbose=verbose, ...) } ) setMethod('shapefile', signature(x='Spatial'), function(x, filename='', overwrite=FALSE, ...) { .requireRgdal() stopifnot(filename != '') filename <- normalizePath(filename, winslash = "/", mustWork = FALSE) extension(filename) <- '.shp' if (file.exists(filename)) { if (!overwrite) { stop('file exists, use overwrite=TRUE to overwrite it') } } layer <- basename(filename) extension(layer) <- '' if (!inherits(x, 'Spatial')) { stop('To write a shapefile you need to provide an object of class Spatial*') } else { if (inherits(x, 'SpatialPixels')) { if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPointsDataFrame') } else { x <- as(x, 'SpatialPoints') } warning('Writing SpatialPixels to a shapefile. Writing to a raster file format might be more desirable') } else if ( inherits(x, 'SpatialGrid') ) { stop('These data cannot be written to a shapefile') } if (!.hasSlot(x, 'data')) { if (inherits(x, 'SpatialPolygons')) { x <- sp::SpatialPolygonsDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE) } else if (inherits(x, 'SpatialLines')) { x <- sp::SpatialLinesDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE) } else if (inherits(x, 'SpatialPoints')) { x <- sp::SpatialPointsDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE) } else { stop('These data cannot be written to a shapefile') } } } rgdal::writeOGR(x, filename, layer, driver='ESRI Shapefile', overwrite_layer=overwrite, ...) #extension(filename) <- '.cpg' #writeLines(encoding, filename, sep="") } ) raster/R/as.character.R0000644000176200001440000000153314160230046014432 0ustar liggesusers setMethod("as.character", signature(x="Extent"), function(x, ...) { e <- extent(x) paste0("extent(", paste(as.vector(e), collapse=", "), ")") } ) setMethod("as.character", signature(x="Raster"), function(x, ...) { e <- extent(x) crs <- proj4string(x) crs <- ifelse(is.na(crs), ", crs=''", paste0(", crs='", crs, "'")) if (nlayers(x) < 2) { paste0("raster(", "ncols=",ncol(x), ", nrows=",nrow(x), ", xmn=",e[1], ", xmx=",e[2], ", ymn=",e[3], ", ymx=",e[4], crs, ")" ) } else { paste0("brick(", "ncol=", ncol(x), ", nrow=", nrow(x), ", nl=", nlayers(x), ", xmn=",e[1], ", xmx=",e[2], ", ymn=",e[3], ", ymx=",e[4], crs, ")" ) } } ) #eval(parse(text=as.character(raster()))) #eval(parse(text=as.character(stack()))) raster/R/transpose.R0000644000176200001440000000347614160021141014114 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2010 # Version 1.0 # Licence GPL v3 setMethod('t', signature(x='RasterLayer'), function(x) { r <- raster(x) e <- eold <- extent(r) e@xmin <- eold@ymin e@xmax <- eold@ymax e@ymin <- eold@xmin e@ymax <- eold@xmax extent(r) <- e dim(r) <- c(ncol(x), nrow(x)) if (! hasValues(x)) { return(r) } if (canProcessInMemory(x)) { return(setValues(r, t(as.matrix(x)))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValuesBlock(x, row=1, nrows=r@ncols, col=tr$row[i], ncols=tr$nrows[i]) v <- as.vector(matrix(v, ncol=tr$nrows[i], byrow=TRUE)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod('t', signature(x='RasterStackBrick'), function(x) { b <- brick(x, values=FALSE) e <- eold <- extent(b) e@xmin <- eold@ymin e@xmax <- eold@ymax e@ymin <- eold@xmin e@ymax <- eold@xmax extent(b) <- e dim(b) <- c(ncol(b), nrow(b), nlayers(b)) if (! hasValues(x)) { return(b) } if (canProcessInMemory(x)) { x <- as.array(x, transpose=TRUE) return( brick(x, xmn=xmin(b), xmx=xmax(b), ymn=ymin(b), ymx=ymax(b), crs=projection(b)) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n) b <- writeStart(b, filename=rasterTmpFile(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValuesBlock(x, row=1, nrows=b@ncols, col=tr$row[i], ncols=tr$nrows[i]) for (j in 1:ncol(v)) { v[,j] <- as.vector(matrix(v[,j], ncol=tr$nrows[i], byrow=TRUE)) } b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) pbClose(pb) return(b) } } ) raster/R/crosstab.R0000644000176200001440000000657314160021141013717 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 1.0 # Licence GPL v3 # revised April 2011 setMethod('crosstab', signature(x='Raster', y='Raster'), function(x, y, digits=0, long=FALSE, useNA=FALSE, progress='', ...) { x <- stack(x, y) crosstab(x, digits=digits, long=long, useNA=useNA, progress=progress, ...) } ) setMethod('crosstab', signature(x='RasterStackBrick', y='missing'), function(x, digits=0, long=FALSE, useNA=FALSE, progress='', ...) { nl <- nlayers(x) if (nl < 2) { stop('crosstab needs at least 2 layers') } nms <- names(x) if (canProcessInMemory(x)) { res <- getValues(x) res <- lapply(1:nl, function(i) round(res[, i], digits=digits)) res <- do.call(table, c(res, useNA='ifany')) res <- as.data.frame(res) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='crosstab', progress=progress) res <- NULL for (i in 1:tr$n) { d <- getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) d <- lapply(1:nl, function(i) round(d[, i], digits=digits)) d <- do.call(table, c(d, useNA='ifany')) d <- as.data.frame(d) res <- rbind(res, d) pbStep(pb, i) } pbClose(pb) res <- res[res$Freq > 0, ,drop=FALSE] # some complexity to aggregate keeping # variables that are NA if (useNA) { for (i in 1:(ncol(res)-1)) { if (any(is.na(res[,i]))) { res[,i] <- factor(res[,i], levels=c(levels(res[,i]), NA), exclude=NULL) } } } res <- aggregate(res[, ncol(res), drop=FALSE], res[, 1:(ncol(res)-1), drop=FALSE], sum) } for (i in 1:(ncol(res)-1)) { # get rid of factors res[,i] <- as.numeric(as.character(res[,i])) } if (nrow(res) == 0) { res <- data.frame(matrix(nrow=0, ncol=length(nms)+1)) } colnames(res) <- c(nms, 'Freq') if (! useNA ) { i <- apply(res, 1, function(x) any(is.na(x))) res <- res[!i, ,drop=FALSE] } if (!long) { f <- eval(parse(text=paste('Freq ~ ', paste(nms , collapse='+')))) res <- stats::xtabs(f, data=res, addNA=useNA) } else { res <- res[res$Freq > 0, ,drop=FALSE] res <- res[order(res[,1], res[,2]), ] rownames(res) <- NULL } return(res) } ) .oldcrosstab <- function(x, y, digits=0, long=FALSE, progress, ...) { # old function, not used any more compareRaster(c(x, y)) if (missing(progress)) { progress <- .progress() } if (canProcessInMemory(x, 3) | ( inMemory(x) & inMemory(y) )) { res <- table(first=round(getValues(x), digits=digits), second=round(getValues(y), digits=digits), ...) } else { res <- NULL tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='crosstab', progress=progress) for (i in 1:tr$n) { d <- table( round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), round(getValuesBlock(y, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), ...) if (length(dim(d))==1) { first = as.numeric(names(d)) second = first d <- matrix(d) } else { first = as.numeric(rep(rownames(d), each=ncol(d))) second = as.numeric(rep(colnames(d), times=nrow(d))) } count = as.vector(t(d)) res = rbind(res, cbind(first, second, count)) pbStep(pb, i) } pbClose(pb) res <- stats::xtabs(count~first+second, data=res) } if (long) { return( as.data.frame(res) ) } else { return(res) } } raster/R/imageplot.R0000644000176200001440000002014114160021141014043 0ustar liggesusers# The functions below here were taken from the fields package !!! (image.plot and subroutines) # to be adjusted for the RasterLayer object. # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html .imageplot <- function (x, y, z, add=FALSE, legend=TRUE, nlevel = 64, horizontal = FALSE, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html legend.shrink = 0.5, legend.width = 0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, graphics.reset = FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, col = heat.colors(nlevel), lab.breaks = NULL, axis.args = NULL, legend.args = NULL, midpoint = FALSE, box=TRUE, useRaster=FALSE, ...) { zlim <- range(z, na.rm = TRUE) old.par <- graphics::par(no.readonly = TRUE) if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (!legend.only) { if (!add) { graphics::par(plt = bigplot) } image(x, y, z, add = add, col = col, useRaster=useRaster, ...) big.par <- graphics::par(no.readonly = TRUE) } else { box <- FALSE } if (legend) { if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { graphics::par(old.par) stop("plot region too small to add legend\n") } ix <- 1 minz <- zlim[1] maxz <- zlim[2] binwidth <- (maxz - minz)/nlevel midpoints <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth) iy <- midpoints iz <- matrix(iy, nrow = 1, ncol = length(iy)) breaks <- list(...)$breaks graphics::par(new=TRUE, pty = "m", plt=smallplot, err = -1) if (!is.null(breaks)) { if (is.null(lab.breaks)) { lab.breaks <- as.character(breaks) } axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } if (!horizontal) { if (is.null(breaks)) { image(ix, iy, iz, xaxt="n", yaxt="n", xlab="", ylab="", col=col, useRaster=useRaster) } else { image(ix, iy, iz, xaxt="n", yaxt="n", xlab = "", ylab = "", col=col, breaks=breaks, useRaster=useRaster) } } else { if (is.null(breaks)) { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, useRaster=useRaster) } else { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, breaks = breaks, useRaster=useRaster) } } do.call("axis", axis.args) graphics::box() if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) } if (!is.null(legend.args)) { do.call(graphics::mtext, legend.args) } } mfg.save <- graphics::par()$mfg if (graphics.reset | add) { graphics::par(old.par) graphics::par(mfg = mfg.save, new = FALSE) } else { graphics::par(big.par) graphics::par(plt = big.par$plt, xpd = FALSE) graphics::par(mfg = mfg.save, new = FALSE) } if (!add & box ) graphics::box() invisible() } .polyimage <- function (x, y, z, col = heat.colors(64), transparent.color = "white", # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html midpoint = FALSE, zlim = range(z, na.rm = TRUE), xlim = range(x), ylim = range(y), add = FALSE, border = NA, ...) { polyimageregrid <- function (x) { temp.addcol <- function(X) { N <- ncol(X) cbind(X[, 1] - (X[, 2] - X[, 1]), X, (X[, N] - X[, (N - 1)]) + X[, N]) } M <- nrow(x) N <- ncol(x) x <- (x[, 1:(N - 1)] + x[, 2:N])/2 x <- (x[1:(M - 1), ] + x[2:M, ])/2 x <- t(temp.addcol(x)) t(temp.addcol(x)) } drapecolor <- function (z, col = heat.colors(64), zlim = NULL, transparent.color = "white", midpoint = TRUE) { eps <- 1e-07 if (is.null(zlim)) { zlim <- range(c(z), na.rm = TRUE) } z[(z < zlim[1]) | (z > zlim[2])] <- NA NC <- length(col) M <- nrow(z) N <- ncol(z) if (midpoint) { z <- (z[1:(M - 1), 1:(N - 1)] + z[2:M, 1:(N - 1)] + z[1:(M - 1), 2:N] + z[2:M, 2:N])/4 } dz <- (zlim[2] * (1 + eps) - zlim[1])/NC zcol <- floor((z - zlim[1])/dz + 1) ifelse(zcol > NC, transparent.color, col[zcol]) } Dx <- dim(x) Dy <- dim(y) if (any((Dx - Dy) != 0)) { stop(" x and y matrices should have same dimensions") } Dz <- dim(z) if (all((Dx - Dz) == 0) & !midpoint) { x <- polyimageregrid(x) y <- polyimageregrid(y) } zcol <- drapecolor(z, col = col, midpoint = midpoint, zlim = zlim, transparent.color = transparent.color) if (!add) { plot(xlim, ylim, type = "n", ...) } N <- ncol(x) Nm1 <- N - 1 M <- nrow(x) Mm1 <- M - 1 for (i in (1:Mm1)) { xp <- cbind(x[i, 1:Nm1], x[i + 1, 1:Nm1], x[i + 1, 2:N], x[i, 2:N], rep(NA, Nm1)) yp <- cbind(y[i, 1:Nm1], y[i + 1, 1:Nm1], y[i + 1, 2:N], y[i, 2:N], rep(NA, Nm1)) xp <- c(t(xp)) yp <- c(t(yp)) graphics::polygon(xp, yp, border = NA, col = c(zcol[i, 1:Nm1])) } } .imageplotplt <- function (x, add = FALSE, legend.shrink = 0.9, legend.width = 1, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html horizontal = FALSE, legend.mar = NULL, bigplot = NULL, smallplot = NULL, ...) { old.par <- graphics::par(no.readonly = TRUE) if (is.null(smallplot)) stick <- TRUE else stick <- FALSE if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } char.size <- ifelse(horizontal, graphics::par()$cin[2]/graphics::par()$din[2], graphics::par()$cin[1]/graphics::par()$din[1]) offset <- char.size * ifelse(horizontal, graphics::par()$mar[1], graphics::par()$mar[4]) legend.width <- char.size * legend.width legend.mar <- legend.mar * char.size if (is.null(smallplot)) { smallplot <- old.par$plt if (horizontal) { smallplot[3] <- legend.mar smallplot[4] <- legend.width + smallplot[3] pr <- (smallplot[2] - smallplot[1]) * ((1 - legend.shrink)/2) smallplot[1] <- smallplot[1] + pr smallplot[2] <- smallplot[2] - pr } else { smallplot[2] <- 1 - legend.mar smallplot[1] <- smallplot[2] - legend.width pr <- (smallplot[4] - smallplot[3]) * ((1 - legend.shrink)/2) smallplot[4] <- smallplot[4] - pr smallplot[3] <- smallplot[3] + pr } } if (is.null(bigplot)) { bigplot <- old.par$plt if (!horizontal) { bigplot[2] <- min(bigplot[2], smallplot[1] - offset) } else { bottom.space <- old.par$mar[1] * char.size bigplot[3] <- smallplot[4] + offset } } if (stick & (!horizontal)) { dp <- smallplot[2] - smallplot[1] smallplot[1] <- min(bigplot[2] + offset, smallplot[1]) smallplot[2] <- smallplot[1] + dp } return(list(smallplot = smallplot, bigplot = bigplot)) } raster/R/minValue.R0000644000176200001440000000615014160021141013646 0ustar liggesusers# raster package # Authors: Robert J. Hijmans # Date : September 2009 # Version 1.0 # Licence GPL v3 if (!isGeneric("minValue")) { setGeneric("minValue", function(x, ...) standardGeneric("minValue")) } setMethod('minValue', signature(x='RasterLayer'), function(x, layer=-1, warn=TRUE) { if ( x@data@haveminmax ) { v <- x@data@min if (isTRUE( v == Inf)) { v <- NA } else { if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } } return(v) } else { if (warn) warning('min value not known, use setMinMax') return(NA) } } ) setMethod('minValue', signature(x='RasterBrick'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] if (layer < 1) { if ( x@data@haveminmax ) { v <- x@data@min v[v == Inf] <- NA if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } return(v) } else { warning('min value not known, use setMinMax') return(rep(NA, nlayers(x))) } } else { if ( x@data@haveminmax ) { v <- x@data@min[layer] * x@data@gain + x@data@offset v[v == Inf] <- NA return(v) } else { warning('min value not known, use setMinMax') return(NA) } } } ) setMethod('minValue', signature(x='RasterStack'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] nl <- nlayers(x) if (layer < 1) { v <- vector(length=nl) for (i in 1:nl) { v[i] <- minValue(x@layers[[i]], warn=warn) } } else { if (layer <= nl) { v <- minValue(x@layers[[layer]]) } else { stop('incorrect layer number') } } return(v) } ) if (!isGeneric("maxValue")) { setGeneric("maxValue", function(x, ...) standardGeneric("maxValue")) } setMethod('maxValue', signature(x='RasterLayer'), function(x, layer=-1, warn=TRUE) { if ( x@data@haveminmax ) { v <- x@data@max if (isTRUE( v == -Inf)) { v <- NA } else { if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } } return(v) } else { if (warn) warning('max value not known, use setMinMax') return(NA) } } ) setMethod('maxValue', signature(x='RasterBrick'), function(x, layer=-1, warn=FALSE) { if ( x@data@haveminmax ) { v <- x@data@max v[!is.finite(v)] <- NA if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } return(v) } else { if (warn) warning('max value not known, use setMinMax') v <- rep(NA, nlayers(x)) } layer <- round(layer)[1] if (layer > 0) { if (layer <= nlayers(x)) { v <- v[layer] } else { stop('invalid layer selected') } } return(v) } ) setMethod('maxValue', signature(x='RasterStack'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] nl <- nlayers(x) if (layer < 1) { v <- vector(length=nl) for (i in 1:nl) { v[i] <- maxValue(x@layers[[i]], warn=warn) } } else { if (layer <= nl) { v <- maxValue(x@layers[[layer]]) } else { stop('incorrect layer number') } } return(v) } ) raster/R/netCDFwriteCD.R0000644000176200001440000001516114160241200014455 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .startWriteCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, progress='', att, varname, varunit, varatt, longname, xname, yname, zname, zunit, zatt, NAflag, force_v4=FALSE, ...) { stopifnot(requireNamespace("ncdf4")) filename <- trim(filename) if (filename == '') { stop('provide a filename') } extension(filename) <- .defaultExtension(format='CDF') if (file.exists(filename) & !overwrite) { stop('file exists, use overwrite=TRUE to overwrite it') } dataType(x) <- datatype ncdatatype <- .getNetCDFDType(datatype) nl <- nlayers(x) if (couldBeLonLat(x)) { if (missing(xname)) xname = 'longitude' if (missing(yname)) yname = 'latitude' xunit = 'degrees_east' yunit = 'degrees_north' } else { if (missing(xname)) xname = 'easting' if (missing(yname)) yname = 'northing' xunit = 'meter' # probably yunit = 'meter' # probably } if (missing(varname)) { if (nl == 1) { varname <- names(x) } else { #varname <- x@title varname <- attr(x@data, 'zvar') if (is.null(varname)) { varname <- names(x@z) if (is.null(varname)) { varname <- 'variable' } } } } if (missing(varunit)) varunit <- "" if (missing(longname)) longname <- "" if (inherits(x, 'RasterBrick')) { zv <- 1:nl z <- getZ(x) if (!is.null(z)) { if (!any(is.na(z))) { cls <- substr(class(z)[1], 1, 4) z <- as.numeric(z) if (!any(is.na(z))) { zv[] <- z if (cls[1] %in% c('Date', 'POSI')) { if (missing(zatt)) { if (missing(zname)) { zname <- 'time' } if (cls == 'Date') { zatt <- list('units=days since 1970-1-1') zunit <- 'days' } else { zatt <- list('units=seconds since 1970-1-1 00:00:00') zunit <- 'seconds' } } } } else { warning('z-values cannot be converted to numeric') } } else { warning('z-values contain NA') } } } if (missing(zname)) { zname <- 'z' } if (missing(zunit)) { zunit <- 'unknown' } if (missing(NAflag)) { NAflag <- NAvalue(x) } xdim <- ncdf4::ncdim_def( xname, xunit, xFromCol(x, 1:ncol(x)) ) ydim <- ncdf4::ncdim_def( yname, yunit, yFromRow(x, 1:nrow(x)) ) if (inherits(x, 'RasterBrick')) { zdim <- ncdf4::ncdim_def( zname, zunit, zv, unlim=TRUE ) vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim, ydim, zdim), NAflag, longname, prec = ncdatatype, ... ) } else { vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim, ydim), NAflag, longname, prec = ncdatatype, ... ) } crsdef <- ncdf4::ncvar_def("crs", "", list(), NULL, prec="integer") defs <- list(crsdef, vardef) nc <- ncdf4::nc_create(filename, defs, force_v4=force_v4) prj <- crs(x) if (!is.na(prj)) { ncdf4::ncatt_put(nc, "crs", "proj4", proj4string(prj), prec='text') ncdf4::ncatt_put(nc, varname, "grid_mapping", "crs") ncdf4::ncatt_put(nc, varname, "proj4", as.character(prj), prec='text') } if (! missing(zatt)){ for (i in 1:length(zatt)) { a <- trim(unlist(strsplit(zatt[[i]], '='))) ncdf4::ncatt_put(nc, zname, a[1], a[2]) } } # ncdf4::ncatt_put(nc, varname, '_FillValue', x@file@nodatavalue, prec=ncdatatype, definemode=TRUE) # ncdf4::ncatt_put(nc, varname, 'missing_value', x@file@nodatavalue, prec=ncdatatype) # ncdf4::ncatt_put(nc, varname, 'long_name', longname, prec='text') if (! missing(varatt)){ for (i in 1:length(varatt)) { a <- trim(unlist(strsplit(varatt[i], '='))) ncdf4::ncatt_put(nc, varname, a[1], a[2]) } } ncdf4::ncatt_put(nc, 0, 'Conventions', 'CF-1.4', prec='text') if (! missing(att)){ for (i in 1:length(att)) { a <- trim(unlist(strsplit(att[i], '='))) ncdf4::ncatt_put(nc, 0, a[1], a[2]) } } pkgversion <- drop(read.dcf(file=system.file("DESCRIPTION", package='raster'), fields=c("Version"))) ncdf4::ncatt_put(nc, 0, 'created_by', paste('R, packages ncdf4 and raster (version ', pkgversion, ')', sep=''), prec='text') ncdf4::ncatt_put(nc, 0, 'date', format(Sys.time(), "%Y-%m-%d %H:%M:%S"), prec='text') ncdf4::nc_close(nc) x@data@min <- rep(Inf, nl) x@data@max <- rep(-Inf, nl) x@data@haveminmax <- FALSE x@file@driver <- 'netcdf' x@file@name <- filename x@file@nodatavalue <- NAflag x@title <- varname return(x) } .stopWriteCDF <- function(x) { nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) ncdf4::ncatt_put(nc, x@title, 'min', as.numeric(x@data@min)) ncdf4::ncatt_put(nc, x@title, 'max', as.numeric(x@data@max)) if (inherits(x, 'RasterBrick')) { r <- brick(x@file@name) } else { r <- raster(x@file@name) } return(r) } .writeValuesCDF <- function(x, v, start=1) { rsd <- stats::na.omit(v) if (length(rsd) > 0) { x@data@min <- min(x@data@min, rsd) x@data@max <- max(x@data@max, rsd) } v[is.na(v)] <- x@file@nodatavalue nr <- length(v) / x@ncols v <- matrix(v, ncol=nr) nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start), count=c(x@ncols, nr)) ) return(x) } .writeValuesBrickCDF <- function(x, v, start=1, layer) { if (missing(layer)) { nl <- nlayers(x) lstart <- 1 lend <- nl w <- getOption('warn') options('warn'=-1) rsd <- apply(v, 2, range, na.rm=TRUE) x@data@min <- pmin(x@data@min, rsd[1,]) x@data@max <- pmax(x@data@max, rsd[2,]) options('warn'= w) } else { nl <- 1 lstart <- layer lend <- layer rsd <- stats::na.omit(v) if (length(rsd) > 0) { x@data@min[layer] <- min(x@data@min[layer], rsd) x@data@max[layer] <- max(x@data@max[layer], rsd) } } ncols <- x@ncols v[is.na(v)] = x@file@nodatavalue rows <- length(v) / (ncols * nl) v <- array(v, c(rows, ncols, nl)) nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start, lstart), count=c(ncols, rows, lend) ) ) return(x) } #.rasterSaveAsNetCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, ...) { # x <- .startWriteCDF(x, filename=filename, datatype=datatype, overwrite=overwrite, ...) # if (nlayers(x) > 1) { # x <- .writeValuesBrickCDF(x, getValues(x) ) # } else { # x <- .writeValuesCDF(x, getValues(x)) # } # return( .stopWriteCDF(x) ) #} #library(raster) #r = raster(ncol=10, nrow=5) #r[] = c(1:49, NA) #names(r) = 'hello world' #a = .rasterSaveAsNetCDF(r, 'test.nc', overwrite=TRUE) #plot(a) #print(a) raster/R/distanceToEdge.R0000644000176200001440000000120114160021141014740 0ustar liggesusers .distToEdge <- function(x) { xy1 <- xyFromCell(x, 1) xy2 <- xyFromCell(x, ncell(x)) a <- cbind(xFromCol(x, 1), yFromRow(x, 1:nrow(x))) b <- cbind(xFromCol(x, 2), yFromRow(x, 1:nrow(x))) dX <- pointDistance(a,b,longlat=T) m = matrix(1:ncol(x), nrow=nrow(x), ncol=ncol(x), byrow=T) m <- m * dX z <- raster(x) z[] <- m z2 <- flip(z, 'x') z <- min(z, z2) dY1 <- pointDistance(xy1, cbind(xy1[1], yFromRow(x, 1:nrow(x))), longlat=T) dY2 <- pointDistance(xy2, cbind(xy2[1], yFromRow(x, 1:nrow(x))), longlat=T) dY <- pmin(dY1, dY2) b <- raster(x) b[] <- rep(dY, each=ncol(x)) d <- min(z,b) d } raster/R/compare_Logical.R0000644000176200001440000002603514160021141015152 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .getAdjustedE <- function(r, tr, i, e) { startcell <- cellFromRowCol(r, tr$row[i] , 1) len <- cellFromRowCol(r, tr$row[i] + (tr$nrows[i]-1), ncol(r)) - startcell + 1 n <- (startcell / length(e)) %% 1 if (n > 0 ) { start <- round(n * length(e)) } else { start <- 1 } out <- c(e[start:length(e)], rep(e, floor(len/length(e)))) out[1:len] } .asLogical <- function(x) { x[x!=0] <- 1 return(x) } setMethod('==', signature(e1='BasicRaster', e2='BasicRaster'), function(e1,e2){ cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) return(cond) } ) setMethod('!=', signature(e1='BasicRaster', e2='BasicRaster'), function(e1,e2){ cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) return(!cond) } ) setMethod('!', signature(x='Raster'), function(x){ if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return(setValues(r, ! getValues(x))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- ! .asLogical(getValues(x, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("Compare", signature(e1='Raster', e2='logical'), function(e1,e2){ nl <- nlayers(e1) if (nl > 1) { r <- brick(e1, values=FALSE) } else { r <- raster(e1) } if (length(e2) > 1 & nl > 1) { if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(t(getValues(e1)), e2 ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(getValues(e1), e2 ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='logical', e2='Raster'), function(e1,e2){ nl <- nlayers(e2) if (nl > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e2) } if (length(e1) > 1 & nl > 1) { if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(e1, t(getValues(e2)) ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric(e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(e1, getValues(e2) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e1) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- methods::callGeneric(e1, getValues(e, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='Raster', e2='numeric'), function(e1, e2){ nl <- nlayers(e1) if (nl > 1) { r <- brick(e1, values=FALSE) } else { r <- raster(e1) } if (length(e2) > 1 & nl > 1) { if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(t(getValues(e1)), e2 ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(getValues(e1), e2)) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='numeric', e2='Raster'), function(e1, e2){ nl <- nlayers(e2) if (nl > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e2) } if (length(e1) > 1 & nl > 1) { if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(e1, t(getValues(e2))) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric(e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(e1, getValues(e2))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- methods::callGeneric(e, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='Raster', e2='Raster'), function(e1, e2){ if (nlayers(e1) > 1) { if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) { stop('number of layers of objects do not match') } r <- brick(e1, values=FALSE) } else if (nlayers(e2) > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e1) } cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) if (!cond) { stop("Cannot compare Rasters that have different BasicRaster attributes. See compareRaster()") } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, methods::callGeneric(getValues(e1), getValues(e2))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod("Logic", signature(e1='Raster', e2='Raster'), function(e1, e2){ if (nlayers(e1) > 1) { r <- brick(e1, values=FALSE) if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) { stop('number of layers of objects do not match') } } else if (nlayers(e2) > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e1) } cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) if (!cond) { stop("Cannot compare Rasters that have different BasicRaster attributes. See compareRaster()") } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, methods::callGeneric(.asLogical(getValues(e1)), .asLogical(getValues(e2)))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- methods::callGeneric(.asLogical(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), .asLogical(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod("Compare", signature(e1='Extent', e2='Extent'), function(e1,e2){ a <- methods::callGeneric(e2@xmin, e1@xmin) b <- methods::callGeneric(e1@xmax, e2@xmax) c <- methods::callGeneric(e2@ymin, e1@ymin) d <- methods::callGeneric(e1@ymax, e2@ymax) a & b & c & d } ) raster/R/cor.R0000644000176200001440000000140014160021141012642 0ustar liggesusers .cor <- function(x, n=Inf, ...) { nl <- nlayers(x) if (nl < 2) return(1) if (n < ncell(x)) { x <- sampleRegular(x, size=n, asRaster=TRUE) } if (canProcessInMemory(x, nlayers(x)*4)) { s <- stats::na.omit(getValues(x)) s <- stats::cor(s) } else { msk <- sum(x, na.rm=FALSE) x <- mask(x, msk) mx <- cellStats(x, 'mean') sx <- cellStats(x, 'sd') nc <- ncell(x) s <- matrix(NA, nrow=n, ncol=n) for (i in 1:(nl-1)) { for (j in (i+1):nl) { s[j,i] <- s[i,j] <- cellStats(((x[[i]] - mx[i]) * (x[[j]] - mx[j])) / (sx[i] * sx[j]), sum)/ (nc-1) } } diag(s) <- 1 } if (nrow(s) == 2) { s[2,1] } else { colnames(s) <- rownames(s) <- names(x) s } } raster/R/idwValue.R0000644000176200001440000000301714160021141013645 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 1.0 # Licence GPL v3 # under development ..idwValue <- function(raster, xy, ngb=4, pow=1, layer, n) { r <- raster(raster) longlat <- couldBeLonLat(r) cells <- cellFromXY(r, xy) adj <- adjacent(r, cells, ngb, pairs=TRUE, include=TRUE, id=TRUE) uc <- unique(adj[,3]) row1 <- rowFromCell(r, min(uc, na.rm=TRUE)) nrows <- row1 - 1 + rowFromCell(r, max(uc, na.rm=TRUE)) offs <- cellFromRowCol(r, row1, 1) - 1 cs <- uc - offs nl <- nlayers(raster) if (nl==1) { v <- cbind(uc, v=getValues(raster, row1, nrows)[cs]) } else { v <- cbind(uc, v=getValues(raster, row1, nrows)[cs,]) } m <- merge(adj, v, by.x='to', by.y=1) colnames(xy) <- c('x', 'y') m <- merge(m, cbind(1:nrow(xy), xy), by.x='id', by.y=1) pd <- pointDistance(m[,c('x', 'y')], xyFromCell(r, m$to), lonlat=longlat) / 1000 pd <- pd^pow pd[pd==0] <- 1e-12 if (nl==1) { pd[is.na(m$v)] <- NA as.vector( tapply(m$v*(1/pd), m$id, sum, na.rm=TRUE) / tapply(1/pd, m$id, sum, na.rm=TRUE) ) #cbind(as.integer(names(res)), res) } else { lys <- 4:(4+nl-1) a1 <- aggregate(m[,lys]*(1/pd), list(m$id), sum) a2 <- aggregate(1/pd, list(m$id), sum) res <- as.matrix(a1[,-1]) / as.vector(as.matrix(a2[,-1])) res <- cbind(as.vector(a1[,1]), res) res[, -1] } } #a=raster(nc=10,nr=10) #xmin(a)=55 #projection(a) = "+proj=utm +zone=33" #a[] = 1:ncell(a) #a[50:75]=NA #r = disaggregate(raster(a), 3) #r[] = .idwValue(a, sp::coordinates(r)) #plot(r) raster/R/gridDistance.R0000644000176200001440000001340614167436761014521 0ustar liggesusers# Author: Jacob van Etten # email jacobvanetten@yahoo.com # Date : May 2010 # Version 1.1 # Licence GPL v3 # RH: updated for igraph (from igraph0) # sept 23, 2012 setMethod("gridDistance", signature("RasterLayer"), function(x, origin, omit=NULL, filename="", ...) { if( !requireNamespace("igraph")) { stop('you need to install the igraph package to be able to use this function') } if (missing(origin)) { stop("you must supply an 'origin' argument") } if (! hasValues(x) ) { stop('cannot compute distance on a RasterLayer with no data') } lonlat <- couldBeLonLat(x) filename <- trim(filename) if (filename != "" & file.exists(filename)) { if (! .overwrite(...)) { stop("file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it") } } # keep canProcessInMemory for debugging # need to test more to see how much igraph can deal with if ( canProcessInMemory(x, n=10) ) { out <- raster(x) x <- getValues(x) # to avoid keeping values in memory twice oC <- which(x %in% origin) ftC <- which(!(x %in% omit)) v <- .calcDist(out, ncell(out), ftC, oC, lonlat=lonlat) v[is.infinite(v)] <- NA out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(x, n=1) pb <- pbCreate(tr$n*2 - 1, ...) #going up r1 <- writeStart(raster(x), rasterTmpFile(), overwrite=TRUE) for (i in tr$n:1) { chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) startCell <- (tr$row[i]-1) * ncol(x) chunkSize <- length(chunk) oC <- which(chunk %in% origin) ftC <- which(!(chunk %in% omit)) if (length(ftC) != 0) { if (i < tr$n) { firstRowftC <- firstRowftC + chunkSize chunkDist <- .calcDist(x, chunkSize=chunkSize + ncol(x), ftC=c(ftC, firstRowftC), oC=c(oC, firstRowftC), perCell=c(rep(0,times=length(oC)),firstRowDist), startCell=startCell, lonlat=lonlat)[1:chunkSize] } else { chunkDist <- .calcDist(x, chunkSize=chunkSize, ftC=ftC, oC=oC, perCell=0, startCell=startCell, lonlat=lonlat) } } else { if (i < tr$n) { firstRowftC <- firstRowftC + chunkSize } chunkDist <- rep(NA, tr$nrows[i] * ncol(r1)) } firstRow <- chunk[1:ncol(x)] firstRowDist <- chunkDist[1:ncol(x)] firstRowftC <- which(!(firstRow %in% omit)) firstRowDist <- firstRowDist[firstRowftC] chunkDist[is.infinite(chunkDist)] <- NA r1 <- writeValues(r1, chunkDist, tr$row[i]) pbStep(pb) } r1 <- writeStop(r1) #going down out <- writeStart(raster(x), filename=filename, overwrite=TRUE, ...) for (i in 1:tr$n) { chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) chunkSize <- length(chunk) startCell <- (tr$row[i]-1) * ncol(x) oC <- which(chunk %in% origin) ftC <- which(!(chunk %in% omit)) if (length(ftC) != 0) { if (i > 1) { chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) chunkDist[is.na(chunkDist)] <- Inf chunkDist <- pmin(chunkDist, .calcDist(x, chunkSize=chunkSize+ncol(x), ftC = c(lastRowftC, ftC+ncol(x)), oC = c(lastRowftC, oC+ncol(x)), perCell = c(lastRowDist, rep(0,times=length(oC))), startCell = startCell - ncol(x), lonlat=lonlat)[-(1:ncol(r1))]) } else { chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) chunkDist[is.na(chunkDist)] <- Inf chunkDist <- pmin(chunkDist, .calcDist(x, chunkSize=chunkSize, ftC=ftC, oC=oC, perCell=0, startCell=startCell, lonlat=lonlat)) } } else { chunkDist <- rep(NA, tr$nrows[i] * ncol(out)) } lastRow <- chunk[(length(chunk)-ncol(x)+1):length(chunk)] lastRowDist <- chunkDist[(length(chunkDist)-ncol(x)+1):length(chunkDist)] lastRowftC <- which(!(lastRow %in% omit)) lastRowDist <- lastRowDist[lastRowftC] chunkDist[is.infinite(chunkDist)] <- NA out <- writeValues(out, chunkDist, tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) return(out) } } ) .calcDist <- function(x, chunkSize, ftC, oC, perCell=0, startCell=0, lonlat) { if (length(oC) > 0) { #adj <- adjacency(x, fromCells=ftC, toCells=ftC, directions=8) adj <- adjacent(x, ftC, directions=8, target=ftC, pairs=TRUE) startNode <- max(adj)+1 #extra node to serve as origin adjP <- rbind(adj, cbind(rep(startNode, times=length(oC)), oC)) distGraph <- igraph::graph.edgelist(adjP, directed=TRUE) if (length(perCell) == 1) { if (perCell == 0) { perCell <- rep(0, times=length(oC)) } } if (lonlat) { distance <- pointDistance(xyFromCell(x,adj[,1]+startCell), xyFromCell(x,adj[,2]+startCell), lonlat=TRUE) igraph::E(distGraph)$weight <- c(distance, perCell) } else { sameRow <- which(rowFromCell(x, adj[,1]) == rowFromCell(x, adj[,2])) sameCol <- which(colFromCell(x, adj[,1]) == colFromCell(x, adj[,2])) igraph::E(distGraph)$weight <- sqrt(xres(x)^2 + yres(x)^2) igraph::E(distGraph)$weight[sameRow] <- xres(x) igraph::E(distGraph)$weight[sameCol] <- yres(x) igraph::E(distGraph)$weight[(length(adj[,1])+1):(length(adj[,1])+length(oC))] <- perCell } shortestPaths <- igraph::shortest.paths(distGraph, startNode) shortestPaths <- shortestPaths[-(length(shortestPaths))] #chop startNode off if (length(shortestPaths) < chunkSize) { #add Inf values where shortest.paths() leaves off before completing all nodes shortestPaths <- c(shortestPaths, rep(Inf, times=chunkSize-length(shortestPaths))) } } else { shortestPaths <- rep(Inf, times=chunkSize) } return(shortestPaths) } raster/R/hdrIDRISI.R0000644000176200001440000000430614160021141013550 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrIDRISI <- function(x, old=FALSE) { hdrfile <- filename(x) hdrfile <- .setFileExtensionHeader(hdrfile, 'IDRISI') dtype <- .shortDataType(x@file@datanotation) dsize <- dataSize(x) if (dataType(x) == 'INT1U') { pixtype <- 'byte' } else if (dataType(x) == 'INT2S') { pixtype <- 'integer' } else { pixtype <- 'real' } if (couldBeLonLat(x)) { refsystem <- 'latlong' refunits <- 'degrees'; } else { refsystem <- 'plane'; refunits <- 'm'; } thefile <- file(hdrfile, "w") # open an txt file connectionis if (!old) cat('file format : IDRISI Raster A.1\n', file = thefile) cat('file title : ', names(x), "\n", sep='', file = thefile) cat('data type : ', pixtype, "\n", sep='', file = thefile) cat('file type : binary\n', sep='', file = thefile) cat('columns : ', ncol(x), "\n", sep='', file = thefile) cat('rows : ', nrow(x), "\n", sep='', file = thefile) cat('ref. system : ', refsystem, "\n", sep='', file = thefile) cat('ref. units : ', refunits, "\n", sep='', file = thefile) cat('unit dist. : 1.0000000', "\n", sep='', file = thefile) cat('min. X : ', as.character(xmin(x)), "\n", sep='', file = thefile) cat('max. X : ', as.character(xmax(x)), "\n", sep='', file = thefile) cat('min. Y : ', as.character(ymin(x)), "\n", sep='', file = thefile) cat('max. Y : ', as.character(ymax(x)), "\n", sep='', file = thefile) cat("pos'n error : unknown\n", file = thefile) cat('resolution : ', xres(x), "\n", sep='', file = thefile) cat('min. value : ', minValue(x), "\n", sep='', file = thefile) cat('max. value : ', maxValue(x), "\n", sep='', file = thefile) if (!old) cat('display min : ', minValue(x), "\n", sep='', file = thefile) if (!old) cat('display max : ', maxValue(x), "\n", sep='', file = thefile) cat('value units : unspecified\n', file = thefile) cat('value error : unknown\n', file = thefile) cat('flag value : ', .nodatavalue(x), "\n", sep='', file = thefile) cat("flag def'n : no data\n", file = thefile) cat('legend cats : 0\n', file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/subs.R0000644000176200001440000000750314160021141013045 0ustar liggesusers# Authors: Robert J. Hijmans # Date : February 2010 # Version 0.9 # Licence GPL v3 if (!isGeneric("subs")) { setGeneric("subs", function(x, y, ...) standardGeneric("subs")) } .localmerge <- function(x, y, subNA, byc=1) { if (byc==1) { nc <- NCOL(x) nr <- NROW(x) x <- cbind(1:length(x), as.vector(x)) if (! subNA ) { y <- merge(x, y, by.x=2, by.y=1) x[y[,2], 2] <- y[,3] x <- x[,2] if (nc > 1) { x <- matrix(as.vector(x), nrow=nr) } } else { x <- as.matrix(merge(x, y, by.x=2, by.y=1, all.x=TRUE)) x <- x[order(x[,2]), -c(1:2)] } if (nc > 1) { x <- matrix(as.vector(x), nrow = nr) } } else { x <- cbind(1:nrow(x), x) x <- as.matrix(merge(x, y, by.x=(1:byc)+1, by.y=1:byc, all.x=TRUE)) x <- x[, -(1:byc)] x <- x[order(x[,1]), -1] } return(x) } setMethod('subs', signature(x='Raster', y='data.frame'), function(x, y, by=1, which=2, subsWithNA=TRUE, filename='', ...) { if (!subsWithNA) { if (length(which) > 1) { stop('you cannot use subsWithNA=FALSE if length(which) > 1') } if (length(by) > 1) { stop('you cannot use subsWithNA=FALSE if length(by) > 1') } } stopifnot(length(by) == 1 | length(by) == nlayers(x)) if (is.character(by)) { by <- match(by, colnames(y)) if (any(is.na(by))) { stop("'by' is not a valid column name") } } if (is.character(which)) { which <- which(which == colnames(y))[1] if (is.na(which)) { stop("'which' is not valid column name") } } byc <- length(by) tt <- table(y[,by]) tt <- tt[ which(tt > 1) ] if (length(tt) > 0) { stop('duplicate "by" values not allowed') } out <- raster(x) nlx <- nlayers(x) cls <- sapply(y, class) hasfactor <- rep(FALSE, length(cls)-1) levs <- list() for (i in 2:length(cls)) { if (cls[i] == 'character') { suppressWarnings(tmp <- as.numeric(y[,i])) if (all(is.na(tmp) == is.na(y[,i]))) { y[,i] <- tmp cls[i] <- 'numeric' } else { y[,i] <- factor(y[,i]) cls[i] <- 'factor' } } if (cls[i] == 'factor') { uny <- unique(y[,i]) lv <- data.frame(ID=1:length(uny), uny) colnames(lv)[2] <- colnames(y)[i] levs[[i-1]] <- lv hasfactor[i-1] <- TRUE m <- match(y[,i], uny) y[,i] <- m #as.numeric(uny[m]) } } if (nlx == 1) { ln <- colnames(y)[which] if (length(which) > 1) { out <- brick(out, nl=length(which)) } } else { if (byc == 1) { out <- brick(out, nl=nlx * length(which)) ln <- rep(names(x), length(which)) if (length(which) > 1) { ln2 <- rep(colnames(y)[which], each=nlx) ln <- paste(ln, paste('_', ln2, sep=''), sep='') } } else { if (length(which) > 1) { out <- brick(out, nl=length(which)) } ln <- colnames(y)[which] } } names(out) <- ln y <- y[ , c(by, which)] filename <- trim(filename) if (canProcessInMemory(x, 3)) { if (any(hasfactor)) { out@data@isfactor <- hasfactor out@data@attributes <- levs } v <- .localmerge( getValues(x), y, subsWithNA, byc ) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } tr <- blockSize(out) pb <- pbCreate(tr$n, label='subs', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) out <- writeValues(out, .localmerge(v, y, subsWithNA, byc), tr$row[i]) pbStep(pb) } pbClose(pb) if (any(hasfactor)) { out@data@isfactor <- TRUE out@data@attributes <- levs } out <- writeStop(out) return(out) } } ) raster/R/as.spatial.R0000644000176200001440000000463214160021141014130 0ustar liggesusers setAs("data.frame", "SpatialPolygons", function(from) { v <- colnames(from)[5] if (v == "x") { obs <- unique(from$object) sp <- list() for (i in 1:length(obs)) { s <- from[from$object==obs[i], ] p <- unique(s$part) pp <- list() for (j in 1:length(p)) { ss <- s[s$part==p[j], ] pol <- sp::Polygon( as.matrix(ss[,c('x', 'y')] )) if (ss$hole[1]) { pol@hole <- TRUE } pp[[j]] <- pol } sp[[i]] <- sp::Polygons(pp, as.character(i)) } } else if (v == "hole") { colnames(from)[1] <- "id" obs <- unique(from$id) sp <- list() for (i in 1:length(obs)) { s <- from[from$id==obs[i], ] p <- unique(s$part) pp <- list() jj <- 1 for (j in 1:length(p)) { ss <- s[s$part==p[j], ] hi <- ss$hole > 0 holes <- ss[hi, ] ss <- ss[!hi,] pol <- sp::Polygon( as.matrix(ss[,c("x", "y")] )) pp[[jj]] <- pol jj <- jj + 1 if (nrow(holes) > 0) { uh <- unique(holes$hole) for (k in uh) { pol <- sp::Polygon( as.matrix(holes[holes$hole==k, c("x", "y")] )) pol@hole <- TRUE pp[[jj]] <- pol jj <- jj + 1 } } sp[[i]] <- sp::Polygons(pp, as.character(i)) } } } else { stop("cannot process this data.frame") } sp::SpatialPolygons(sp) } ) setAs("data.frame", "SpatialPolygonsDataFrame", function(from) { x <- as(from, "SpatialPolygons") if (ncol(from) > 6) { d <- unique(from[, -c(2:6), drop=FALSE]) rownames(d) <- d$object d <- d[, -1, drop=FALSE] sp::SpatialPolygonsDataFrame(x, d) } else { x } } ) setAs("data.frame", "SpatialLines", function(from) { colnames(from)[1] <- "object" obs <- unique(from$object) sp <- list() for (i in 1:length(obs)) { s <- from[from$object==obs[i], ] p <- unique(s$part) pp <- list() for (j in 1:length(p)) { ss <- s[s$part==p[j], ] ln <- sp::Line(as.matrix(ss[,c("x", "y")])) pp[[j]] <- ln } sp[[i]] <- sp::Lines(pp, as.character(i)) } sp::SpatialLines(sp) } ) setAs("data.frame", "SpatialLinesDataFrame", function(from) { x <- as(from, "SpatialLines") if (ncol(from) > 5) { d <- unique(from[, -c(2:5), drop=FALSE]) rownames(d) <- d$object d <- d[, -1, drop=FALSE] sp::SpatialLinesDataFrame(x, d) } else { x } } ) raster/R/tmpFile.R0000644000176200001440000000654414160021141013475 0ustar liggesusers# Author: Robert J. Hijmans # Date : May 2009 # Version 0.9 # Licence GPL v3 .fileSaveDialog <- function(filetypes="") { if (! requireNamespace("tcltk") ) { stop('you need to install the tcltk library') } if (filetypes == "") { filetypes="{{GeoTIFF} {.tif} } {{grid files} {.grd}}" } tcltk::tclvalue(tcltk::tkgetSaveFile(filetypes=filetypes)) } .fileOpenDialog <- function(filetypes="") { if (! requireNamespace("tcltk") ) { stop('you need to install the tcltk library') } if (filetypes == "") { filetypes="{{All Files} *} {{GeoTIFF} {.tif} } {{grid files} {.grd}}" } tcltk::tclvalue(tcltk::tkgetOpenFile(filetypes=filetypes)) } .old_rasterTmpFile <- function(prefix='raster_tmp_') { f <- getOption('rasterTmpFile') if (!is.null(f)) { f <- trim(f) if (! f == '' ) { options('rasterTmpFile' = NULL) return(f) } } extension <- .defaultExtension(.filetype()) d <- tmpDir(create=TRUE) # dir.create(d, showWarnings = FALSE) f <- paste(round(stats::runif(10)*10), collapse="") d <- paste(d, prefix, f, extension, sep="") if (file.exists(d)) { d <- rasterTmpFile(prefix=prefix) } if (getOption('verbose')) { cat('writing raster to:', d) } return(d) } rasterTmpFile <- function(prefix='r_tmp_') { f <- getOption('rasterTmpFile') if (!is.null(f)) { f <- trim(f) if (! f == '' ) { options('rasterTmpFile' = NULL) return(f) } } extension <- .defaultExtension(.filetype()) d <- tmpDir() while(TRUE) { # added pid as suggested by Daniel Schlaepfer to avoid overlapping file names when running parallel processes and using set.seed() in each node f <- paste(prefix, gsub(" ", "_", gsub(":", "", as.character(Sys.time()))), "_", Sys.getpid(), "_", paste(sample(0:9,5,replace=TRUE),collapse=''), extension, sep = "") tmpf <- normalizePath(file.path(d, f), winslash = "/", mustWork=FALSE) if (! file.exists(tmpf)) { break } } if (getOption('verbose')) { cat('writing raster to:', tmpf) } return(tmpf) } .removeTrailingSlash <- function(d) { if (substr(d, nchar(d), nchar(d)) == '/') { d <- substr(d, 1, nchar(d)-1) } if (substr(d, nchar(d), nchar(d)) == '\\') { d <- substr(d, 1, nchar(d)-1) } return(d) } removeTmpFiles <- function(h=24) { # remove files in the temp folder that are > h hours old warnopt <- getOption('warn') on.exit(options('warn'= warnopt)) tmpdir <- tmpDir(create=FALSE) if (!is.na(tmpdir)) { d <- .removeTrailingSlash(tmpdir) f <- list.files(path=d, pattern='r_tmp*', full.names=TRUE, include.dirs=TRUE) # f <- list.files(path=d, pattern='[.]gr[di]', full.names=TRUE, include.dirs=TRUE) fin <- file.info(f) dif <- Sys.time() - fin$mtime dif <- as.numeric(dif, units="hours") f <- f[which(dif > h)] unlink(f, recursive=TRUE) } options('warn'=warnopt) } showTmpFiles <- function() { f <- NULL tmpdir <- tmpDir(create=FALSE) if (!is.na(tmpdir)) { d <- .removeTrailingSlash(tmpdir) if (file.exists(d)) { f <- list.files(d, pattern='r_tmp_') #f <- list.files(d, pattern='\\.gri$') if (length(f) == 0) { cat('--- none ---\n') } else { ff <- f extension(ff) <- '' ff <- paste(unique(ff), '\n', sep='') cat(ff) } } else { cat('--- none ---\n') } } else { cat('--- none ---\n') } invisible(f) } raster/R/indexReplace.R0000644000176200001440000001123414160021141014470 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setReplaceMethod("[", c("RasterLayer", "RasterLayer", "missing"), function(x, i, j, value) { i <- crop(i, x) if (inherits(value, 'RasterLayer')) { value <- getValues(value) } if (! hasValues(i) ) { i <- cellsFromExtent(x, i) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { i <- as.logical( getValues(i) ) } else { j <- as.logical( getValues(i) ) i <- cellsFromExtent(x, i)[j] x[i] <- value return(x) } .replace(x, i, value=value, recycle=1) } ) setReplaceMethod("[", c("RasterLayer","missing","missing"), function(x, i, j, value) { if (length(value) == ncell(x)) { x <- try( setValues(x, value)) } else if (length(value) == 1) { x <- try( setValues(x, rep(value, times=ncell(x))) ) } else { v <- try( vector(length=ncell(x)) ) if (! inherits(x, "try-error")) { v[] <- value x <- try( setValues(x, v) ) } } if (inherits(x, "try-error")) { stop('cannot replace values on this raster (it is too large') } return(x) } ) .replace <- function(x, i, value, recycle=1) { if ( is.logical(i) ) { i <- which(i) } else { i <- stats::na.omit(i) } if (any(i < 1)) { if (!all(i < 1)) {stop("you cannot mix negative and positive subscript")} j <- i i <- 1:ncell(x) i <- i[j] } nl <- nlayers(x) # recycling if (nl > 1 & recycle > 0) { rec2 <- ceiling(nl / recycle) if (rec2 > 1) { add <- ncell(x)*recycle * (0:(rec2-1)) i <- as.vector(t((matrix(rep(i, rec2), nrow=rec2, byrow=TRUE)) + add)) } } j <- i > 0 & i <= (ncell(x)*nl) if (!all(j)) { i <- i[j] if (length(value) > 1) { value <- value[j] } } if ( inMemory(x) ) { if (inherits(x, 'RasterStack')) { x <- brick( x, values=TRUE ) # this may go to disk, hence we check again below } } if ( inMemory(x) & hasValues(x) ) { x@data@values[i] <- value x <- setMinMax(x) x <- .clearFile(x) return(x) } else if (canProcessInMemory(x)) { if (inherits(x, 'RasterStack')) { x <- brick( x, values=TRUE ) if (!inMemory(x)) { x <- readAll(x) } x <- .clearFile(x) x@data@values[i] <- value x <- setMinMax(x) } else if ( fromDisk(x) ) { x <- readAll(x) x <- .clearFile(x) x@data@values[i] <- value x <- setMinMax(x) } else { vals <- rep(NA, times=ncell(x)*nl) vals[i] <- value x <- setValues(x, vals) } return(x) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='replace') hv <- hasValues(x) if (nl==1) { if (! length(value) %in% c(1, length(i))) { stop('cannot replace values in large Raster objects if their length is not 1 or the number of cells to be replaced') } r <- raster(x) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) for (k in 1:tr$n) { # cells <- cellFromRowCol(x, tr$row[k], 1):cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x)) cell1 <- cellFromRowCol(x, tr$row[k], 1) cell2 <- cell1 + tr$nrows[k] * ncol(x) - 1 if (hv) { v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k]) } else { v <- rep(NA, 1+cell2-cell1) } j <- which(i >= cell1 & i <= cell2) if (length(j) > 0) { localcells <- i[j] - (cell1-1) if (length(value) == length(i)) { v[localcells] <- value[j] } else { v[localcells] <- value } } r <- writeValues(r, v, tr$row[k]) pbStep(pb, k) } r <- writeStop(r) pbClose(pb) return(r) } else { if (! length(value) %in% c(1, length(i))) { stop('length of replacement values does not match the length of the index') } r <- brick(x, values=FALSE) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) # add <- (0:(nl-1)) * ncell(x) # remove the added cells again.... nc <- ncol(x) ii <- (i-1) %% ncell(x) + 1 for (k in 1:tr$n) { startcell <- cellFromRowCol(x, tr$row[k], 1) endcell <- cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x)) if (hv) { v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k]) } else { v <- matrix(NA, nrow=tr$nrows[k] * nc, ncol=nl) } j <- i[ii >= startcell & ii <= endcell] - startcell + 1 if (length(j) > 0) { jj <- (j %/% ncell(x)) * tr$nrow[k] * ncol(x) + (j %% ncell(x)) if (length(value) == length(i)) { v[jj] <- value[jj] } else { v[jj] <- value } } r <- writeValues(r, v, tr$row[k]) pbStep(pb, k) } r <- writeStop(r) pbClose(pb) return(r) } } } raster/R/hdrErdasRaw.R0000644000176200001440000000356014160235752014315 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .writeHdrErdasRaw <- function(raster) { hdrfile <- filename(raster) extension(hdrfile) <- ".raw" thefile <- file(hdrfile, "w") # open an txt file connectionis cat("IMAGINE_RAW_FILE\n", file = thefile) cat("PIXEL_FILES ", .setFileExtensionValues(raster@file@name), "\n", file = thefile) # this may not work. Some implementations may ignore this keyword and expect the pixelfile to have the same file name, no extension. cat("HEIGHT ", nrow(raster), "\n", file = thefile) cat("WIDTH ", ncol(raster), "\n", file = thefile) cat("NUM_LAYERS ", nbands(raster), "\n", file = thefile) if (.shortDataType(raster@file@datanotation) == 'INT') { dd <- "S" } else { dd <- "F" } nbits <- dataSize(raster@file@datanotation) * 8 dtype <- paste(dd, nbits, sep="") cat("DATA_TYPE ", dtype, "\n", file = thefile) #U1, U2, U4, U8, U16, U32 #S16, S32 #F32, and F64. if (.Platform$endian == "little") { btorder <- "LSB" } else { btorder <- "MSB" } cat("BYTE_ORDER ", btorder, "\n", file = thefile) #Required for DATA_TYPE values of U16, S16, U32, S32 cat("FORMAT ", "BIL", "\n", file = thefile) cat("DATA_OFFSET 0\n", file = thefile) cat("END_RAW_FILE\n", file = thefile) cat("\n\n", file = thefile) cat("The below is additional metadata, not part of the ERDAS raw format\n", file = thefile) cat("----------------------------------------------------------------\n", file = thefile) cat("CREATOR=R package:raster\n", file = thefile) cat("CREATED=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n", file = thefile) cat("Projection=", proj4string(raster), "\n", file = thefile) cat("MinValue=", minValue(raster), "\n", file = thefile) cat("MaxValue=", maxValue(raster), "\n", file = thefile) close(thefile) .worldFile(raster, ".rww") } raster/R/readAscii.R0000644000176200001440000000366514160021141013762 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .readAllAscii <- function(x) { filename <- trim(filename(x)) if (!file.exists(filename)) { stop(paste(filename, " does not exist")) } v <- as.numeric( scan(filename, skip=x@offset, what='character', quiet=TRUE) ) # if (x@file@nodatavalue < -10000) { # v[v <= x@file@nodatavalue ] <- NA # } else { v[v == x@file@nodatavalue ] <- NA # } return ( v ) } .readRowsAscii <- function(x, startrow, nrows, startcol=1, ncols=x@ncols) { if (startcol > 1 | ncols < x@ncols) { v <- matrix(nrow=ncols, ncol=nrows) endcol <- startcol+ncols-1 skiprows <- x@file@offset + startrow - 2 cols <- endcol-startcol+1 r <- raster(x) nrow(r) <- nrows tr <- blockSize(r, minblocks=1) for (i in 1:tr$n) { start <- skiprows + tr$row[i] d <- matrix( scan(filename(x), skip=start, nlines=tr$nrows[i], what='character', quiet=TRUE), ncol=tr$nrows[i]) v[,tr$row[i]:(tr$row[i]+tr$nrows[i]-1)] <- as.numeric(d[startcol:endcol, ]) } v <- as.vector(v) } else { skiprows <- x@file@offset + startrow - 1 v <- as.numeric ( scan(filename(x), skip=skiprows, nlines=nrows, what='character', quiet=TRUE) ) } # if (x@file@nodatavalue < 0) { # v[v <= x@file@nodatavalue ] <- NA # } else { v[v == x@file@nodatavalue ] <- NA # } return ( v ) } .readCellsAscii <- function(raster, cells) { colrow <- matrix(ncol=5, nrow=length(cells)) colrow <- matrix(ncol=5, nrow=length(cells)) colrow[,1] <- colFromCell(raster, cells) colrow[,2] <- rowFromCell(raster, cells) colrow[,3] <- cells colrow[,4] <- NA rows <- stats::na.omit(unique(colrow[order(colrow[,2]), 2])) for (i in 1:length(rows)) { v <- .readRowsAscii(raster, rows[i], 1, 1, raster@ncols) thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] colrow[colrow[,2] == rows[i],4] <- v[thisrow[,1]] } return(colrow[,4]) } raster/R/erase.R0000644000176200001440000000760714160021141013175 0ustar liggesusers .gDif <- function(x, y, type='polygons') { xln <- length(x) yln <- length(y) if (xln==0 | yln==0) { return(x) } rn <- row.names(x) for (i in xln:1) { z <- x[i,] for (j in 1:yln) { z <- rgeos::gDifference(z, y[j,], drop_lower_td=TRUE) if (is.null(z)) { break } } if (is.null(z)) { x <- x[-i,] rn <- rn[-i] } else { if (type=='polygons') { x@polygons[i] <- z@polygons } else { x@lines[i] <- z@lines } } if (length(rn) > 0) { row.names(x) <- rn } } if ((type=='polygons') & (length(x) > 0)) { w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) j <- rgeos::gIsValid(x, byid=TRUE, reason=FALSE) #j <- which(gArea(x, byid=TRUE) > 0) if (!all(j)) { bad <- which(!j) for (i in bad) { # it could be that a part of a polygon is a sliver, but that other parts are OK a <- sp::disaggregate(x[i, ]) if (length(a) > 1) { jj <- which(rgeos::gIsValid(a, byid=TRUE, reason=FALSE)) a <- a[jj, ] if (length(a) > 0) { x@polygons[i] <- aggregate(a)@polygons j[i] <- TRUE } } } x <- x[j,] rn <- rn[j] } if (length(rn) > 0) { row.names(x) <- rn } } x } setMethod(erase, signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ...){ valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) if (!.hasSlot(x, "data")) { d <- data.frame(erase_dissolve_ID=1:length(x)) rownames(d) <- row.names(x) x <- sp::SpatialPolygonsDataFrame(x, data=d) dropframe <- TRUE } else { dropframe <- FALSE x$erase_dissolve_ID <- 1:nrow(x) } y <- aggregate(y) int <- rgeos::gIntersects(x, y, byid=TRUE) int1 <- apply(int, 2, any) int2 <- apply(int, 1, any) if (sum(int1) == 0) { # no intersections return(x) } if (all(int1)) { part1 <- NULL } else { part1 <- x[!int1,] } part2 <- .gDif(x[int1,], y[int2,]) part2 <- sp::SpatialPolygonsDataFrame(part2, x@data[match(row.names(part2), rownames(x@data)), ,drop=FALSE]) if (!is.null(part1)) { part2 <- rbind(part1, part2) } if (length(part2@polygons) > 1) { part2 <- aggregate(part2, colnames(part2@data)) } part2@proj4string <- prj if (dropframe) { return( as(part2, 'SpatialPolygons') ) } else { part2@data$erase_dissolve_ID <- NULL return( part2 ) } } ) setMethod(erase, signature(x='SpatialLines', y='SpatialPolygons'), function(x, y, ...){ valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x@proj4string <- sp::CRS(as.character(NA)) y@proj4string <- sp::CRS(as.character(NA)) if (!.hasSlot(x, 'data')) { d <- data.frame(ID=1:length(x)) rownames(d) <- row.names(x) x <- sp::SpatialLinesDataFrame(x, data=d) dropframe <- TRUE } else { dropframe <- FALSE } y <- aggregate(y) int <- rgeos::gIntersects(x, y, byid=TRUE) int1 <- apply(int, 2, any) int2 <- apply(int, 1, any) if (sum(int1) == 0) { # no intersections return(x) } if (all(int1)) { part1 <- NULL } else { part1 <- x[!int1,] } part2 <- .gDif(x[int1,], y[int2,], 'lines') part2 <- sp::SpatialLinesDataFrame(part2, x@data[match(row.names(part2), rownames(x@data)), ,drop=FALSE], match.ID = FALSE) if (!is.null(part1)) { part2 <- rbind(part1, part2) } if (length(part2@lines) > 1) { part2 <- aggregate(part2, colnames(part2@data)) } part2@proj4string <- prj if (dropframe) { return( as(part2, 'SpatialLines') ) } else { return( part2 ) } } ) raster/R/animate.R0000644000176200001440000000125714160021141013507 0ustar liggesusers setMethod('animate', signature(x='RasterStackBrick'), function(x, pause=0.25, main, zlim, maxpixels=50000, n=10, ...) { nl <- nlayers(x) if (missing(main)) { main <- getZ(x) if (is.null(main)) { main <- names(x) } } x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE) if (missing(zlim)) { zlim <- c(min(minValue(x)), max(maxValue(x))) } i <- 1 reps <- 0 while (reps < n) { plot(x[[i]], main = main[i], zlim=zlim, maxpixels=Inf, ...) grDevices::dev.flush() Sys.sleep(pause) i <- i + 1 if (i > nl) { i <- 1 reps <- reps+1 } } } ) #anim(st, tvals) raster/R/writeAllGDAL.R0000644000176200001440000000143114160021141014276 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .writeGDALall <- function(x, filename, options=NULL, setStatistics=TRUE, ...) { stat <- cbind(NA, NA) if (nlayers(x) > 1) { y <- brick(x, values=FALSE) levels(y) <- levels(x) x <- getValues(x) if (setStatistics) { stat <- t(apply(x, 2, function(z, ...) cbind(mean(z, na.rm=TRUE), stats::sd(z, na.rm=TRUE)))) } } else { y <- raster(x) levels(y) <- levels(x) y@legend@colortable <- colortable(x) x <- getValues(x) if (setStatistics) { stat <- cbind(mean(x, na.rm=TRUE), stats::sd(x, na.rm=TRUE)) } } y <- .startGDALwriting(y, filename, options, setStatistics=setStatistics, ...) x <- writeValues(y, x, start=1) .stopGDALwriting(x, stat) } raster/R/hdrRaster.R0000644000176200001440000000775614160235760014057 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .writeHdrRaster <- function(x, type='raster') { rastergrd <- .setFileExtensionHeader(filename(x), type) thefile <- file(rastergrd, "w") # open an txt file connection cat("[general]", "\n", file = thefile, sep='') cat("creator=R package 'raster'", "\n", file = thefile, sep='') cat("created=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n", file = thefile, sep='') cat("[georeference]", "\n", file = thefile, sep='') cat("nrows=", nrow(x), "\n", file = thefile, sep='') cat("ncols=", ncol(x), "\n", file = thefile, sep='') cat("xmin=", as.character(xmin(x)), "\n", file = thefile, sep='') cat("ymin=", as.character(ymin(x)), "\n", file = thefile, sep='') cat("xmax=", as.character(xmax(x)), "\n", file = thefile, sep='') cat("ymax=", as.character(ymax(x)), "\n", file = thefile, sep='') cat("projection=", proj4string(x), "\n", file = thefile, sep='') cat("[data]", "\n", file = thefile, sep='') cat("datatype=", x@file@datanotation, "\n", file = thefile, sep='') cat("byteorder=", x@file@byteorder, "\n", file = thefile, sep='') nl <- nlayers(x) cat("nbands=", nl, "\n", file = thefile, sep='') cat("bandorder=", x@file@bandorder, "\n", file = thefile, sep='') # currently only for single layer files! if (nl == 1) { fact <- is.factor(x)[1] cat("categorical=", paste(fact, collapse=':'), "\n", file = thefile, sep='') if (any(fact)) { r <- x@data@attributes[[1]] cat("ratnames=", paste(colnames(r), collapse=':'), "\n", file = thefile, sep='') cat("rattypes=", paste(sapply(r, class), collapse=':'), "\n", file = thefile, sep='') v <- trim(as.character(as.matrix(r))) v <- gsub(":", "~^colon^~", v) cat("ratvalues=", paste(v, collapse=':'), "\n", file = thefile, sep='') } if (length(x@legend@colortable) > 1) { cat("colortable=", paste(x@legend@colortable, collapse=':'), "\n", file = thefile, sep='') } } # cat("levels=", x@data@levels, "\n", file = thefile, sep='') cat("minvalue=", paste(minValue(x, -1, warn=FALSE), collapse=':'), "\n", file = thefile, sep='') cat("maxvalue=", paste(maxValue(x, -1, warn=FALSE), collapse=':'), "\n", file = thefile, sep='') cat("nodatavalue=", .nodatavalue(x), "\n", file = thefile, sep='') # cat("Sparse=", x@sparse, "\n", file = thefile, sep='') # cat("nCellvals=", x@data@ncellvals, "\n", file = thefile, sep='') cat("[legend]", "\n", file = thefile, sep='') cat("legendtype=", x@legend@type, "\n", file = thefile, sep='') cat("values=", paste(x@legend@values, collapse=':'), "\n", file = thefile, sep='') cat("color=", paste(x@legend@color, collapse=':'), "\n", file = thefile, sep='') cat("[description]", "\n", file = thefile, sep='') ln <- gsub(":", ".", names(x)) cat("layername=", paste(ln, collapse=':'), "\n", file = thefile, sep='') z <- getZ(x) if (! is.null(z)) { zname <- names(x@z)[1] if (is.null(zname)) { zname <- 'z-value' } zclass <- class(z) # suggested by Michael Sumner if (inherits(z, "POSIXct")) { z <- format(z, "%Y-%m-%d %H:%M:%S", tz="UTC") } else { z <- as.character(z) } cat("zvalues=", paste(c(zname, z), collapse=':'), "\n", file = thefile, sep='') cat("zclass=", zclass, "\n", file = thefile, sep='') } a <- NULL try( a <- unlist(x@history), silent=TRUE ) if (!is.null(a)) { cat("history=", a, "\n", file = thefile, sep='') } a <- NULL try( a <- rapply(x@history, function(x) paste(as.character(x), collapse='#,#')), silent=TRUE ) if (!is.null(a)) { a <- gsub('\n', '#NL#', a) type <- rapply(x@history, class) type_value <- apply(cbind(type, a), 1, function(x) paste(x, collapse=':')) name_type_value <- apply(cbind(names(a), type_value), 1, function(x) paste(x, collapse='=')) name_type_value <- paste(name_type_value, '\n', sep='') cat("[metadata]", "\n", file = thefile, sep='') cat(name_type_value, file = thefile, sep='') } close(thefile) return(TRUE) } raster/R/area.R0000644000176200001440000001354514160021141013004 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .cellArea <- function(x, r=6378137) { # currently not used dlonR2 <- xres(x) * (pi / 180) * r^2 lat <- yFromRow(x, 1:nrow(x)) lat <- cbind(lat, lat) dlat <- yres(x) lat[,1] <- lat[,1] + 0.5 * dlat lat[,2] <- lat[,2] - 0.5 * dlat lat <- sin(lat * (pi / 180) ) # for one column: abs(lat[,2] - lat[,1]) * dlonR2 } setMethod('area', signature(x='SpatialPolygons'), function(x, ...) { if (couldBeLonLat(x)) { if (!isLonLat(x)) { warning('assuming that the crs is longitude/latitude!') } lonlat = TRUE } else { lonlat = FALSE } g <- geom(x) .Call('_raster_get_area_polygon', PACKAGE = 'raster', g, lonlat) } ) setMethod('area', signature(x='RasterLayer'), function(x, filename='', na.rm=FALSE, weights=FALSE, ...) { out <- raster(x) if (na.rm) { if (! hasValues(x) ) { na.rm <- FALSE warning("'x' has no values, ignoring 'na.rm=TRUE'") rm(x) } } else { rm(x) } if (! couldBeLonLat(out)) { warning('This function is only useful for Raster* objects with a longitude/latitude coordinates') ar <- prod(res(out)) return( init(out, function(x) ar, filename=filename, ...) ) } filename <- trim(filename) if (!canProcessInMemory(out, 3) & filename == '') { filename <- rasterTmpFile() } if (filename == '') { v <- matrix(NA, ncol=nrow(out), nrow=ncol(out)) } else { if (weights) { outfname = filename filename = rasterTmpFile() } out <- writeStart(out, filename=filename, ...) } dy <- .geodist(0, 0, 0, yres(out)) y <- yFromRow(out, 1:nrow(out)) dx <- .geodist(0, y, xres(out), y) tr <- blockSize(out) pb <- pbCreate(tr$n, label='area', ...) for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) if (na.rm) { a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA } if (filename == "") { v[,r] <- vv } else { out <- writeValues(out, vv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (filename == "") { v <- as.vector(v) if (weights) { v <- v / sum(v, na.rm=TRUE) } values(out) <- v } else { out <- writeStop(out) if (weights) { total <- cellStats(out, 'sum') out <- calc(out, fun=function(x){x/total}, filename=outfname, ...) } } return(out) } ) setMethod('area', signature(x='RasterStackBrick'), function(x, filename='', na.rm=FALSE, weights=FALSE, ...) { if (! na.rm) { return( area(raster(x), filename=filename, na.rm=FALSE, weights=weights, ...) ) } out <- brick(x, values=FALSE) if (! couldBeLonLat(out)) { stop('This function is only useful for Raster* objects with a longitude/latitude coordinates') } filename <- trim(filename) if (!canProcessInMemory(out) & filename == '') { filename <- rasterTmpFile() } nl <- nlayers(out) if (filename == '') { v <- matrix(NA, ncol=nl, nrow=ncell(out)) } else { if (weights) { outfname = filename filename = rasterTmpFile() } out <- writeStart(out, filename=filename, ...) } dy <- pointDistance(c(0,0),c(0, yres(out) ), lonlat=TRUE) y <- yFromRow(out, 1:nrow(out)) dx <- pointDistance(cbind(0, y), cbind(xres(out), y), lonlat=TRUE) if (.doCluster() ) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nrow(out), length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() tr <- blockSize(out, minblocks=nodes) pb <- pbCreate(tr$n, label='area', ...) # clFun <- function(i, tr, dx, dy, out, nl) { clFun <- function(i) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) vv <- matrix(rep(vv, times=nl), ncol=nl) a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA return(vv) } .sendCall <- eval( parse( text="parallel:::sendCall") ) parallel::clusterExport(cl, c('tr', 'dx', 'dy', 'out', 'nl'), envir=environment()) for (i in 1:nodes) { .sendCall(cl[[i]], clFun, list(i), tag=i) } for (i in 1:tr$n) { d <- .recvOneData(cl) if (! d$value$success ) { print(d) stop('cluster error') } if (filename == "") { r <- tr$row[d$value$tag]:(tr$row[d$value$tag]+tr$nrows[d$value$tag]-1) start <- (r[1]-1) * ncol(out) + 1 end <- r[length(r)] * ncol(out) v[start:end, ] <- d$value$value } else { out <- writeValues(out, d$value$value, tr$row[d$value$tag]) } if ((nodes + i) <= tr$n) { # .sendCall(cl[[d$node]], clFun, list(nodes+i, tr, dx, dy, out, nl), tag=nodes+i) .sendCall(cl[[d$node]], clFun, list(nodes+i), tag=nodes+i) } pbStep(pb, i) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='area', ...) #rows <- 1 for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) vv <- matrix(rep(vv, times=nl), ncol=nl) a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA if (filename == "") { start <- (r[1]-1) * ncol(out) + 1 end <- r[length(r)] * ncol(out) v[start:end, ] <- vv } else { out <- writeValues(out, vv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) } if (filename == "") { if (weights) { total <- colSums(v, na.rm=TRUE) v <- t( t(v) / total ) } values(out) <- v } else { out <- writeStop(out) if (weights) { total <- cellStats(out, 'sum') out <- calc(out, fun=function(x){x / total}, filename=outfname, ...) } } return(out) } ) raster/R/cellRowCol.R0000644000176200001440000000673514160021141014144 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod(rowFromCell, signature(object="BasicRaster", cell="numeric"), function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA trunc((cell-1)/ncol(object)) + 1 } ) #rowFromCell <- function(object, cell) { # object <- raster(object) # cell <- round(cell) # cell[cell < 1 | cell > ncell(object)] <- NA # trunc((cell-1)/ncol(object)) + 1 #} .rowFromCell <- function(object, cell) { trunc((cell-1)/ncol(object)) + 1 } cellFromRow <- function(object, rownr) { object <- raster(object) rownr <- round(rownr) #if (length(rownr)==1) { # return(cellFromRowCol(object, rownr, 1):cellFromRowCol(object, rownr, object@ncols)) #} cols <- rep(1:ncol(object), times=length(rownr)) rows <- rep(rownr, each=ncol(object)) cellFromRowCol(object, rows, cols) } cellFromCol <- function(object, colnr) { object <- raster(object) colnr <- round(colnr) rows <- rep(1:nrow(object), times=length(colnr)) cols <- rep(colnr, each=nrow(object)) return(cellFromRowCol(object, rows, cols)) } .OLD_cellFromRowColCombine <- function(object, rownr, colnr) { object <- raster(object) rc <- expand.grid(rownr, colnr) return( cellFromRowCol(object, rc[,1], rc[,2])) } setMethod(cellFromRowColCombine, signature(object="BasicRaster", row="numeric", col="numeric"), function(object, row, col) { # faster without this according to PR #131 # object <- raster(object) row[row < 1 | row > object@nrows] <- NA col[col < 1 | col > object@ncols] <- NA cols <- rep(col, times=length(row)) dim(cols) <- c(length(col), length(row)) cols <- t(cols) row <- (row-1) * object@ncols cols <- cols + row as.vector(t(cols)) } ) setMethod(colFromCell, signature(object="BasicRaster", cell="numeric"), function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA rownr <- trunc((cell-1)/object@ncols) + 1 as.integer(cell - ((rownr-1) * object@ncols)) } ) #colFromCell <- function(object, cell) { # object <- raster(object) # cell <- round(cell) # cell[cell < 1 | cell > ncell(object)] <- NA # rownr <- trunc((cell-1)/object@ncols) + 1 # as.integer(cell - ((rownr-1) * object@ncols)) #} .colFromCell <- function(object, cell) { nc <- object@ncols rownr <- trunc((cell-1)/nc) + 1 cell - ((rownr-1) * nc) } setMethod(rowColFromCell, signature(object="BasicRaster", cell="numeric"), function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA row <- as.integer(trunc((cell-1)/object@ncols) + 1) col <- as.integer(cell - ((row-1) * object@ncols)) return(cbind(row, col)) } ) #rowColFromCell <- function(object, cell) { # object <- raster(object) # cell <- round(cell) # cell[cell < 1 | cell > ncell(object)] <- NA # row <- as.integer(trunc((cell-1)/object@ncols) + 1) # col <- as.integer(cell - ((row-1) * object@ncols)) # return(cbind(row, col)) #} setMethod(cellFromRowCol, signature(object="BasicRaster", row="numeric", col="numeric"), function(object, row, col, ...) { rows <- object@nrows cols <- object@ncols .doCellFromRowCol(rows, cols, row, col) } ) #cellFromRowCol <- function(object, rownr, colnr) { # rows <- object@nrows # cols <- object@ncols # .doCellFromRowCol(rows, cols, rownr, colnr) #} raster/R/cut.R0000644000176200001440000000445414160021141012666 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('cut', signature(x='Raster'), function(x, breaks, ..., filename='', format, datatype='INT2S', overwrite, progress) { if (! hasValues(x) ) { warning('x has no values, nothing to do') return(x) } filename <- trim(filename) if (missing(format)) { format <- .filetype(format=format, filename=filename) } if (missing(overwrite)) { overwrite <- .overwrite() } if (missing(progress)) { progress <- .progress() } nl <- nlayers(x) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) } if (canProcessInMemory(out, n=nl*2 + 2)) { if (nl > 1) { values(out) <- apply(getValues(x), 2, function(x) as.numeric(cut(x, breaks=breaks, labels=FALSE, ...))) } else { values(out) <- as.numeric(cut(getValues(x), breaks=breaks, labels=FALSE, ...)) } if ( filename != "" ) { out <- writeRaster(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (length(breaks) == 1) { breaks <- round(breaks) stopifnot(breaks > 1) probs <- c(0, 1:breaks * 1/breaks) breaks <- stats::na.omit(sampleRegular(x, 10000, useGDAL=TRUE)) warning('breaks are approximate, based on a sample of ', length(breaks), ' cells that are not NA') breaks <- stats::quantile(breaks, probs, names=FALSE) breaks[1] <- -Inf breaks[length(breaks)] <- Inf } out <- writeStart(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) tr <- blockSize(out) pb <- pbCreate(tr$n, progress=progress, label='cut') if (nl > 1) { for (i in 1:tr$n) { res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) res <- apply(res, 2, function(x) as.numeric(cut(x, breaks=breaks, labels=FALSE, ...))) out <- writeValues(out, res, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) res <- as.numeric(cut(res, breaks=breaks, labels=FALSE, ...)) out <- writeValues(out, res, tr$row[i]) pbStep(pb, i) } } out <- writeStop(out) pbClose(pb) return(out) } } ) raster/R/rasterToPolygons.R0000644000176200001440000000604714160021141015431 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 rasterToPolygons <- function(x, fun=NULL, n=4, na.rm=TRUE, digits=12, dissolve=FALSE) { stopifnot(n %in% c(4,8,16)) if (nlayers(x) > 1) { if (!is.null(fun)) { stop('you cannot supply a "fun" argument when "x" has multiple layers') } } if (! fromDisk(x) & ! inMemory(x)) { xyv <- xyFromCell(x, 1:ncell(x)) xyv <- cbind(xyv, NA) } else if ( !(na.rm) | inMemory(x) | canProcessInMemory(x) ) { xyv <- cbind(xyFromCell(x, 1:ncell(x)), getValues(x)) x <- clearValues(x) if (na.rm) { nas <- apply(xyv[,3:ncol(xyv), drop=FALSE], 1, function(x) all(is.na(x))) xyv <- xyv[!nas, ,drop=FALSE] } if (!is.null(fun)) { if (nrow(xyv) > 0) { xyv <- subset(xyv, fun(xyv[,3])) } } } else { tr <- blockSize(x) xyv <- matrix(ncol=3, nrow=0) nl <- nlayers(x) for (i in 1:tr$n) { start <- cellFromRowCol(x, tr$row[i], 1) end <- start+tr$nrows[i]*ncol(x)-1 xyvr <- cbind(xyFromCell(x, start:end), getValues(x, row=tr$row[i], nrows=tr$nrows[i])) if (na.rm) { if (nl > 1) { nas <- apply(xyvr[,3:ncol(xyvr), drop=FALSE], 1, function(x) all(is.na(x))) } else { nas <- is.na(xyvr[,3]) } xyvr <- xyvr[!nas, ,drop=FALSE] } if (nrow(xyvr) > 0) { if (!is.null(fun)) { xyvr <- subset(xyvr, fun(xyvr[,3,drop=FALSE])) } rownames(xyvr) <- NULL xyv <- rbind(xyv, xyvr) } } } colnames(xyv) <- c('x', 'y', names(x)) if (nrow(xyv) == 0) { warning('no values in selection') return( NULL ) } cr <- .getPolygons(xyv[, 1:2, drop=FALSE], res(x), n) # xr <- xres(x)/2 # yr <- yres(x)/2 # if (n==4) { # cr <- matrix(ncol=10, nrow=nrow(xyv)) # cr[,c(1,4:5)] <- xyv[,1] - xr # cr[,2:3] <- xyv[,1] + xr # cr[,c(6:7,10)] <- xyv[,2] + yr # cr[,8:9] <- xyv[,2] - yr # } else if (n == 8) { # cr <- matrix(ncol=18, nrow=nrow(xyv)) # cr[,c(1,7:9)] <- xyv[,1] - xr # cr[,c(2,6)] <- xyv[,1] # cr[,3:5] <- xyv[,1] + xr # cr[,c(10:12,18)] <- xyv[,2] + yr # cr[,c(13,17)] <- xyv[,2] # cr[,14:16] <- xyv[,2] - yr # } else if (n == 16) { # cr <- matrix(ncol=34, nrow=nrow(xyv)) # cr[,c(1,13:17)] <- xyv[,1] - xr # cr[,c(2,12)] <- xyv[,1] - 0.5 * xr # cr[,c(3,11)] <- xyv[,1] # cr[,c(4,10)] <- xyv[,1] + 0.5 * xr # cr[,5:9] <- xyv[,1] + xr # cr[,c(18:22,34)] <- xyv[,2] + yr # cr[,c(23,33)] <- xyv[,2] + 0.5 * yr # cr[,c(24,32)] <- xyv[,2] # cr[,c(25,31)] <- xyv[,2] - 0.5 * yr # cr[,26:30] <- xyv[,2] - yr # } cr <- round(cr, digits=digits) sp <- lapply(1:nrow(cr), function(i) sp::Polygons(list(sp::Polygon( matrix( cr[i,], ncol=2 ) )), i)) sp <- sp::SpatialPolygons(sp, proj4string=.getCRS((x))) sp <- sp::SpatialPolygonsDataFrame(sp, data.frame(xyv[,3:ncol(xyv),drop=FALSE]), match.ID=FALSE) if (dissolve) { if(! requireNamespace("rgeos") ) { warning('package rgeos is not available. Cannot dissolve') } else { sp <- aggregate(sp, names(sp)) } } sp } raster/R/merge.R0000644000176200001440000003037314160021141013171 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # redesinged for multiple row processing # and arguments ext and overlap # October 2011 # version 1 setMethod('merge', signature(x='Extent', y='ANY'), function(x, y, ...) { x <- c(x, y, list(...)) x <- sapply(x, extent) x <- x[sapply(x, function(x) inherits(x, 'Extent'))] x <- lapply(x, function(e) t(bbox(e))) x <- do.call(rbind, x) x <- apply(x, 2, range) extent(as.vector(x)) } ) setMethod('merge', signature(x='RasterStackBrick', y='missing'), function(x, ..., tolerance=0.05, filename="", ext=NULL) { nl <- nlayers(x) if (nl < 2) { return(x) } else if (nl == 2) { merge(x[[1]], x[[2]], tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext) } else { do.call(merge, c(x=x[[1]], y=x[[2]], .makeRasterList(x[[3:nl]]), tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext)) } } ) setMethod('merge', signature(x='Raster', y='Raster'), function(x, y, ..., tolerance=0.05, filename="", overlap=TRUE, ext=NULL) { x <- c(x, y, list(...)) isRast <- sapply(x, function(x) inherits(x, 'Raster')) dotargs <- x[ !isRast ] x <- x[ isRast ] compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance) if (is.null(dotargs$datatype)) { dotargs$datatype <- .commonDataType(sapply(x, dataType)) } filename <- trim(filename) dotargs$filename <- filename nl <- max(unique(sapply(x, nlayers))) bb <- .unionExtent(x) if (nl > 1) { out <- brick(x[[1]], values=FALSE, nl=nl) } else { out <- raster(x[[1]]) } out <- setExtent(out, bb, keepres=TRUE, snap=FALSE) hasV <- sapply(x, hasValues) if (!any(hasV)) { return(out) } if (!is.null(ext)) { ext <- extent(ext) out1 <- extend(out, union(ext, extent(out))) out1 <- crop(out1, ext) test <- try( intersect(extent(out), extent(out1)) ) if (inherits(test, "try-error")) { stop('"ext" does not overlap with any of the input data') } out <- out1 ext <- extent(out) } if ( canProcessInMemory(out, 3) ) { if (!is.null(ext)) { if (overlap) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells, ] dat <- extract(x[[i]], ext) if (!is.matrix(dat)) { dat <- matrix(dat, ncol=1) } na <- ! rowSums(dat)==nl vv[na, ] <- dat[na, ] v[cells, ] <- vv } } } else { v <- rep(NA, ncell(out)) for (i in length(x):1) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) xy <- xyFromCell(out, cells) d <- extract(x[[i]], xy) j <- !is.na(d) v[cells[j]] <- d[j] } } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } else { # ignore overlap (if any) v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in length(x):1 ) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells, ] <- extract(x[[i]], ext) } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } } else { if (overlap) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells, ] dat <- getValues(x[[i]]) if (!is.matrix(dat)) { dat <- matrix(dat, ncol=1) } na <- ! rowSums(is.na(dat)) == nl vv[na, ] <- dat[na, ] v[cells, ] <- vv } } else { v <- rep(NA, ncell(out)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells] vv[is.na(vv)] <- getValues(x[[i]])[is.na(vv)] v[cells] <- vv } } rm(vv) out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } else { # no overlap (or ignore overlap) v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in length(x):1) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells, ] <- getValues(x[[i]]) } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } } } if (is.null(ext)) { rowcol <- matrix(NA, ncol=6, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] rowcol[i,1] <- rowFromY(out, xy1[2]) # start row on new raster rowcol[i,2] <- rowFromY(out, xy2[2]) # end row rowcol[i,3] <- colFromX(out, xy1[1]) # start col rowcol[i,4] <- colFromX(out, xy2[1]) # end col rowcol[i,5] <- i # layer rowcol[i,6] <- nrow(x[[i]]) } tr <- blockSize(out) # tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1))) # tr$row <- subset(tr$row, tr$row <= nrow(out)) # tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row) # tr$n <- length(tr$row) pb <- pbCreate(tr$n, dotargs$progress, label='merge') dotargs$x <- out out <- do.call(writeStart, dotargs) if (overlap) { if (nl == 1) { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out)) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { #reverse order so that the first raster covers the second etc. vv[] <- NA r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValues(x[[ rc[j,5] ]], r1, nr), nrow=nr, byrow=TRUE) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, as.vector(t(v)), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { vv[] <- NA r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) vv[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { # not overlap for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { for (j in nrow(rc):1) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { # ext is not null rowcol <- matrix(NA, ncol=10, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] xyout1 <- xyFromCell(out, 1) xyout2 <- xyFromCell(out, ncell(out)) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { j <- rowFromY(out, xy1[2]) rowcol[i,1] <- ifelse(is.na(j), 1, j) # start row on new raster j <- rowFromY(out, xy2[2]) rowcol[i,2] <- ifelse(is.na(j), nrow(out), j) # end row j <- colFromX(out, xy1[1]) rowcol[i,3] <- ifelse(is.na(j), 1, j) # start col j <- colFromX(out, xy2[1]) rowcol[i,4] <- ifelse(is.na(j), ncol(out), j) # end col rowcol[i,5] <- nrow(x[[i]]) j <- rowFromY(x[[i]], xyout1[2]) rowcol[i,6] <- ifelse(is.na(j), 1, j) j <- rowFromY(x[[i]], xyout2[2]) rowcol[i,7] <- ifelse(is.na(j), nrow(x[[i]]), j) - rowcol[i,6] + 1 j <- colFromX(x[[i]], xyout1[1]) rowcol[i,8] <- ifelse(is.na(j), 1, j) j <- colFromX(x[[i]], xyout2[1]) rowcol[i,9] <- ifelse(is.na(j), ncol(x[[i]]), j) - rowcol[i,8] + 1 rowcol[i,10] <- i # layer } } rowcol <- subset(rowcol, !is.na(rowcol[,1])) tr <- blockSize(out) # tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1))) # tr$row <- subset(tr$row, tr$row <= nrow(out)) # tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row) # tr$n <- length(tr$row) pb <- pbCreate(tr$n, dotargs$progress, label='merge') dotargs$x <- out out <- do.call(writeStart, dotargs) if (overlap) { if (nl == 1) { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out)) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { #reverse order so that the first raster covers the second etc. vv[] <- NA r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]), nrow=nr, byrow=TRUE) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, as.vector(t(v)), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { vv[] <- NA r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) vv[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { # no overlap for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { for (j in nrow(rc):1) { r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } pbClose(pb) writeStop(out) } ) raster/R/compare.R0000644000176200001440000001071714160021141013520 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod("all.equal", c("Raster", "Raster"), function(target, current, values=TRUE, stopiffalse=FALSE, showwarning=TRUE, ...) { compareRaster(target, current, ..., values=values, stopiffalse=stopiffalse, showwarning=showwarning) } ) compareRaster <- function(x, ..., extent=TRUE, rowcol=TRUE, crs=TRUE, res=FALSE, orig=FALSE, rotation=TRUE, values=FALSE, tolerance, stopiffalse=TRUE, showwarning=FALSE) { if (missing(tolerance)) { tol <- .tolerance() } else { tol <- tolerance } result <- TRUE objects <- c(x, list(...)) if (!isTRUE(length(objects) > 1)) { warning('There should be at least 2 Raster* objects to compare') return(result) } minres <- min(res(objects[[1]])) proj1 <- .getCRS(objects[[1]]) ext1 <- extent(objects[[1]]) ncol1 <- ncol(objects[[1]]) nrow1 <- nrow(objects[[1]]) res1 <- res(objects[[1]]) origin1 <- abs(origin(objects[[1]])) rot1 <- rotated(objects[[1]]) for (i in 2:length(objects)) { if (extent) { if (!(isTRUE(all.equal(ext1, extent(objects[[i]]), tolerance=tol, scale=minres )))) { result <- FALSE if (stopiffalse) { stop('different extent') } if (showwarning) { warning('different extent') } } } if (rowcol) { if ( !(identical(ncol1, ncol(objects[[i]]))) ) { result <- FALSE if (stopiffalse) { stop('different number or columns') } if (showwarning) { warning('different number or columns') } } if ( !(identical(nrow1, nrow(objects[[i]]))) ) { result <- FALSE if (stopiffalse) { stop('different number or rows') } if (showwarning) { warning('different number or rows') } } } if (crs) { thisproj <-.getCRS(objects[[i]]) if (is.na(proj1)) { proj1 <- thisproj } else { crs <- try (compareCRS(proj1, thisproj, unknown=TRUE), silent=TRUE) if (inherits(crs, "try-error")) { if (stopiffalse) { stop("invalid crs") } if (showwarning) { warning("invalid crs") } } else if (!crs) { result <- FALSE if (stopiffalse) { stop("different crs") } if (showwarning) { warning("different crs") } } } } # Can also check res through extent & rowcol if (res) { if (!(isTRUE(all.equal(res1, res(objects[[i]]), tolerance=tol, scale=minres)))) { result <- FALSE if (stopiffalse) { stop('different resolution') } if (showwarning) { warning('different resolution') } } } # Can also check orig through extent & rowcol, but orig is useful for e.g. Merge(raster, raster) if (orig) { dif <- origin1 - abs(origin(objects[[i]])) if (!(isTRUE(all.equal(dif, c(0,0), tolerance=tol, scale=minres)))) { result <- FALSE if (stopiffalse) { stop('different origin') } if (showwarning) { warning('different origin') } } } if (rotation) { rot2 <- rotated(objects[[i]]) if (rot1 | rot2) { if (rot1 != rot2) { if (stopiffalse) { stop('not all objects are rotated') } if (showwarning) { warning('not all objects are rotated') } result <- FALSE } else { test <- all(objects[[i]]@rotation@geotrans == objects[[1]]@rotation@geotrans) if (! test) { if (stopiffalse) { stop('rotations are different') } if (showwarning) { warning('rotations are different') } result <- FALSE } } } } if (values) { hv1 <- hasValues(objects[[1]]) hvi <- hasValues(objects[[i]]) if (hv1 != hvi) { if (stopiffalse) { stop('not all objects have values') } if (showwarning) { warning('not all objects have values') } result <- FALSE } else if (hv1 & hvi) { if (canProcessInMemory(objects[[1]])) { test <- isTRUE(all.equal(getValues(objects[[1]]), getValues(objects[[i]]))) if (! test) { if (stopiffalse) { stop('not all objects have the same values') } if (showwarning) { warning('not all objects have the same values') } result <- FALSE } } else { tr <- blockSize(objects[[1]]) for (j in 1:tr$n) { v1 <- getValues(objects[[1]], tr$row[j], tr$nrows[j]) v2 <- getValues(objects[[i]], tr$row[j], tr$nrows[j]) if (!isTRUE(all.equal(v1, v2))) { if (stopiffalse) { stop('not all objects have the same values') } if (showwarning) { warning('not all objects have the same values') } result <- FALSE break } } } } } } return(result) } raster/R/simplifyPols.R0000644000176200001440000000114214160021141014554 0ustar liggesusers .simplifyPolygons <- function(p) { g <- geom(p) out <- NULL for (i in 1:g[nrow(g), 'cump']) { gg <- g[g[,3]==i, ] keep <- rep(TRUE, nrow(gg)) for (j in 2:(nrow(gg)-1)) { if (gg[j,'x'] == gg[j-1,'x'] & gg[j,'x'] == gg[j+1,'x']) { keep[j] <- FALSE } else if (gg[j,'y'] == gg[j-1,'y'] & gg[j,'y'] == gg[j+1,'y']) { keep[j] <- FALSE } } gg <- gg[keep, ] out <- rbind(out, gg) } out <- as(data.frame(out), 'SpatialPolygons') out@proj4string <- p@proj4string if (.hasSlot(p, 'data')) { out <- sp::SpatialPolygonsDataFrame(out, p@data) } out } raster/R/stack.R0000644000176200001440000001270514160021141013176 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("stack")) { setGeneric("stack", function(x, ...) standardGeneric("stack")) } setMethod("stack", signature(x='missing'), function(x) { return(methods::new("RasterStack")) } ) setMethod("stack", signature(x='Raster'), function(x, ..., layers=NULL) { rlist <- list(x, ...) if ( length(rlist) == 1 ) { if (inherits(x, 'RasterLayer')) { stack(rlist) } else if (inherits(x, 'RasterBrick')) { return( .stackFromBrick(x, bands=layers) ) } else { # RasterStack return(x) } } else { stack( .makeRasterList(rlist) ) } } ) setMethod("stack", signature(x='character'), function(x, ..., bands=NULL, varname="", native=FALSE, RAT=TRUE, quick=FALSE) { if (length(x) == 0) { stop("no filenames supplied") } rlist <- c(x, list(...)) if ( varname != "") { if (length(rlist) == 1) { return(.stackCDF(x, varname=varname, bands=bands)) } else { s <- stack(sapply(rlist, function(i) stack(i, varname=varname, bands=bands))) return(s) } } else { if (length(rlist) == 1) { return(.quickStackOneFile(x, bands=bands, native=native)) } else if (quick) { if (!is.null(bands)) { stop("cannot do 'quick' if bands is not NULL") } return(.quickStack(rlist, native=native)) } return(stack(rlist, bands=bands, native=native, RAT=RAT)) } } ) setMethod("stack", signature(x='list'), function(x, bands=NULL, native=FALSE, RAT=TRUE, ...) { if (inherits(x, 'data.frame')) { return(utils::stack(x, ...)) } lstnames <- names(x) if (is.null(lstnames)) { namesFromList <- FALSE } else { lstnames <- validNames(lstnames) namesFromList <- TRUE } # first try simplest case, all RasterLayer objects cls <- sapply(x, function(i) inherits(i, 'RasterLayer')) if (all(cls)) { hd <- sapply(x, function(i) hasValues(i) ) if (!all(hd)) { if (sum(hd) == 0) { s <- methods::new("RasterStack") s@nrows <- x[[1]]@nrows s@ncols <- x[[1]]@ncols s@extent <- x[[1]]@extent crs(s) <- crs(x[[1]]) return(s) } warning('RasterLayer objects without cell values were removed') x <- x[hd] } if (length(x) > 1) { compareRaster(x) } s <- methods::new("RasterStack") s@nrows <- x[[1]]@nrows s@ncols <- x[[1]]@ncols s@extent <- x[[1]]@extent crs(s) <- crs(x[[1]]) s@layers <- x if (namesFromList) { names(s) <- lstnames } else { names(s) <- sapply(x, names) } return(s) } r <- list() if (is.character(x[[1]])) { first <- raster(x[[1]], native=native, RAT=RAT, ...) } else { first <- raster(x[[1]]) } if (!is.null(bands)) { lb <- length(bands) bands <- bands[bands %in% 1:nbands(first)] if (length(bands) == 0) { stop('no valid bands supplied') } if (length(bands) < lb) { warning('invalid band numbers ignored') } } j <- 1 for (i in seq(along.with=x)) { if (is.character(x[[i]])) { if (!is.null(bands)) { for (b in bands) { r[[j]] <- raster(x[[i]], band=b, native=native, RAT=RAT, ...) if (namesFromList) { names(r[[j]]) <- paste(lstnames[i], '_', b, sep='') } j <- j + 1 } } else { r[[j]] <- raster(x[[i]], band=1, native=native, RAT=RAT, ...) bds <- nbands(r[[j]]) if (namesFromList) { if (bds > 1) { names(r[[j]]) <- paste(lstnames[i], '_1', sep='') } else { names(r[[j]]) <- lstnames[i] } } j <- j + 1 if (bds > 1) { for (b in 2:bds) { r[[j]] <- raster(x[[i]], band=b, native=native, RAT=RAT, ...) if (namesFromList) { names(r[[j]]) <- paste(lstnames[i], '_', b, sep='') } j <- j + 1 } } } } else if (methods::extends(class(x[[i]]), "Raster")) { if (inherits(x[[i]], 'RasterStackBrick')) { # commented on 2012/11/21 because bands should # only refer to files, not to layers in Raster objects # if (!is.null(bands)) { # for (b in bands) { # r[j] <- raster(x[[i]], b) # j <- j + 1 # } # } else { if (inherits(x[[i]], 'RasterBrick')) { x[[i]] <- stack(x[[i]]) } r <- c(r, x[[i]]@layers) j <- j + nlayers(x[[i]]) # } } else { r[[j]] <- x[[i]] if (namesFromList) { names(r[[j]]) <- lstnames[i] } j <- j + 1 } } else { stop("Arguments should be Raster* objects or filenames") } } if ( length(r) == 1 ) { r <- r[[1]] if ( hasValues(r) ) { return( addLayer( methods::new("RasterStack"), r) ) } else { x <- methods::new("RasterStack") x@nrows <- r@nrows x@ncols <- r@ncols x@extent <- r@extent crs(x) <- crs(r) if(rotated(r)) { x@rotated = r@rotated x@rotation = r@rotation } return(x) } } else { return(addLayer(methods::new("RasterStack"), r)) } } ) setMethod("stack", signature(x='SpatialGridDataFrame'), function(x, ...) { .stackFromBrick(brick(x), ...) } ) setMethod("stack", signature(x='SpatialPixelsDataFrame'), function(x, ...) { x <- as(x, 'SpatialGridDataFrame') .stackFromBrick(brick(x), ...) } ) setMethod('stack', signature(x='kasc'), function(x) { as(x, 'RasterStack') } ) setMethod('stack', signature(x='SpatRaster'), function(x) { x <- as(x, "Raster") stack(x) } ) raster/R/coverBrick.R0000644000176200001440000000445414160021141014164 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('cover', signature(x='RasterStackBrick', y='Raster'), function(x, y, ..., filename=''){ rasters <- .makeRasterList(x, y, ..., unstack=FALSE) compareRaster(rasters) nl <- sapply(rasters, nlayers) un <- unique(nl) if (length(un) > 3) { stop('number of layers does not match') } else if (length(un) == 2 & min(un) != 1) { stop('number of layers does not match') } else if (nl[1] != max(un)) { stop('number of layers of the first object must be the highest') } outRaster <- brick(x, values=FALSE) compareRaster(rasters) filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(filename=filename) } else { format <- dots$format } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } else { overwrite <- dots$overwrite } if (is.null(dots$progress)) { progress <- .progress() } else { progress <- dots$progress } if (is.null(dots$datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } else { datatype <- dots$datatype } if ( canProcessInMemory(x, sum(nl)+nl[1])) { v <- getValues( rasters[[1]] ) v2 <- v for (j in 2:length(rasters)) { v2[] <- getValues( rasters[[j]] ) v[is.na(v)] <- v2[is.na(v)] } outRaster <- setValues(outRaster, v) if (filename != '') { outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } } else { if (filename == '') { filename <- rasterTmpFile() } outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite) tr <- blockSize(outRaster, sum(nl)) pb <- pbCreate(tr$n, label='cover', progress=progress) for (i in 1:tr$n) { v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] ) v2 <- v for (j in 2:length(rasters)) { v2[] <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i]) v[is.na(v)] <- v2[is.na(v)] } outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) outRaster <- writeStop(outRaster) } return(outRaster) } ) raster/R/fasterize.R0000644000176200001440000000506714160021141014070 0ustar liggesusers .makeSpPolygons <- function(polys, attr=NULL, crs="", ...) { x <- data.frame(geom(polys)) x$cump <- NULL ppp <- SpPolygons$new() x <- split(x, x$object) for (i in 1:length(x)) { y <- x[[i]] pp <- SpPoly$new() if ( any(y$hole > 0) ) { ym <- y[y$hole < 1, ] z <- split(ym, ym$part) for (j in 1:length(z)) { p <- SpPolyPart$new() p$set(z[[j]]$x, z[[j]]$y) z[[j]] <- p } yh <- y[y$hole > 0, ] zz <- split(yh, yh$part) for (j in 1:length(zz)) { id <- zz[[j]]$hole[1] z[[id]]$setHole(zz[[j]]$x, zz[[j]]$y) } for (j in 1:length(z)) { pp$addPart(z[[j]]) } } else { z <- split(y, y$part) for (j in 1:length(z)) { p <- SpPolyPart$new() p$set(z[[j]]$x, z[[j]]$y) pp$addPart(p) } } ppp$addPoly(pp) } if (!is.na(crs)) { ppp$crs <- crs } ppp } .fasterize <- function(p, r, values, background = NA, filename="", ...) { if (class(p) != "Rcpp_SpPolygons") p <- .makeSpPolygons(p) if (missing(values)) values <- 1:p$size() out <- raster(r) if (canProcessInMemory(out, 4)) { out <- setValues(out, p$rasterize(nrow(r), ncol(r), as.vector(extent(r)), values, background)) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } return(out) } else { temp <- out tr <- blockSize(out) pb <- pbCreate(tr$n, label='rasterize', ...) out <- writeStart(out, filename=filename, ... ) for (i in 1:tr$n) { x <- crop(temp, extent(temp, r1=tr$row[i], r2=tr$row[i]+tr$nrows[i]-1, c1=1, c2=ncol(out))) #x <- setValues(x, p$rasterize(nrow(x), ncol(x), as.vector(extent(x)), values, background)) #out <- writeValues(out, values(x), tr$row[i]) x <- p$rasterize(nrow(x), ncol(x), as.vector(extent(x)), values, background) out <- writeValues(out, x, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) return(out) } } .extractPolygons <- function(x, p) { addres <- max(res(x)) * 2 rr <- raster(x) er <- as.vector(extent(x)) sp <- .makeSpPolygons(p) npol <- sp$size() res <- list(rep(NA, sp$size())) for (i in 1:npol) { pp <- sp$subset(i-1) ep <- pp$extent$vector if (!(ep[1] >= er[2] || ep[2] <= er[1] || ep[3] >= er[4] || ep[4] <= er[3])) { rc <- crop(rr, extent(ep)+addres) rc <- .fasterize(pp, rc, values=1, background = NA) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # catch holes or very small polygons res[[i]] <- .xyValues(x, xy) } } } res } raster/R/setValues.R0000644000176200001440000001451514160021141014045 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('setValues', signature(x='RasterLayer'), function(x, values, ...) { if (is.factor(values)) { levs <- levels(values) d <- dim(values) values <- as.integer(values) if (!is.null(d)) { dim(values) <- d } x@data@isfactor <- TRUE x@data@attributes <- list(data.frame(ID=1:length(levs), VALUE=levs)) } if (is.matrix(values)) { if (ncol(values) == x@ncols & nrow(values) == x@nrows) { values <- as.vector(t(values)) } else if (ncol(values)==1 | nrow(values)==1) { values <- as.vector(values) } else { stop('cannot use a matrix with these dimensions') } } else if (!is.vector(values)) { stop('values must be a vector or matrix') } if (!(is.numeric(values) | is.factor(values) | is.logical(values))) { stop('values must be numeric, logical or factor') } if (length(values) == 1) { values <- rep(values, ncell(x)) } if (length(values) == ncell(x)) { x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@file@name <- "" x@file@driver <- "" x@data@values <- values x <- setMinMax(x) return(x) } else { stop("length(values) is not equal to ncell(x), or to 1") } } ) setMethod('setValues', signature(x='RasterStack'), function(x, values, layer=-1, ...) { if (layer > 0) { stopifnot(layer <= nlayers(x)) x[[layer]] <- setValues(x[[layer]], values, ...) return(x) } else { b <- brick(x, values=FALSE) setValues(b, values, ...) } } ) setMethod('setValues', signature(x='RasterBrick', values="ANY"), function(x, values, layer=-1, ...) { layer <- layer[1] if (is.array(values) & !is.matrix(values)) { dm <- dim(values) if (length(dm) != 3) { stop('array has wrong number of dimensions (needs to be 3)') } dmb <- dim(x) transpose <- FALSE if (dmb[1] == dm[2] & dmb[2] == dm[1]) { #if (dm[1] == dm[2]) { warning('assuming values should be transposed') } transpose <- TRUE } else if (dmb[1] != dm[1] | dmb[2] != dm[2]) { stop('dimensions of array do not match the RasterBrick') } # speed imrovements suggested by Justin McGrath # http://pastebin.com/uuLvsrYc if (!transpose) { values <- aperm(values, c(2, 1, 3)) } attributes(values) <- NULL dim(values) <- c(dm[1] * dm[2], dm[3]) ### } else if ( ! (is.vector(values) | is.matrix(values)) ) { stop('values must be a vector or a matrix') } if (!(is.numeric(values) | is.integer(values) | is.logical(values))) { stop('values must be numeric, integer or logical.') } # rownr <- round(rownr) if (layer < 1) { if (!is.matrix(values)) { values <- matrix(values, nrow=ncell(x), ncol=nlayers(x)) } if (nrow(values) == ncell(x)) { x@file@name <- "" x@file@driver <- "" x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@data@nlayers <- ncol(values) cn <- colnames(values) if (!is.null(cn)) { names(x) <- cn } x@data@values <- values x <- setMinMax(x) } else { stop("the size of 'values' is not correct") } } else { nlx <- nlayers(x) if (nlx==0) { x@data@nlayers <- 1 } bind <- FALSE layer <- round(layer) if (layer > nlx) { if (layer == nlx + 1) { bind <- TRUE } else { stop('layer number too high') } } if (length(values) == ncell(x)) { if ( inMemory(x) ) { if (bind) { x@data@values <- cbind(x@data@values, values) x@data@nlayers <- as.integer(x@data@nlayers + 1) } else { x@data@values[,layer] <- values } rge <- range(values, na.rm=TRUE) x@data@min[layer] <- rge[1] x@data@max[layer] <- rge[2] } else { if (canProcessInMemory(x)) { if (hasValues(x)) { x <- readAll(x) x@file@name <- "" x@file@driver <- "" x@data@inmemory <- TRUE x@data@fromdisk <- FALSE } else { x@data@values <- matrix(NA, nrow=ncell(x), ncol=nlx) x@data@min <- rep(Inf, nlx) x@data@max <- rep(-Inf, nlx) x@data@haveminmax <- TRUE x@data@inmemory <- TRUE } if (bind) { x@data@values <- cbind(x@data@values, values) x@data@nlayers <- as.integer(x@data@nlayers + 1) } else { x@data@values[,layer] <- values } rge <- range(values, na.rm=TRUE) x@data@min[layer] <- rge[1] x@data@max[layer] <- rge[2] } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='setValues',) r <- brick(x) nc <- ncol(x) if (bind) { r@data@nlayers <- as.integer(r@data@nlayers + 1) r <- writeStart(r, filename=rasterTmpFile(), format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- cbind(v, values[cellFromRowCol(x, tr$row[i], 1):cellFromRowCol(x, tr$row[i]+tr$nrows[i]-1, nc)]) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { r <- writeStart(r, filename=rasterTmpFile(), format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v[, layer] <- values[cellFromRowCol(x, tr$row[i], 1):cellFromRowCol(x, tr$row[i]+tr$nrows[i]-1, nc)] r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) return(r) } } } else { stop("length(values) is not equal to ncell(x)") } } return(x) } ) setMethod('setValues', signature(x='RasterLayerSparse'), function(x, values, index=NULL, ...) { stopifnot(is.vector(values)) if (!(is.numeric(values) | is.integer(values) | is.logical(values))) { stop('values must be numeric, integer or logical.') } if (is.null(index)) { if (! hasValues(x)) { stop('you must supply an index argument if the RasterLayerSparse does not have values') } stopifnot(length(x@index) == length(values)) } else { stopifnot(is.vector(index)) stopifnot(length(index) == length(values)) stopifnot(all(index > 0 | index <= ncell(x))) x@index <- index } x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@file@name <- "" x@file@driver <- "" x@data@values <- values x <- setMinMax(x) return(x) } ) raster/R/speasy.R0000644000176200001440000000252514160021141013374 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2015 # Version 1.0 # Licence GPL v3 # easy functions for creating SpatialLines* and SpatialPolygons* spLines <- function(x, ..., attr=NULL, crs="") { x <- c(list(x), list(...)) x <- rapply(x, sp::Line, how='replace') x <- lapply(1:length(x), function(i) sp::Lines(x[[i]], as.character(i))) x <- sp::SpatialLines(x) if (!is.null(attr)) { if (nrow(attr) == length(x)) { x <- sp::SpatialLinesDataFrame(x, attr) } else { msg <- paste('number of rows in attr (', nrow(attr), ') does not match the number of lines (', length(x), ')', sep='') stop(msg) } } if (!is.na(crs)) { crs(x) <- crs } x } spPolygons <- function(x, ..., attr=NULL, crs="") { x <- c(list(x), list(...)) x <- rapply(x, sp::Polygon, how='replace') x <- lapply(1:length(x), function(i) { if (length(x[[i]]) == 1) { sp::Polygons(x[i], as.character(i)) } else { sp::Polygons(x[[i]], as.character(i)) } }) x <- sp::SpatialPolygons(x) if (!is.null(attr)) { if (nrow(attr) == length(x)) { x <- sp::SpatialPolygonsDataFrame(x, attr) } else { msg <- paste('number of rows in attr (', nrow(attr), ') does not match the number of polygons (', length(x), ')', sep='') stop(msg) } } if (!is.na(crs)) { crs(x) <- crs } x } raster/R/makeTiles.R0000644000176200001440000000140514160021141014002 0ustar liggesusers .makeTiles <- function(x, y, filename="", ...) { res <- res(y) xy <- xyFromCell(y, 1:ncell(y)) xy1 <- xy - 0.5 * res xy2 <- xy + 0.5 * res tiles <- list() if (length(filename) > 1) { stopifnot(length(filename) == ncell(y)) } else if (filename != '') { ext <- extension(filename) extension(filename) <- '' filename <- paste0(filename, '_', 1:ncell(y), ext) } else if (!canProcessInMemory(x)) { filename <- rasterTmpFile() ext <- extension(filename) extension(filename) <- '' filename <- paste0(filename, '_', 1:ncell(y), ext) } else { filename <- rep("", ncell(y)) } for (i in 1:ncell(y)) { e <- extent(xy1[i,1], xy2[i,1], xy1[i,2], xy2[i,2]) tiles[[i]] <- crop(x, e, filename=filename[i], ...) } tiles } raster/R/freq.R0000644000176200001440000000652314160021141013027 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 setMethod('freq', signature(x='RasterLayer'), function(x, digits=0, value=NULL, useNA="ifany", progress='', ...) { if (!is.null(value)) { return( .count(x, value, digits=digits, progress=progress, ...) ) } if (canProcessInMemory(x, 3)) { d <- round(getValues(x), digits=digits) res <- table( d, useNA=useNA ) res <- cbind(as.numeric(names(res)), as.vector(res)) } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress, label='freq') z <- vector(length=0) for (i in 1:tr$n) { d <- round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits) res <- table(d, useNA=useNA ) res <- cbind(as.numeric(unlist(as.vector(dimnames(res)), use.names = FALSE)), as.vector(res)) z <- rbind(z, res) pbStep(pb, i) } res <- tapply(z[,2], as.character(z[,1]), sum) res <- cbind(as.numeric(names(res)), as.vector(res)) z <- z[is.na(z[,1]), ,drop=FALSE] if (isTRUE(nrow(z) > 0)) { z <- sum(z[,2]) res <- rbind(res, c(NA, z)) } res <- res[order(res[,1]), ] pbClose(pb) } colnames(res) <- c('value', 'count') return(res) } ) setMethod('freq', signature(x='RasterStackBrick'), function(x, digits=0, value=NULL, useNA="ifany", merge=FALSE, progress='', ...) { if (!is.null(value)) { return(.count(x, value, digits=digits, progress=progress, ...)) } nl <- nlayers(x) res <- list() pb <- pbCreate(nl, progress=progress, label='freq') for (i in 1:nl) { res[[i]] <- freq( raster(x, i), digits=digits, useNA=useNA, progress='', ...) pbStep(pb, i) } pbClose(pb) names(res) <- ln <- names(x) if (merge) { r <- res[[1]] colnames(r)[2] <- ln[1] if (nl > 1) { for (i in 2:nl) { x <- res[[i]] colnames(x)[2] <- ln[i] r <- merge(r, x, by=1, all=TRUE) } } return(r) } return(res) } ) .count <- function(x, value, digits=0, progress='', ...) { value <- value[1] if (nlayers(x) > 1) { if (canProcessInMemory(x, 2)) { if (is.na(value)) { v <- colSums(is.na(getValues(x))) } else { v <- round(getValues(x), digits=digits) == value v <- colSums(v, na.rm=TRUE) } } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress) v <- 0 for (i in 1:tr$n) { vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (is.na(value)) { v <- v + colSums(is.na(vv)) } else { vv <- round(v, digits=digits) == value v <- v + colSums(vv, na.rm=TRUE) } pbStep(pb, i) } pbClose(pb) } return(v) } else { if (canProcessInMemory(x, 2)) { if (is.na(value)) { x <- sum(is.na(getValues(x))) } else { v <- stats::na.omit(round(getValues(x), digits=digits)) x <- sum(v == value) } return(x) } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress) r <- 0 for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (is.na(value)) { r <- r + sum(is.na(v)) } else { v <- stats::na.omit(round(v, digits=digits)) r <- r + sum(v == value) } pbStep(pb, i) } pbClose(pb) return(r) } } } raster/R/cover.R0000644000176200001440000000424614160021141013210 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('cover', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ..., filename=''){ rasters <- .makeRasterList(x, y, ...) if (length(rasters) == 1) { return(rasters[[1]]) } compareRaster(rasters) nl <- sapply(rasters, nlayers) if (max(nl) > 1) { stop("Only single layer (RasterLayer) objects can be used if 'x' and 'y' have a single layer") } outRaster <- raster(x) filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(filename=filename) } else { format <- dots$format } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } else { overwrite <- dots$overwrite } if (is.null(dots$progress)) { progress <- .progress() } else { progress <- dots$progress } if (is.null(dots$datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } else { datatype <- dots$datatype } if (canProcessInMemory(x, length(rasters) + 2)) { v <- getValues( rasters[[1]] ) for (j in 2:length(rasters)) { v[is.na(v)] <- getValues(rasters[[j]])[is.na(v)] } outRaster <- setValues(outRaster, v) if (filename != '') { outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } } else { if (filename == '') { filename <- rasterTmpFile() } outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite ) tr <- blockSize(outRaster, length(rasters)) pb <- pbCreate(tr$n, progress=progress, label='cover') for (i in 1:tr$n) { v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] ) if (! is.matrix(v) ) { v <- matrix(v, ncol=1) } for (j in 2:length(rasters)) { vv <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i]) v[is.na(v)] <- vv[is.na(v)] } outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) outRaster <- writeStop(outRaster) } return(outRaster) } ) raster/R/rasterize.R0000644000176200001440000000504414160021141014077 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('rasterize', signature(x='matrix', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...){ .pointsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, na.rm=na.rm, ...) } ) setMethod('rasterize', signature(x='data.frame', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...){ x <- as.matrix(x) .pointsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, na.rm=na.rm, ...) } ) setMethod('rasterize', signature(x='sf', y='Raster'), function(x, y, ...) { x <- .sf2sp(x) #if (is.list(x)) {} rasterize(x, y, ...) } ) setMethod('rasterize', signature(x='SpatialPoints', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...){ .pointsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, na.rm=na.rm, ...) } ) setMethod('rasterize', signature(x='SpatialLines', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", ...){ .linesToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, ...) } ) setMethod('rasterize', signature(x='SpatialPolygons', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", getCover=FALSE, silent=TRUE, ...){ .polygonsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, getCover=getCover, silent=silent, ...) } ) setMethod('rasterize', signature(x='Extent', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", getCover=FALSE, silent=TRUE, ...){ # this could be done much more efficiently. x <- as(x, 'SpatialPolygons') .polygonsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, getCover=getCover, silent=silent,...) } ) raster/R/rasterFromFile.R0000644000176200001440000000664414160021141015022 0ustar liggesusers# R raster package # Date : September 2009 # Version 1.0 # Licence GPL v3 .rasterObjectFromFile <- function(x, band=1, objecttype='RasterLayer', native=FALSE, silent=TRUE, offset=NULL, ncdf=FALSE, ...) { x <- trim(x) if (x=="" | x==".") { # etc? stop('provide a valid filename') } # fix for opendap https://r-forge.r-project.org/forum/message.php?msg_id=5015 start <- tolower(substr(x, 1, 3)) if (! start %in% c('htt', 'ftp')) { y <- NULL try( y <- normalizePath( x, mustWork=TRUE), silent=TRUE ) if (! is.null(y)) { x <- y } } fileext <- toupper(extension(x)) if (fileext %in% c(".GRD", ".GRI")) { grifile <- .setFileExtensionValues(x, 'raster') grdfile <- .setFileExtensionHeader(x, 'raster') if ( file.exists( grdfile) & file.exists( grifile)) { return ( .rasterFromRasterFile(grdfile, band=band, objecttype, ...) ) } } if (! file.exists(x) ) { if (extension(x) == '') { grifile <- .setFileExtensionValues(x, 'raster') grdfile <- .setFileExtensionHeader(x, 'raster') if ( file.exists( grdfile) & file.exists( grifile)) { return ( .rasterFromRasterFile(grdfile, band=band, objecttype, ...) ) } else { # stop('file: ', x, ' does not exist') } } } #if (isTRUE(GMT)) { # return(.rasterObjectFromCDF_GMT(x)) #} if (( fileext %in% c(".HE5", ".NC", ".NCF", ".NC4", ".CDF", ".NCDF", ".NETCDF")) | (isTRUE(ncdf))) { return ( .rasterObjectFromCDF(x, type=objecttype, band=band, ...) ) } if ( fileext == ".GRD") { if (.isNetCDF(x)) { return ( .rasterObjectFromCDF(x, type=objecttype, band=band, ...) ) } } # if ( fileext == ".BIG" | fileext == ".BRD") { # return( .rasterFromRasterFile(x, band=band, objecttype, driver='big.matrix', ...) ) # } if (!is.null(offset)) { return ( .rasterFromASCIIFile(x, offset, ...) ) } ## MDSumner, NSIDC data if (fileext %in% c(".BIN")) { r <- .rasterFromNSIDCFile(x) if (!is.null(r)) return(r) } if(!native) { if (! .requireRgdal(FALSE) ) { native <- TRUE } } if (native) { if ( fileext == ".ASC" ) { return ( .rasterFromASCIIFile(x, ...) ) } if ( fileext %in% c(".BIL", ".BIP", ".BSQ")) { return ( .rasterFromGenericFile(x, type=objecttype, ...) ) } if ( fileext %in% c(".RST", ".RDC") ) { # not tested much return ( .rasterFromIDRISIFile(x, ...) ) } if ( fileext %in% c(".DOC", ".IMG") ) { # not tested much return ( .rasterFromIDRISIFile(x, old=TRUE, ...)) } if ( fileext %in% c(".SGRD", ".SDAT") ) { # barely tested return ( .rasterFromSAGAFile(x, ...) ) } } # old IDRISI format if ( fileext == ".DOC" ) { if (file.exists( extension(x, '.img'))) { return( .rasterFromIDRISIFile(x, old=TRUE, ...)) } } if ( fileext %in% c(".SGRD", ".SDAT") ) { r <- .rasterFromSAGAFile(x, ...) if (r@file@toptobottom | r@data@gain != 1) { return(r) } # else use gdal } if (! .requireRgdal(FALSE) ) { stop("Cannot create RasterLayer object from this file; perhaps you need to install rgdal first") } test <- try( r <- .rasterFromGDAL(x, band=band, objecttype, ...), silent=silent ) if (inherits(test, "try-error")) { if (!file.exists(x)) { stop("Cannot create a RasterLayer object from this file. (file does not exist)") } stop("Cannot create a RasterLayer object from this file.") } else { return(r) } } raster/R/rasterFromBIL.R0000644000176200001440000001264314160021141014545 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromGenericFile <- function(filename, band=1, SIGNEDINT=NULL, type='RasterLayer', crs="", ...) { hdrfname <- .setFileExtensionHeader(filename, "BIL") ini <- readIniFile(hdrfname, token=' ') if (ini[1,1] == "ENVI") { stop("This file has an ENVI header; I cannot read that natively, only via rgdal") } ini[,2] = toupper(ini[,2]) byteorder <- '' nbands <- as.integer(1) band <- as.integer(band) bandorder <- "BIL" minval <- Inf maxval <- -Inf nodataval <- -Inf pixtype <- '' gaps <- 0 xx <- xn <- xd <- yx <- yn <- yd <- NULL for (i in 1:length(ini[,1])) { if (ini[i,2] == "LLXMAP") {xn <- as.numeric(ini[i,3])} else if (ini[i,2] == "ULXMAP") {xn <- as.numeric(ini[i,3])} else if (ini[i,2] == "LRXMAP") {xx <- as.numeric(ini[i,3])} else if (ini[i,2] == "URXMAP") {xx <- as.numeric(ini[i,3])} else if (ini[i,2] == "LLYMAP") {yn <- as.numeric(ini[i,3])} else if (ini[i,2] == "ULYMAP") {yx <- as.numeric(ini[i,3])} else if (ini[i,2] == "LRYMAP") {yn <- as.numeric(ini[i,3])} else if (ini[i,2] == "URYMAP") {yx <- as.numeric(ini[i,3])} else if (ini[i,2] == "XDIM") {xd <- as.numeric(ini[i,3])} else if (ini[i,2] == "YDIM") {yd <- as.numeric(ini[i,3])} else if (ini[i,2] == "YMAX") {yx <- as.numeric(ini[i,3])} else if (ini[i,2] == "ROWS") {nr <- as.integer(ini[i,3])} else if (ini[i,2] == "COLUMNS") {nc <- as.integer(ini[i,3])} else if (ini[i,2] == "NROWS") {nr <- as.integer(ini[i,3])} else if (ini[i,2] == "NCOLS") {nc <- as.integer(ini[i,3])} else if (ini[i,2] == "NODATA") {nodataval <- as.numeric(ini[i,3])} else if (ini[i,2] == "NBITS") {nbits <- ini[i,3]} else if (ini[i,2] == "PIXELTYPE") {pixtype <- ini[i,3]} else if (ini[i,2] == "BANDGAPBYTES") {gaps <- ini[i,3]} else if (ini[i,2] == "BYTEORDER") {byteorder <- ini[i,3]} else if (ini[i,2] == "NBANDS") {nbands <- ini[i,3]} else if (ini[i,2] == "LAYOUT") {bandorder <- ini[i,3]} else if (ini[i,2] == "MINVALUE=") {try (minval <- as.numeric(unlist(strsplit(trim(ini[i,3]), ' ')))) } else if (ini[i,2] == "MAXVALUE=") {try (maxval <- as.numeric(unlist(strsplit(trim(ini[i,3]), ' ')))) } } wrldf <- extension(filename, '.blw') if (file.exists(wrldf)) { a <- readLines(wrldf) if (is.null(xn)) xn <- as.numeric(a[5]) if (is.null(xd)) xd <- as.numeric(a[1]) if (is.null(yx)) yx <- as.numeric(a[6]) if (is.null(yd)) yd <- -1 * as.numeric(a[4]) } if (is.null(xd)) { xd <- (xx - xn) / (nc - 1) } if (is.null(yd)) { yd <- (yx - yn) / (nr - 1) } if (!is.null(xn)) { xn <- xn - 0.5 * xd if (is.null(xx)) { xx <- xn + nc * xd } } else { xx <- xx + 0.5 * xd xn <- xx - nc * xd } if (!is.null(yn)) { yn <- yn - 0.5 * yd if (is.null(yx)) { yx <- yn + nr * yd } } else { yx <- yx + 0.5 * yd yn <- yx - nr * yd } if (gaps > 0) { stop('generic raster with gaps not supported') } if (band < 1) { band <- 1 warning('band set to 1') } else if (band > nbands) { band <- nbands warning('band set to ', nbands) } minval <- minval[1:nbands] maxval <- maxval[1:nbands] minval[is.na(minval)] <- Inf maxval[is.na(maxval)] <- -Inf if (type == 'RasterBrick') { x <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) x@data@nlayers <- as.integer(nbands) x@data@min <- minval x@data@max <- maxval } else { x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) x@data@band <- as.integer(band) x@data@min <- minval[band] x@data@max <- maxval[band] } if (x@data@min[1] != Inf) {x@data@haveminmax <- TRUE } else { x@data@haveminmax <- FALSE } x@file@nbands <- as.integer(nbands) if (bandorder %in% c("BSQ", "BIP", "BIL")) { x@file@bandorder <- bandorder } if (type == 'RasterBrick') { names(x) <- rep(gsub(" ", "_", extension(basename(filename), "")), nbands) } else { lnames <- gsub(" ", "_", extension(basename(filename), "")) if (nbands > 1) { lnames <- paste(lnames, '_', band, sep='') } names(x) <- lnames } x@file@name <- filename if (!is.null(SIGNEDINT)) { if(SIGNEDINT) { pixtype <- 'SIGNEDINT' } else { pixtype <- 'UNSIGNEDINT' } } if (nbits == 8) { if (pixtype == 'SIGNEDINT') { dataType(x) <- 'INT1S' } else { if (pixtype != 'UNSIGNEDINT') { warning('assuming data is unsigned. If this is not correct, use dataType(x) <- "INT1S"') } dataType(x) <- 'INT1U' } } else if (nbits == 16) { if (pixtype == 'SIGNEDINT') { dataType(x) <- 'INT2S' } else { if (pixtype != 'UNSIGNEDINT') { warning('assumed data is unsigned. If this is not correct, use dataType(x) <- "INT2S"') } dataType(x) <- 'INT2U' } } else if (nbits == 32) { if (pixtype == 'FLOAT') { dataType(x) <- 'FLT4S' } else { dataType(x) <- 'INT4S' } } else if (nbits == 64 & pixtype == 'FLOAT') { dataType(x) <- 'FLT8S' # } else { # dataType(x) <- 'INT8S' # } } else { stop(paste('unexpected nbits in BIL:', nbits)) } if (byteorder == "I") { x@file@byteorder <- 'little' } else if (byteorder == "M") { x@file@byteorder <- 'big' } else { x@file@byteorder <- .Platform$endian } x@data@fromdisk <- TRUE x@file@driver <- bandorder x@file@nodatavalue <- nodataval return(x) } raster/R/imageplot2.R0000644000176200001440000001636114163413661014155 0ustar liggesusers# The functions is based on a function in the fields package # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html # # Adjustments by Robert Hijmans # July 2011 .asRaster <- function(x, col, breaks=NULL, r=NULL, colNA=NA, alpha=NULL) { if (!is.null(breaks)) { if (is.logical(x)) { x <- x * 1 } x[] <- as.numeric(cut(as.vector(x), breaks, include.lowest=TRUE)) } else { #if (is.function(fun)) { # x[] <- fun(x) #} if (is.null(r)) { r <- range(x, na.rm=TRUE) } if (r[1] == r[2]) { r[1] <- r[1] - 0.001 r[2] <- r[2] + 0.001 } x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) } x[] <- col[x] if (!is.na(colNA)) { x[is.na(x)] <- grDevices::rgb(t(grDevices::col2rgb(colNA)), maxColorValue=255) } if (!is.null(alpha)) { x[] <- paste(substr(as.vector(x), 1, 7), t(alpha), sep='') } as.raster(x) } .rasterImagePlot <- function(x, col, add=FALSE, legend=TRUE, horizontal = FALSE, legend.shrink=0.5, legend.width=0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab=NULL, graphics.reset=FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, lab.breaks=NULL, axis.args=NULL, legend.args = NULL, interpolate=FALSE, box=TRUE, breaks=NULL, zlim=NULL, zlimcol=NULL, fun=NULL, asp, colNA = NA, alpha=NULL, npretty=0, ...) { if (!is.null(alpha)) { if (is.vector(alpha)) { alpha <- matrix(alpha, nrow=nrow(x), ncol=ncol(x), byrow=TRUE) } alpha <- as.matrix(alpha) alpha[alpha < 0] <- 0 alpha[alpha > 1] <- 1 alpha[is.na(alpha)] <- 1 alpha <- alpha * 255 + 1 a <- c(0:9, LETTERS[1:6]) a <- paste(rep(a, each=16), rep(a, times=16), sep='') a <- a[alpha] alpha <- matrix(a, nrow(alpha), ncol(alpha), byrow=TRUE) } ffun <- NULL if (is.character(fun)) { if (fun %in% c('sqrt', 'log')) { if (fun == 'sqrt') { ffun <- fun fun <- sqrt } else { ffun <- fun fun <- log } } else { fun <- NULL } } else { fun <- NULL } lonlat <- .couldBeLonLat(x, warnings=FALSE) if (missing(asp)) { if (lonlat) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } } e <- as.vector(t(bbox(extent(x)))) x <- as.matrix(x) if (!is.null(fun)) { x <- fun(x) } x[is.infinite(x)] <- NA if (!is.null(zlim)) { if (!is.null(zlimcol)) { x[x < zlim[1]] <- zlim[1] x[x > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { x[x < zlim[1] | x > zlim[2]] <- NA } } if (is.null(breaks)) { suppressWarnings(zrange <- range(x, zlim, na.rm=TRUE)) } else { suppressWarnings(zrange <- range(x, zlim, breaks, na.rm=TRUE)) } if (! is.finite(zrange[1])) { legend <- FALSE } else { x <- .asRaster(x, col, breaks, zrange, colNA, alpha=alpha) } old.par <- graphics::par(no.readonly = TRUE) if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (legend.only) { box <- FALSE } else { if (!add) { graphics::par(plt = bigplot) if (lonlat & (npretty > 0)) { lX <- pretty(e[1]:e[2], npretty) lX <- lX[lX >= -180 & lX <= 180] lY <- pretty(e[3]:e[4], npretty) lY <- lY[lY >= -90 & lY <= 90] labelsX <- parse(text=paste(lX, "^o", sep="")) labelsY <- parse(text=paste(lY, "^o", sep="")) plot(NA, NA, xlim=e[1:2], ylim=e[3:4], type = "n", , xaxs ='i', yaxs = 'i', asp=asp, axes = FALSE, ...) graphics::axis(1, lX, labels=labelsX) graphics::axis(2, lY, labels=labelsY) } else { plot(NA, NA, xlim=e[1:2], ylim=e[3:4], type = "n", , xaxs ='i', yaxs = 'i', asp=asp, ...) } } graphics::rasterImage(x, e[1], e[3], e[2], e[4], interpolate=interpolate) big.par <- graphics::par(no.readonly = TRUE) } if (legend) { if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { graphics::par(old.par) stop("plot region is too small. Cannot add a legend\n") } ix <- 1 minz <- zrange[1] maxz <- zrange[2] if (minz == maxz) { if (!is.null(breaks)) { breaks=minz } else { minz <- minz - 0.001 maxz <- maxz + 0.001 } } graphics::par(new=TRUE, pty = "m", plt=smallplot, err = -1) if (!is.null(breaks)) { binwidth <- (maxz - minz)/100 midpoints <- seq(minz, maxz, by = binwidth) axis.args <- c(list(side=ifelse(horizontal,1,4), mgp=c(3,1,0), las=ifelse(horizontal,0,2)), axis.args) if (is.null(axis.args$at)) { axis.args$at <- breaks } if (is.null(axis.args$labels) ) { axis.args$labels=lab.breaks } } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } if (!horizontal) { plot(NA, NA, xlim=c(0, 1), ylim=c(minz, maxz), type="n", xlab="", ylab="", xaxs ='i', yaxs = 'i', axes=FALSE) if (is.null(breaks)) { mult <- round(max(1, 100 / length(col) )) xx <- .asRaster( ((mult*length(col)):1)/mult, col, colNA=colNA) } else { xx <- rev(.asRaster(midpoints, col, breaks=breaks, colNA=colNA)) } graphics::rasterImage(xx, 0, minz, 1, maxz, interpolate=FALSE) if (!is.null(ffun)) { at <- graphics::axTicks(2) axis.args$at <- at if (ffun=='sqrt') { at <- at^2 if (max(at) > 5) { at <- round(at, 0) } else { at <- round(at, 1) } at <- unique(at) axis.args$at <- sqrt(at) } else { at <- exp(at) if (max(at) > 5) { at <- round(at, 0) } else { at <- round(at, 1) } at <- unique(at) axis.args$at <- log(at) } axis.args$labels <- at } do.call(graphics::axis, axis.args) graphics::box() } else { plot(NA, NA, ylim=c(0, 1), xlim=c(minz, maxz), type="n", xlab="", ylab="", xaxs ='i', yaxs = 'i', axes=FALSE) if (is.null(breaks)) { mult <- round(max(1, 100 / length(col) )) xx <- t(.asRaster((1:(mult*length(col)))/mult, col, colNA=colNA )) } else { xx <- t(.asRaster(midpoints, col, breaks=breaks, colNA=colNA)) } graphics::rasterImage(xx, minz, 0, maxz, 1, interpolate=FALSE) do.call("axis", axis.args) graphics::box() } if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) } if (!is.null(legend.args)) { do.call(graphics::mtext, legend.args) } } mfg.save <- graphics::par()$mfg if (graphics.reset | add) { graphics::par(old.par) graphics::par(mfg = mfg.save, new = FALSE) } else { graphics::par(big.par) graphics::par(plt = big.par$plt, xpd = FALSE) graphics::par(mfg = mfg.save, new = FALSE) } if (!add & box ) graphics::box() invisible() } raster/R/zApply.R0000644000176200001440000000103414160021141013341 0ustar liggesusers# Oscar Perpinan Lamigueiro zApply <- function(x, by, fun=mean, name='', ...){ z <- getZ(x) stopifnot(length(z) == nlayers(x)) ##from aggregate.zoo my.unique <- function(x) x[match(x, x) == seq_len(length(x))] my.sort <- function(x) x[order(x)] if (is.function(by)) { by <- by(z) } ##stopifnot(length(time(x)) == length(by)) b <- stackApply(x, as.numeric(factor(by)), match.fun(fun), ...) zval <- my.sort(my.unique(by)) b <- setZ(b, zval, name) names(b) <- as.character(zval) b } raster/R/mask.R0000644000176200001440000004515414160021141013030 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 1.0 # Licence GPL v3 setMethod('mask', signature(x='Raster', mask='sf'), function(x, mask, ...) { mask <- .sf2sp(mask) mask(x, mask, ...) } ) setMethod('mask', signature(x='Raster', mask='Spatial'), function(x, mask, filename="", inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...){ if (inherits(mask, 'SpatialPolygons')) { m <- .fasterize(mask, x, values=rep(1,length(mask))) } else { m <- rasterize(mask, x, 1, silent=TRUE) } mask(x, m, filename=filename, inverse=inverse, maskvalue=NA, updatevalue=updatevalue, ...) } ) setMethod('mask', signature(x='RasterLayer', mask='RasterLayer'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] compareRaster(x, mask) out <- .copyWithProperties(x) if ( canProcessInMemory(x, 3)) { x <- getValues(x) mask <- getValues(mask) if (is.na(maskvalue)) { if (updateNA) { if (inverse) { x[!is.na(mask)] <- updatevalue } else { x[is.na(mask)] <- updatevalue } } else { if (inverse) { x[!is.na(mask) & !is.na(x)] <- updatevalue } else { x[is.na(mask) & !is.na(x)] <- updatevalue } } } else { if (updateNA) { if (inverse) { x[mask != maskvalue] <- updatevalue } else { x[mask == maskvalue] <- updatevalue } } else { if (inverse) { x[mask != maskvalue & !is.na(x)] <- updatevalue } else { x[mask == maskvalue & !is.na(x)] <- updatevalue } } } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } else { if (filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (is.na(updatevalue)) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (updateNA) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterStackBrick', mask='RasterLayer'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ compareRaster(x, mask) maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] out <- .copyWithProperties(x) if (canProcessInMemory(x, nlayers(x)+4)) { x <- getValues(x) if (is.na(maskvalue)) { if (updateNA) { if (inverse) { x[!is.na(getValues(mask))] <- updatevalue } else { x[is.na(getValues(mask))] <- updatevalue } } else { if (inverse) { x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue } else { x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue } } } else { if (updateNA) { if (inverse) { x[getValues(mask) != maskvalue] <- updatevalue } else { x[getValues(mask) == maskvalue] <- updatevalue } } else { if (inverse) { x[getValues(mask) != maskvalue & !is.na(x)] <- updatevalue } else { x[getValues(mask) == maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (is.na(updatevalue)) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (updateNA) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterLayer', mask='RasterStackBrick'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ compareRaster(x, mask) out <- brick(mask, values=FALSE) maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] if (canProcessInMemory(mask, nlayers(x)*2+2)) { x <- getValues(x) x <- matrix(rep(x, nlayers(out)), ncol=nlayers(out)) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { x[!is.na(getValues(mask))] <- updatevalue } else { x[is.na(getValues(mask))] <- updatevalue } } else { if (inverse) { x[getValues(mask)!=maskvalue] <- updatevalue } else { x[getValues(mask)==maskvalue] <- updatevalue } } } else { if (is.na(maskvalue)) { if (inverse) { x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue } else { x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue } } else { if (inverse) { x[getValues(mask)!=maskvalue & !is.na(x)] <- updatevalue } else { x[getValues(mask)==maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterStackBrick', mask='RasterStackBrick'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ nlx <- nlayers(x) nlk <- nlayers(mask) if ( nlx != nlk ) { if (nlx == 1) { x <- raster(x, 1) return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...)) } if (nlk == 1) { mask <- raster(mask, 1) return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...)) } if (! ((nlx > nlk) & (nlx %% nlk == 0)) ) { stop('number of layers of x and mask must be the same,\nor one of the two should be 1, or the number of layers of x\nshould be divisible by the number of layers of mask') } } updatevalue <- updatevalue[1] maskvalue <- maskvalue[1] compareRaster(x, mask) out <- brick(x, values=FALSE) ln <- names(x) names(out) <- ln if (canProcessInMemory(x, nlx*2)) { x <- getValues(x) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { x[!is.na(as.vector(getValues(mask)))] <- updatevalue } else { x[is.na(as.vector(getValues(mask)))] <- updatevalue } } else { if (inverse) { x[as.vector(getValues(mask)) != maskvalue] <- updatevalue } else { x[as.vector(getValues(mask)) == maskvalue] <- updatevalue } } } else { if (is.na(maskvalue)) { if (inverse) { x[!is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue } else { x[is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue } } else { if (inverse) { x[as.vector(getValues(mask)) != maskvalue & !is.na(x)] <- updatevalue } else { x[as.vector(getValues(mask)) == maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) names(out) <- ln } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(!is.na(m))] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(is.na(m))] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m != maskvalue)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m == maskvalue)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(!is.na(m)) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(is.na(m)) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m != maskvalue) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m == maskvalue) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } pbClose(pb) out <- writeStop(out) names(out) <- ln return(out) } } ) raster/R/stackSelect.R0000644000176200001440000000364314160021141014337 0ustar liggesusers# Author: Robert J. Hijmans # Date: March 2011 # Version 1 # Licence GPL v3 if (!isGeneric("stackSelect")) { setGeneric("stackSelect", function(x, y, ...) standardGeneric("stackSelect")) } setMethod('stackSelect', signature(x='RasterStackBrick', y='Raster'), function(x, y, recycle=FALSE, type='index', filename='', ...) { filename <- trim(filename) out <- brick(x, values=FALSE) nlx <- nlayers(out) nly <- nlayers(y) compareRaster(out, y) if (recycle) { stopifnot(nly > 1) stopifnot(nlx > nly) stopifnot(nlx %% nly == 0) type <- tolower(type) stopifnot(type %in% c('index', 'truefalse')) nl <- nlx+nlx+nly maxnl <- nly nr <- nlx / nly id <- as.integer( (rep(1:nr, each=nly)-1) * nly ) } else { if (nly == 1) { out <- raster(out) } else { out@data@nlayers <- nlayers(y) } nl <- nlx+nly maxnl <- nlx id <- 0 } ib <- (nlx+1):(nlx+nly) if (canProcessInMemory(x, nl)) { y <- round(getValues(y)) if (type == 'truefalse') { y <- t(apply(y,1,function(x)x*(1:nly))) } y[y < 1 | y > maxnl] <- NA x <- cbind(getValues(x), y) x <- apply(x, 1, function(z) z[z[ib]+id] ) out <- setValues(out, t(x)) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } } else { if (filename == '') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=nlx+nly) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { j <- round(getValues(y, row=tr$row[i], nrows=tr$nrows[i])) if (type == 'truefalse') { j <- t(apply(j, 1, function(x)x*(1:nly))) } j[j < 1 | j > maxnl] <- NA v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- cbind(v, j) v <- apply(v, 1, function(z) z[z[ib]+id] ) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) } return(out) } ) raster/MD50000644000176200001440000006524214173106421012072 0ustar liggesusersa14a3d7969e7b15d41dfe5c4bc38eec2 *DESCRIPTION c5ff767d5ea7a7a6a49f549b5b5bc811 *NAMESPACE acc6b01e8279fcc87df32726a63d25c5 *NEWS ab4cbfca4ecdd25ce38911c198cfbf58 *R/AAAClasses.R 13a231c08446107ae73c670ee3bc95fc *R/AAgeneric_functions.R d32c4ab014be1d776d2bfa27c03fab7f *R/GDALtransient.R 37de111007563a036b3c4ff9b0c44f10 *R/Geary.R c926b505e31beca60d533fbc3be7f5f3 *R/RGB.R 74d31dd27f9d90029cf77ec794a8d510 *R/RcppExports.R a3d7863b67d7082a38f2950d6506d588 *R/addFiles.R 3d7c42d20e94e309a0e41ba83def09ec *R/addLayer.R 9a416b217b36aa4d7ef0343e54d9d491 *R/adjacency.R f94b1b2006609dddc33e39c8394095bb *R/adjacent.R 8921889dc13b148108655cf31c92bca0 *R/aggregate_3d.R 44d2b809db27d7168d503547625e6980 *R/aggregate_sp.R ff994f0748631dd4b33a66519007b5b5 *R/alignExtent.R c16ee6733660d259c8514d698ca82755 *R/animate.R 38d5e3712bf2753e6e71ce7f069cd23f *R/approxNA.R a949236b46eddee18c3896a4961186e8 *R/area.R 94b1441314aeac38bc15c201b4177a73 *R/arith.R bf04afcad4358556c49107a1520fa4de *R/arith_sp.R 223a73282a5b7abf959de7591e3f782d *R/as.array.R 5afcb23cebdba03b141ce9c042e9c07b *R/as.character.R 243172558f6bc96d13b0553e45351808 *R/as.data.frame.R d8bf63eb2aa46c73b4262465e9bf0f8f *R/as.logical.R 69ac4322db0e04a858126f25e2615aa6 *R/as.matrix.R 9e6744ec4c5b3b47336c38bf548c4744 *R/as.raster.R 639e4149cb7cfcaf2f75c723e14b2ee9 *R/as.spatial.R 419c3e2ba9099803ece3263b56ef7109 *R/atan2.R 2c3454d4cf365032e2b10684f9371eea *R/bands.R 987e9d69116214719acc12856c6fbbfd *R/barplot.R 0a827c38839fdf9b5940e15d38a5178b *R/bbox.R 6f997e76c4acd6511eb779b0f0f6cdcf *R/bilinearValue.R af9f7bced2ab3e9ff8e1664fa65a65c0 *R/bind.R d8ef8184c0597963bc5b394514779f80 *R/blend.R 81091b02646df5e926d643054bfb1a4c *R/blockSize.R 76e9d60b56e6723cfc9c1a7b12e2cc4a *R/boundaries.R eba8a19bc63557510ef3847bafa77377 *R/boxplot.R cf433cf505d6c879d6fd01e4f2af8603 *R/brick.R 3290ddcf0d07c55f487f29a5a5db6f65 *R/buffer.R c1307200faa6a5c035a0b27a9cdc7242 *R/calc.R ba05befbddbda6b2f68af9c7b281c26b *R/canProcessInMemory.R 0c175d3dc30adb04de7884d31aeda7c3 *R/cellFromLine.R ff57e204ecf1ce8c1a5d856d6f48d129 *R/cellFromPolygon.R ee9284d0a874c6b0f70d3c23b80bb997 *R/cellRowCol.R 511be694eaa6d8dabb07f71b359584bc *R/cellStats.R 962fa03ae16fb39dd0a062db9c764a08 *R/cellValues.R 447c54f0d60d48252375bf1ef844e4bd *R/cellsFromExtent.R 0ca810a368ea01f31a80a032050dc2e8 *R/clamp.R 5289fa90f9f43bead14a186206a4a87b *R/clearValues.R 84e34cac205568a2135f758a17bee7a0 *R/click.R 6e363fa8f051973c114eb31cc4c96f66 *R/clump.R 351b50b3f150e45d47a551b7b71ee7d5 *R/clusterR.R 48b4e8a11b16c36113b2cd6bb1b87668 *R/coerce.R 860fa84e6201107a04e7d866a2e254f8 *R/col2RGB.R f1670f8661d7b88ab58e624cf6b9fd16 *R/colortable.R f6d126480109fc7634a8315b08dbf1c1 *R/commonDataType.R 827323b00c5f8b1aa7c8943037531df0 *R/compare.R 7ad41720914aea50d9bb76567cd45ea4 *R/compareCRS.R eda5f13e2587c0042edfccf8559ca9da *R/compare_Logical.R 738ad4284c26ddf9c6d19c2a6a7fc93e *R/connection.R 73b59c32e0bfc32ece529d1d10dfbbde *R/contour.R 3683aa76f6958a3d6f862b4854b1925f *R/cor.R 8ac3a44714aef67724c423e4069100e4 *R/corLocal.R 5f58712dd68a5bdbc1d8e097ae142b56 *R/cover.R c5cee6b1f0665437644f3de3438d6193 *R/coverBrick.R 36dbb06ede20bf7032bd981aa5f83890 *R/coverPolygons.R 0c0d037dff70a4928b296cb04e032815 *R/crop.R f8225a9cf624a23559130787e475b24d *R/cropSpatial.R 8211e9f469edb2f2e44f8e6c773c76ef *R/crosstab.R a1ec4fd447a90c7897f834a97232f63e *R/cut.R a68f1be5ce1e7c76e0fd5e212727d436 *R/cv.R 97fcb57787fcd622e1f2e20b7499954e *R/dataProperties.R 404e7fd3c0406b68bfc7fc3cb1e2ce59 *R/dataType.R fe1d06f6438e456b5ddd8457c04c9688 *R/density.R cf1c7271abc57723f4f48a40cb6b560d *R/destair.R 3569502b06ca9dd4ff0bed5e1b2de97e *R/dim.R b5b54b82c4d70b48fb7197c6e0da9eca *R/direction.R 5c20cb7cb312d7d54cacf115fd2644cb *R/disaggregate.R 24c4878bb3638a2880f904559685c4ca *R/distance.R 24d285c859ff146e8aec5f668b159274 *R/distanceFromPoints.R 0e64c880346a3eb1ab744bfb640fa32a *R/distanceRows.R 356c0143144007aeb2ec36dd8d484100 *R/distanceToEdge.R 1b208d9b095d0d4b793c7650e96f8307 *R/dotdens.R 77f4a35b2e283a261c13e43d24ed6d88 *R/drawExtent.R 39906674932824f0946d652f5e921732 *R/drawPoly.R 15a69d75a655ea21315bf42d820fa2e5 *R/drivers.R 28d4608948b3e427ca4e442cf212d1be *R/dropLayer.R 1d3d39dddde8b283c4abb0ef2420c6e5 *R/erase.R 0211864aa2373d754beb32aa0535610a *R/extend.R cbf7b48e3bff9ef889cb07a81f010507 *R/extension.R bfb938b239c217e1ea5837388b2b2aa6 *R/extent.R 8139e117ac8136b28d291b9fb7bbbd63 *R/extentUnion.R 6647b0e90dbf346d504ecbeb3d0e8ae4 *R/extract.R 72059da5ec2ee8ab387e8e827a287262 *R/extractExtent.R c9bafa825311cfeee7065739c4b8dc8d *R/extractLines.R 489f13a80f3d77b1520a86653a85c81d *R/extractPoints.R 0d590116cd286cb368ba41ce67970913 *R/extractPoints_sp.R f8471ccd803dba46895e6946081947c0 *R/extractPolygons.R 29e5855fd3088aae375f366917c1de6e *R/factor.R 938b2e7b40165cecd578854b17dd41f1 *R/fasterize.R 65f4a18f3c138c4bc4d5330a924bc03b *R/filler.R 5559b633eff091779be327d29dc06844 *R/fixDBFnames.R 36abd141ac3e1fc3bbf882655a6b13cf *R/flip.R 9c0ebeceb09632195710f8987e9ce1e4 *R/flowpath.R b7eda323030b3b6052da439621efaf4b *R/focal.R b185ebd78ade2717268f47da9dfbddef *R/focalFun.R b99dabe8a4fc9a6ea5324f4837a3e834 *R/focalWeight.R 8a3d52c8ae0c450e7ff7437a71be45fe *R/fourCellsFromXY.R b33d32af14b1c2134efdf9600d57bc08 *R/frbind.R a306dc4052e259e8e4bfe7d21a5b2433 *R/freq.R 2b88a2a6226d72afb17fce30b9816b5e *R/fullFileName.R 473743a1707348b5ce3587eb19b8e076 *R/gainoffset.R 69c6342a584d0ff9695e0891d57f6b25 *R/gdal.R 41333b3a0ffa2f669f9a85ec4a239029 *R/gdalFormats.R f47b5d910876525145f91c12efe5a708 *R/geom.R 42ae99870e0c5384a739c13226659f80 *R/getData.R 81d42d06f44c8aad01b7b9f7006c4795 *R/getValues.R 87755ff732f48d32388e653cd1002d2a *R/getValuesBlock.R c48910388a81b11c2d81d16481481df2 *R/getValuesFocal.R 560a823c98ff1eec1a6e59182566e75e *R/getValuesRows.R c399352f999594490645dd9983422e0c *R/gridDistance.R 336cccf6b1e7f60984900be6afbc8744 *R/gridDistance2.R 202e1a07121ba2e7300be48c539baf95 *R/hdr.R e171c0e26ab30938e8a2b86eacfcd9c6 *R/hdrBIL.R 7640cca85fd501d0cc7ea2014e89e9bb *R/hdrBov.R 44e44a116ea414878fa126eb7123ec7c *R/hdrEnvi.R ffb1e1fffedeaf3d88da7f2b4a5bb58b *R/hdrErdasRaw.R 1188875b30080a2256b30a2b2fc35db4 *R/hdrIDRISI.R afe8e5e23e04bc4acc264b9a21c3325a *R/hdrPRJ.R 7d198df29cac5a5487dc0a45bfba5baf *R/hdrRaster.R f17b5f21fceb414e0f5212365a372780 *R/hdrSAGA.R 13d8bbbd7f5531a8a445f1bf161ca055 *R/hdrVRT.R 714c3163e7b131cda273de02680bf792 *R/hdrWorldFile.R 05888d9c29b9f1abbe76463a336471ac *R/head.R f563de32e0a487250a3bb5d92ec441b2 *R/hillShade.R 19f1aa4c637023a03b2e740de5a92d70 *R/hist.R b298a63e44a38c4b863f84b14daf3c1f *R/idwValue.R 10e7398cbeda28ee4ba6e0cd25148ce4 *R/ifelse.R d6a67f9f37483c096af83b984e69cde7 *R/image.R f2415c0dff9ad3ce4e3dc6c563b512ce *R/imageplot.R 5465182c0553377a5c0f2add4e143d22 *R/imageplot2.R dceda6fd18da8d9ca20eb37ef2826418 *R/index.R e94b8627cabd7ed87640591bb239db42 *R/indexReplace.R 4de14e4f63dab22cfcd88e43886f994b *R/indexReplaceBrick.R 101fc0f279984201a9f8d414247135ac *R/inifile.R 582d01b5f334611df0f3c10a4425a917 *R/init.R f590d5b5c82c554d8265d45ba6918498 *R/intDataType.R ee596050104b87661ebc9cdd3fc76cdf *R/interpolate.R 742a4d76a01616d8ea8eeef9d98a78a9 *R/intersect.R 3e89740cc539bdbd0f047505ca87bb65 *R/intersect_sp.R c5676dcb0c5c3f3833ec20a24b8ee273 *R/is.na.R eb19a9a646ba3324ef3c884c4df29e2a *R/isLonLat.R 4d4d56411dc82d5e078e043a09262126 *R/kernelDens.R 07fdd2495921d2d68a7822f9114da623 *R/kernelDensity.R dc657a0641c9e9872e4cf7a49b0ef36e *R/kml.R 47c8a0e20b610efc4b305ee6ea20d303 *R/kml_multiple.R 8f5e3d9782b51c1e8d36445cc1d23974 *R/labels.R b4179153acc3a507dae81ce4f22d4d43 *R/layerStats.R 0682cb18ad33039dbe87f4d3020fdc69 *R/layerize.R fce67465da1557ea30ce733d55ae58ba *R/localFun.R fab545b64b373abfdf5b5449258d6e87 *R/makeProjString.R a2b4bba0df69e68fefbd7ef6f739c867 *R/makeRasterList.R d9e51011e1649d5e92932c690f922b47 *R/makeTiles.R 43b8e24c9dc81be206e430b861e2cafb *R/mask.R 3b1452b78edefeb41aaf863a0558daac *R/match.R 4b3271ec4b879f3e12a1c3387011c1e6 *R/math.R 1cb6fcb1766b9889e304fffe45456c04 *R/maxDataType.R 6f3a28b7f8321add9e5c177a6db7ffef *R/mean.R 7c80bbd23f662cd66b89e36ab142bb3f *R/median.R 4bd41b92505176fb819d38898de6aff0 *R/merge.R dd481842a2f215a8247c925021e3f20e *R/metadata.R e7e9c586a34ed5b9c6342f8996a5ee83 *R/minValue.R b3b4cc504a77f3ebecdaa149b42bb3a7 *R/modal.R b6ca32c691056fdb586b2bc34a0404bc *R/modalRaster.R dc0846a3c1e08c0ff74596c2d560c727 *R/moran.R 65e78908ced302e34d91a9bb3bccaa9c *R/mosaic.R 723299315161be75225cfe9748bc3cb0 *R/movingFun.R 9f083cb4990404c0368c2eeccb83b44d *R/multiCore.R 03a7a03798a1af13f3b84dd95d5e435d *R/naValue.R 4f5ec46e6384ec2b9128833d7eadfcf0 *R/names.R 84c63eefe0e98f95e7e7e539978aaa06 *R/ncell.R e5573118f1750271a1d2b7424580dd6b *R/netCDFread.R 563d1ffa7bad45d6f13cb9f59bf59543 *R/netCDFreadCells.R edb5d1799e51311ba7455e607f458100 *R/netCDFtoRasterCD.R 322c27edefaca28163f122af13324d27 *R/netCDFtoRasterGMT.R eae8a0e3489850d0ee6468c5ff13e5c2 *R/netCDFtoStack.R 9afd0c3c981eca7b7a240284aeefe46f *R/netCDFutil.R 877959d8f56a175814a0f62351c15cc3 *R/netCDFwriteCD.R c6086ef40bb390abc3c2cb8d605985ce *R/newPLot.R 07075bf7ca758c2814aa861eb6b103e4 *R/nlayers.R 3b100bb974182c34fa7b9a96eef8af22 *R/notused.R 4307d1a90539118fa716255bc574e2bd *R/nsidcICE.R a0de213f4841210f12896a7070b86d59 *R/origin.R bac6784c58fb041dbf04c518d62d00c7 *R/overlay.R 6b38244fff7a4c97cc1563cd73cb435d *R/pairs.R 2bff0c9e7996158a256aa3a48eb84b99 *R/persp.R 84552041874d1bd05ff4d947e43516f8 *R/plot.R a20ebe13a940951f63df8765b1e9b23a *R/plot2rasters.R d0b5e69f09e127505e248766a42bcccc *R/plotCT.R 59a42f68753300c351aed2b1a056ace8 *R/plotExent.R f837f0ab0e6317e100217173c6f6a220 *R/plotRGB.R 55dd82521806975cb9ffc775bb66fa50 *R/plotRaster.R e05b963d86aa7a141fc0b2d81aa75084 *R/plotRaster2.R 8121a7963c6df9451984ba48a424bdce *R/pointdistance.R 4da2d934bbad84939f3389e9c6c1322b *R/predict.R 49647c0795d0ad58eec6ddac36fb5f20 *R/print.R 253e1b00d879156bcb58506c6a558296 *R/progressBar.R c6b4626c571ec2eff28bc15fcc538ceb *R/project.R cdbb9e93b085ecc2f9f237cc4ad0223f *R/projectRaster.R 41c78fbf1a56aab5f0a73dbc9b5fc199 *R/projection.R 712c7df567606133082ffba0cd94e8e0 *R/properties.R c9ed2fd56a87388235a2d1a42dc6ebb2 *R/quad.R 959d84e06b9cbf6d09d105c05d07a4fa *R/quantile.R a91bdbdcebd7402a4cee54d85cc707ef *R/randomize.R 9da327b886c01486a4b73093e4034b97 *R/range.R 1e5b1d6b78a069cb13883ff577b1305a *R/raster.R 91d847505ff1f0f3fbceedb1616904e2 *R/rasterFromASCII.R 2b43e3986df342ca7c02a47ff515ff4c *R/rasterFromBIL.R 78633f66f4c398a38b98ddb16d17e1e9 *R/rasterFromCells.R 39cf8356751dd8a531342a5e230d7b5f *R/rasterFromFile.R 1471320258fadb399c07c783594ac888 *R/rasterFromGDAL.R c841bd3998409d0e53545d432d77c8dd *R/rasterFromIDRISI.R 55ad484bbbbfe080b476960edd648f36 *R/rasterFromRasterFile.R 196b47554f0e664e2cf8167b7907a119 *R/rasterFromSAGA.R 4e791da3a684b32251a70d8911ca4b7d *R/rasterFromSurferFile.R c1c87a0f47aa712464dbfea6b27c7eec *R/rasterFromXYZ.R 602d0105e14e41291c929f9fa76e9553 *R/rasterOptions.R c233ac9cb77fd74e19177d088a5e23b9 *R/rasterToPoints.R 15526fa18847e2abb5890eed237c7a77 *R/rasterToPolygons.R 294fe3ebf9b6e88e68a25191e3cfb23f *R/rasterize.R ab3591b3943fb07c295a86ed03d575f0 *R/rasterizeLines.R 56d85d75f1ce531d62c241c7716385c4 *R/rasterizePoints.R dbd3935ae5db793baf63f960f2152742 *R/rasterizePointsNGB.R d8d6dc7aba673bde0641a4f7eda55134 *R/rasterizePolygons.R a52d0e6a3136f71cd1a255fed00232cc *R/ratify.R 518a95b00727311cabf545ba058f3fff *R/read.R 695f1725011a1d9425047b1bd4e3413a *R/readAscii.R 59fb9dbb789ce3482a4bd44ca45e4070 *R/readCells.R da877121a31f503168f00f46ca017314 *R/readCellsGDAL.R e6d5e22bf62060574f43f163f03f7fd9 *R/readRasterBrick.R ad792be1ca35ae5417305b01673fcd0b *R/readRasterLayer.R d79c53bc60249bb986f0757686a3f4e9 *R/reclassify.R 1f35c47c68396e84765009782bdb5e2a *R/rectify.R 1a5e287e9f675ab0a555477eb451aa08 *R/replaceProperties.R 2cca0c2bb270c3e6d8069659f63b6c1e *R/resample.R 401d560a908a18a30c3abdd8c4e03b45 *R/rotate.R d84843e6dc16186f18fa72521dd69e77 *R/roundExtent.R 92fb25c2ac0978e1791c2a9ca0cc5ecb *R/rowMinMax.R 4d690b320b82abbadeb602f42013ed82 *R/rowSums.R 14d119e0f6087f27bf10bd39928841d8 *R/sampleAlong.R 6a1e363958e224d953908c61cc413c89 *R/sampleInt.R 7f5e2576a5059c4be71a924dab3c313f *R/sampleRandom.R 2c0f1866f03f6aa99a196be323935ae3 *R/sampleRegular.R dde18bac17eb4451dcf8638caac0394f *R/sampleStratified.R 4e88eeadfebc7677d048b3db2d877795 *R/scale.R e63c3a401431d2f564d51ee935ebf5d2 *R/scalebar.R 34ec7a60cc28656236113e5c855fb859 *R/select.R 6de7caaa6cd0ea99b975f303c3eeb446 *R/setCV.R 34dc1fd270672ba8b1be4e47effb845c *R/setExtent.R ed66a4a05a4eff8d28e816db894e0c0b *R/setFileExt.R 6ca20616b2c906921cffad12ccc9729c *R/setMinMax.R 4df5ae66acfb78af801d2428e7abbb06 *R/setValues.R f1e1b942bee3ed1d13ee7979e4143393 *R/setZ.R 1010411cb78ed3c845eb7f96ec5645ec *R/sf.R be144dd9615afc1bd208fd51d0778fbf *R/shift.R 58cb9d9e3981c6c1cde695e8b0284418 *R/show.R d3981f681dc22613c58f8ce51d281efc *R/shp.R ae93f0532b393c60f6f405a3dde3df22 *R/simplifyPols.R f52699bf005321bfca93b99a115d5096 *R/slopeAspect.R b5e894d2985bbe4227bc40cfecd16825 *R/sparse.R 04aa9733205684e9291c89bb631ca103 *R/speasy.R ab4f85ef0e2042d165a0c5e03193f093 *R/spplot.R 9af457e5d4a1ca121ef485cb727ace6d *R/stack.R 05f28ccae6b20bdc268a0b79aa62ca8a *R/stackApply.R 6c6d872beb2eda2a4e5180db284dae29 *R/stackFile.R 849916a196040efc968e30838f2879f1 *R/stackQuick.R 3c9bab661c2685f5d24dead85fc3b468 *R/stackSelect.R 1b303a6b2b64a906fe025a64f4e0918e *R/stretch.R 1dfa4b4eabbb5166095ef0997e541523 *R/subs.R b3ab8c53fbed516d7861e1013e1a030b *R/subset.R 578ca78311eaa7083a77068f113a5544 *R/summary-methods.R 5dc827b239f6ef103922763f0def87f1 *R/summary.R dbcb9f3bf888558fe01d9eadb44b00a9 *R/symdif.R 1506b1d20c4df47ec8ba2bbd54ee2d93 *R/terrain.R 78cbfb2f2d6817dbad53abd1b4551c14 *R/text.R 7b5cdfb953ba2fe08ba43a101c21090b *R/tmpFile.R d7da964a76a847225bba55c77d604c24 *R/transpose.R 8f32d751d3ed74e8e11affe086e452d0 *R/trim.R d6a3aa82137988cad5b620baf783c948 *R/union.R 36e2536bdc2c2b4f94f268f7ca41a55e *R/union_sp.R e96edabab189ce83040243aabe04ec08 *R/unique.R 2c3df52854a3eee3ee465458ddebace4 *R/unstack.R 8f5035307d6bc37d4547a228a0694b06 *R/update.R f37c880549f2d7b406d4236db8fa9767 *R/validCell.R 77c452ac21dcb8a477cc7bab75537b73 *R/values.R 8beb18c54d98351e652abd01fd3431ed *R/weighted.mean.R 8d9076e0152bc0abd23676b57d98d99d *R/which.R 935c01abacb5c85c2568a96d2168e6dc *R/which.max.R d250349f68bb5139da55130f064efaa6 *R/whiches.max.R 4526f3ffe6c9e811fc50c3c15f19737a *R/writeAllAscii.R f4bb9da532b458441ec7ebb4f90265ef *R/writeAllGDAL.R 2f692f9d9a80e31ba11b4bf3d15ff900 *R/writeAllRaster.R 05c398b294bc0cde175a30dd5d474570 *R/writeRaster.R 258629598211c6ac8369429fd3e4afc6 *R/writeStartStop.R deb195398ea10a1bb5a4f8c560e4ae29 *R/writeStartStopAscii.R 870f4a77a6837f1a7ba04e3e19d33fd8 *R/writeStartStopGDAL.R 73ffb9d479226e1898f4a8edfcb899c4 *R/writeStartStopRaster.R 92813940b773594f4fa6644516d9c596 *R/writeValues.R b4aa89ba67a4cf4a9eeea9039cad38da *R/xyCell.R 4fef0b80cdc7fb9661ba565d5ff66f1f *R/xyMinMax.R b550e3cc1c8c68c9bb09cf9d49274bf6 *R/xyResolution.R 05741efcecfbde55fa8c361a95109525 *R/xyValuesBuffer.R a87634900f485c7e3e9fcb882fe191e0 *R/zApply.R 4299faa46bbe88e8cf023e4d761d345a *R/zonal.R 04018c59009b0d1d04b9f018faa0032f *R/zoom.R 47e0201bf562a2e166876b23e67bad65 *R/zzz.R 6c07fde4477b55c74a0bcccbe4d37567 *build/partial.rdb 836fc2bffa338d9f9a721e00d9cd6078 *inst/external/countries.rds c85d689dcf4c7101db48cbab30338201 *inst/external/lux.dbf e729936bf5360b37a15365fc295a1901 *inst/external/lux.prj c6fbaf5566eecb7bb8538e818f9a79d8 *inst/external/lux.rds 4ae2847099f7574e36516738dc411a0f *inst/external/lux.shp 5d6304a3bc11ffe01ffdda30514d15df *inst/external/lux.shx 73f8af2ca1abc3d0a175f1078ae38d34 *inst/external/rlogo.grd b3ed7227bb04142c4a36cbe25067d5ac *inst/external/rlogo.gri 7d6a75f2a0f3617e8f0774411be8349d *inst/external/test.grd cb22d2072ca597b022e481bb86f9f989 *inst/external/test.gri abe388883dc8cf4db5b9cd1ba772e8e6 *inst/tinytest/test_getvaluesblock.R 6752d3a8080729215b419c3639b09a0a *inst/tinytest/test_rasterize.R c60d9a1d08b489ce345c3638e411d381 *inst/tinytest/test_sf-coercion.R d532931dc72b3675c3dbbb98637d6e50 *inst/tinytest/test_subset.R ceefb20f4aeab6dd25bd045d72c70e06 *inst/tinytest/tinytest.R 97ba849347e4e2cd0eba47d512c07bd3 *man/Arith-methods.Rd 062d623d936269344de74c0775a068b1 *man/Compare-methods.Rd 6047dd6990d8ca1867fcb7ebf2fe05b0 *man/Extent-class.Rd ec18beb5b959eea05b65f727b24eed40 *man/KML.Rd e6e3f3c6901dd528896fde2dec1afc89 *man/Logic-methods.Rd 90a5f6ebc995d8def86a883e5a98c286 *man/Math-methods.Rd 470cbb508192734f425651d2cc3fcb07 *man/NAvalue.Rd e0699ad27d1b74936cbcedf1547ed2b4 *man/RGB.Rd 24934375376bdd9010bf5c71617c681b *man/Raster-classes.Rd e4ab6daa41de6a19490be9d9cc956571 *man/Rcpp-classes.Rd e3d3cc8737a9f33cf329de9ce0878f1d *man/Summary-methods.Rd b14a0a3a9582eadb82f89dbf9e7dba5b *man/addLayer.Rd d0e0fc612111552db2f0e55af4538113 *man/adjacent.Rd 0110577bbec47b41f72bee8429106680 *man/aggregate.Rd 1b49ae5146bdd428bf04bee70402c4d0 *man/alignExtent.Rd 19a6a6770b9fae0971db7dc799539ff4 *man/animate.Rd c708716bd7f41b1a6a4ecc1b8c54c92a *man/approxNA.Rd dfe007e1052d23dda3b9784aba89dc74 *man/area.Rd aeb32acd8f2562a4be9466831bf19cca *man/as.character.Rd fdb2cb9945bec16650d28ead4bbc90ff *man/as.data.frame.Rd 732c69d3f3ddcab57841ae4ceeac39fd *man/as.list.Rd b446948e7356af78c84b0bc346bf23f1 *man/as.logical-methods.Rd 662c1b65d81e75d0129d0020b24cc3cd *man/as.matrix.Rd 9216dbe150f5a645a44579822924fd62 *man/as.raster.Rd c612b935d86bf046db17968078e479db *man/atan2.Rd 52af0b0f0165ed9f1adf09be70f8327d *man/autocor.Rd 7177a45476a606bd173fea369423efda *man/bands.Rd 831f328f9e60041530a9497cfdab8e79 *man/barplot.Rd 02a2eb6bcce0645927c08bd812bbe87d *man/bind.Rd 466aa200d0693ae98314b11a6b1a963d *man/blockSize.Rd 02c2913abdf3cb3a4aca698ce203ab48 *man/boundaries.Rd 4e0c3c9e094797886d0173b778703c46 *man/boxplot.Rd 86700a94c980eef90de504d03b56e8d0 *man/brick.Rd 918df7db0b9274795ac3efab104eebea *man/buffer.Rd 7c8666c96e39af0b71ac586ad7adfade *man/calc.Rd 5918d9d863a591f10b398efdc8afd560 *man/cellFrom.Rd 60d38d663b7c2dfccdedfdebbc6569d6 *man/cellStats.Rd 6b5b8cf57f426d559e19397a7aad4da1 *man/cellsFromExtent.Rd 9cee6ad09ea2580c851a86f5650d89ee *man/clamp.Rd b5b53fce5c4f90f54cde8e05637e7413 *man/clearValues.Rd 8a3e0f6208c4182a2697782679ff2dea *man/click.Rd 2ebd41d6cfc8f7c5a2346d0c4de47fcc *man/clump.Rd 66003173e7e845973e894febd2460553 *man/cluster.Rd b7c052ff1e9353ca37b841311a9bf80c *man/colortable.Rd 661c53c5061d2afad75a184c93a747ee *man/compare.Rd a60bb5d5c0e3e4b9410a7c4e1ec4c8ef *man/compareCRS.Rd 78e4f54301f3326efbe16948df9e8044 *man/contour.Rd de85fec287afd9c9de1669ce2c4960fa *man/coords.Rd cd960262c5ebbc98b5a5c4b8d5f79d20 *man/corLocal.Rd 5e2fe7abb2a52e90881bfc558db68462 *man/cover.Rd 205cba14a90985f45a26faee3dc4b8ec *man/crop.Rd 4466dde37143b0690cfa5e10f022b305 *man/crosstab.Rd 177261fd9a3340c67cf0a1bf73885c06 *man/cut.Rd dc99e1ef680f7b9049951d10bcefcdd4 *man/cv.Rd c4997a4932e35e6a7e85d671d986491b *man/dataType.Rd f94fa04f4b3569318055995695daa3a2 *man/datasource.Rd c16b7475ab57a14888eb4667045b7945 *man/density.Rd 91adc79fc209ceb2c458617e8b05d891 *man/dimensions.Rd b9f0dd57238470a916f3e7666d08e61c *man/direction.Rd c19c1f8056f716eef167647ba39f9d13 *man/disaggregate.Rd 235efc054ac9f762359efa50c731d35e *man/distance.Rd 376870b69cca718812adb22e2c7f5021 *man/distanceFromPoints.Rd 1e848e176b8ee174e029949f6ad0d4c7 *man/draw.Rd e076ee0e57ae6d598245bc6edb72ead2 *man/drawExtent.Rd fceee5e0d8aa31f5cc939c39a79b5348 *man/erase.Rd 99f7e13b5e6afc12efa47de2221cc57e *man/extend.Rd 07c974ef67d5a7c1cba408243cd153d7 *man/extension.Rd 20ed9649970ed7417152361eb8ea1840 *man/extent.Rd b36382ae09b5ca36bc392c962eb4240d *man/extract.Rd db605e0c6d28bb31c5c2975158af5c7e *man/extractIndex.Rd fa36a1f1da83b141883bd7e1acf4e0a7 *man/extremeValues.Rd a103f9d1d8f7210f60b208d0d4939a8e *man/factor.Rd 090cc4bc07e3b292ec6cf0fcce488a5d *man/filename.Rd 2ec80f9c27b436691f588884a12a7185 *man/filledContour.Rd d3507591bbd48355a2ca5a0c0a14875e *man/flip.Rd 0fdd013f07fa15e98f7584e56d0fdc2d *man/flowpath.Rd 3b1b521bf9ad29a8640cc222779e3e01 *man/focal.Rd dfffae349e18a9c470a77c334ebdc825 *man/focalWeight.Rd d9d4239a537b007e365432128ef73605 *man/freq.Rd 5461bd4b1168c90c87114c034ba7c007 *man/gainoffset.Rd 53bdd9a6973432c87c5647c5781af1fd *man/geom.Rd 46d44569448474076646859f7b51eacf *man/getData.Rd cb460a6fc25c59a198e53393ef84f96e *man/getValues.Rd c13a2f31ae576b2039e97fa0e1c45744 *man/getValuesBlock.Rd 53a4dc1378183de9cfa52c8e69ccf947 *man/getValuesFocal.Rd e190506d42b3f55d1bb334343e57fd54 *man/gridDistance.Rd 73a8f9cc67816633c52711724e64d3d2 *man/hdrFiles.Rd 8ba92ca56ef61af1e401464bd17c41eb *man/headtail.Rd 9f0420e15109dfb25c3139cc50099411 *man/hillShade.Rd 68880b38ba1eb97ad9dfbc8ea1f66e38 *man/hist.Rd 9b1252c3f6ed4e29b17c946c05403756 *man/image.Rd fc4e9785a37e59954bea419acc632bde *man/iniFile.Rd 25fc38474ad16403c07b3050c9d82ae2 *man/init.Rd 121c1235505f156e40a8eaaff2ff2e6c *man/interpolate.Rd 94dc32beeabf591626ae709ce58e81d9 *man/intersect.Rd 7f2c6305803056683c9ad6c1c2a12522 *man/isLonLat.Rd e8530a3ad8334ff8e7fc661d1f310279 *man/layerStats.Rd e092d99baacb3aaebe175f110d820589 *man/layerize.Rd d7302146d92f94c726a0401c2984edde *man/localFun.Rd cbe4595d169ba7098ee0b44557f1a1ea *man/mask.Rd 2a0bbbd2e0efb26ac8e9c44a4253abc6 *man/match.Rd be52c9e2c2ce749d45be5cb707cdf68b *man/merge.Rd 05dc1861b372377b90d0b096aa56e8c7 *man/metadata.Rd 44f5b456ad02bc79beee393cffafa928 *man/modal.Rd 14f0e3bd16e39a89d688967f3b36419d *man/mosaic.Rd e2843923291909994b044b5b5df8921d *man/movingFun.Rd 5931dc996f774e57473eb5a07459e666 *man/names.Rd e9273cc2e1661bdd63250b8ea2aed9a4 *man/ncell.Rd c990b0a4b2a1ae6e907c990c083d39ca *man/nlayers.Rd 09dae45a5cd229a20f38f6b70d23c867 *man/origin.Rd c9daecbd5f5d3b03a02245c908341b4a *man/overlay.Rd 96379250813832bfe1652669def0239e *man/pairs.Rd e94b18a4a00d391e254f98eef93c8269 *man/persp.Rd 3102d0f993589d05e80400505497bd11 *man/plot.Rd 72d3eb6e724a714675a43764056ae38b *man/plotRGB.Rd 12cd4acddba25e73a5931bd5d391c124 *man/pointDistance.Rd 5bace8750de3039d68493eb99045fe2e *man/predict.Rd 649fb977044f9b3e4ec2ab9c76948478 *man/programming.Rd b6e54a4e7bf00287fef4068a7f4af516 *man/projectRaster.Rd eec4d3481f2265365fd42e8d296b1e72 *man/projection.Rd a8845dcadffe786cde4381e41248508f *man/properties.Rd 3856e4785976d4b9bf4a106a43264353 *man/quantile.Rd 65de5497d3a91d37684c78f9359caa69 *man/raster-package.Rd 3a5f52a375bf4e5cf3fe6f2f0df70382 *man/raster.Rd a6aa5de8355b28dfa53ca2235d47c658 *man/rasterFromCells.Rd 1a1751ea1d994eadb4c396819248cb77 *man/rasterFromXYZ.Rd f054a1cf6c56e2172f6f0cd06b876280 *man/rasterOptions.Rd b63711dbe7a92ad1a046c162d9d2ff1d *man/rasterTmpFile.Rd 1b73ddcea853fc367fb6366cf792b9b3 *man/rasterToContour.Rd 23c9157771afe5511abdaed6a1a22d2a *man/rasterToPoints.Rd dc0711203b90a21520713da68c073fe4 *man/rasterToPolygons.Rd 2b135488332bf3e4fb3c33ae895b087b *man/rasterize.Rd c4ea12aba9e9c6bcdfc6b7566b67648b *man/readAll.Rd 40855686027a4b860b7d20bbadd95385 *man/reclassify.Rd 915b36bbb7502f826a50176e0a6c569b *man/rectify.Rd c96ce430e6bce8289e58d5fee1c7f98a *man/replacement.Rd b467c1189d3e3f621b22f884e7920173 *man/resample.Rd 047fec72514e8285949b806862b355c2 *man/resolution.Rd b66fe12ac3f37bd1c5994f5dde357524 *man/rotate.Rd ed9fbb6a3897e879db3a3a69e52f9cd4 *man/rotated.Rd 41d041a46aa0c6c09cde226a6b2f656d *man/round.Rd 8630daa11802d3345b6bf84af630534d *man/roundExtent.Rd c6dbaf8fd250c3ca8dfea03a4c60dc2e *man/rowFromCell.Rd e8f314b24a086c2488423d4f508261aa *man/rowSums.Rd e45578499872a35f1eca04a4dab96519 *man/sampleInt.Rd 312503eb3f0dd257b4af2d67f610e8c9 *man/sampleRandom.Rd 6f1d1030509a529a131b8113d284e8f0 *man/sampleRegular.Rd 8bbb13b612af7b005394c24488de4540 *man/sampleStratified.Rd 5f5dcd3f48adf1a538aae9dbb3d547eb *man/saveStack.Rd bcd299674cde2c613bacbcc3d2079d2a *man/scale.Rd 8354efe9ed5c8a961cae776def53e90a *man/scalebar.Rd ce25c74b937c2caf54437e10a9328eb1 *man/select.Rd dd97555856192ee24fddd9f2ce408b65 *man/setExtent.Rd ec02ea1ca10608ac69efbd96624e9251 *man/setMinMax.Rd c43e9441ea59f250cc2785700e90b687 *man/setValues.Rd ba9da985b63e6dfa2bdec1cae19dde0b *man/shapefile.Rd 5690dbb96d2ea0408fd53bb32adca297 *man/shift.Rd b052d0eb654757fff60e517dc55461e7 *man/slopeAspect.Rd 12f269a5a41d6c1d66d7e8cdcdaeebe7 *man/spEasy.Rd 5974008cad6f29b0fdfa8eee8b7acd52 *man/spplot.Rd 0aaea33d3a71164077222ef8c5674614 *man/stack.Rd b4e5367a1a3e8e90cbd3a3d9f2c69a13 *man/stackApply.Rd cb01d82b0ff33c4c3b07f33fa4a9f401 *man/stackSelect.Rd f6bc30f3d45a49fe0c55456334a6733f *man/strech.Rd e91f4f702537f7fc416be44c72d74b2f *man/subs.Rd cef4b0ae0e8e758830cda58df31c69dd *man/subset.Rd 7cb3657af929fc13de7bf2c88294947b *man/summary.Rd 78ab5a46bf690afc0491e60a97078ed7 *man/symdif.Rd 4d0c2b3c7a2b923bb0474be5db186673 *man/terrain.Rd fd3e870528c1748d5efe2f034fc644de *man/text.Rd 5e0f4ae16d19004a1315e53c79d76f6c *man/transpose.Rd eeb31a2a9ae9cbabc1ca572b86a84162 *man/trim.Rd bf6de48aa917b7ca016966e60ed7cab6 *man/union.Rd a9d4404be696b9ea893759f30caa6036 *man/unique.Rd 3ca50b5aa6d04c407036b227814737ae *man/unstack.Rd c6fb7e85aefbea01c9ac78ea85273a2b *man/update.Rd 61b8d8151baf66597a478c8da372bce4 *man/validCell.Rd 403e7d3d2a3f90f5216467c3d22194dd *man/validNames.Rd 21d1b013abe7cb0ca54ee44b112c4662 *man/weighted.mean.Rd 6529a60b7fee2e04908544eefc87b6c1 *man/which.Rd 9d3336603f6cf63ca2cd845c7f89d6ad *man/which.minmax.Rd 164657c9c168e7cbe3fc4b256e9f01ca *man/writeFormats.Rd b1d370b11c1619fff39c530ed92dbd1f *man/writeRaster.Rd 65feb1b95f3fe775d7b74122b6774ec3 *man/writeValues.Rd b2d1db5758eab0d60e5852c79364b23a *man/xyFromCell.Rd c939d846d9caccdc1296ab0cbc572d4d *man/zApply.Rd 30caf8090f30f1e69b7c4fa040e5785d *man/zonal.Rd 2ed4cd3d565f0dc466b46590fd52fb6b *man/zoom.Rd 7f2a34ddf86c7e4cf7055cfb6f6fdf6b *man/zvalues.Rd fadffd1a59958998d5aa0a8ee4e44874 *src/RasterModule.cpp fe0e480c52c98688007d5ad4008b450e *src/RcppExports.cpp 169c17c28c95acb76ffb33ed01a06edf *src/aggregate.cpp ab6184e18df246510bfcb0f86b0d936d *src/aggregate.h 741e22173fba2f2928b30e204a59f0ef *src/bilinear.cpp e7912875e61e298a928371427a363db3 *src/broom.cpp 374a0ab9f7be016993bb20c602f0ab16 *src/cellRowCol.cpp 07e6e0b7e68782a3d28898e606c173b5 *src/clamp.cpp 08796267d48d3f61d95b58d0a908a997 *src/distance.cpp be72e268df1d536c022fb180556277d3 *src/distance.h b0188c0bd53304d33afaa134d49ec4cc *src/edge.cpp ba4c83076484833048d1a955a5f5f531 *src/focal_fun.cpp 0e8d74da363ce4d3694e47b1a241ea33 *src/focal_get.cpp 292b011b936b2d21a714a9cd186d427a *src/focal_sum.cpp de722fd0f8f6aa154e53ae6fbb02f10a *src/geodesic.c 931f9f1e049b10f6de797a8e96952251 *src/geodesic.h ddef60d0af91cb1fd0e994c69f2c7f82 *src/getPolygons.cpp 3ffac977e550f88ad3a26d3be3025d36 *src/layerize.cpp a396097fc9e7b8a76799bb13efd25a82 *src/memory.cpp 8c9da6e32cc8145423a65c80eab2500e *src/memory.h 171dea5b0c4d0db0b3d2e689096d1da0 *src/modal.cpp 15d16970a4635bac1e9bf7a09393ef0f *src/ppmin.cpp 59e92c441aa707a80ac91c8204cd5b67 *src/raster_aggregate.cpp 4f6e7b0b8879a7cbe8f667e455eeffad *src/raster_distance.cpp 8cd6ef602e2ae21aa33bcc11ea4f026c *src/rasterize.cpp 8eebd5a154b6809afa176a2295a20795 *src/reclass.cpp b9624288cf9e6e277eea0cd9ea83b2b0 *src/spat.h e4e6f9ef6da14024b9d3606f995b943f *src/terrain.cpp e8793d57c6405d2f688421d75ae5115d *src/util.cpp 02b3ab8677d52f791681845435a5252a *src/util.h 6eecc5a74b0d952ec5350934932ab19d *src/xyCell.cpp e29ac422b2cc0d924fa52c457521d409 *tests/tinytest.R raster/inst/0000755000176200001440000000000014173044240012526 5ustar liggesusersraster/inst/tinytest/0000755000176200001440000000000014160021141014400 5ustar liggesusersraster/inst/tinytest/tinytest.R0000644000176200001440000000013714160021141016407 0ustar liggesusers if ( requireNamespace("tinytest", quietly=TRUE) ) { tinytest::test_package("raster") } raster/inst/tinytest/test_sf-coercion.R0000644000176200001440000000324614160021141017776 0ustar liggesusers # This gives an error on CRAN for OSX # context("test-sf-coercion") # library(sf) # p1 <- structure(cbind(0, 0), class = c("XY", "POINT", "sfg")) # p2 <- structure(cbind(1, 1), class = c("XY", "POINT", "sfg")) # sf <- structure(data.frame(a = 1:2, geometry = structure(list(p1, p2), class = c("sfc_POINT", "sfc"), # bbox = structure(c(xmin = 0, ymin = 0, xmax = 1, ymax = 1), class = "bbox"), # crs = structure(list(epsg = NA_integer_, proj4string = NA_character_), class = "crs"), precision = 0)), # class = c("sf", "data.frame"), sf_column = "geometry", agr = factor(NA, c("constant", "aggregate", "identity"))) # raster_sf <- raster(sf) # test_that("raster from sf works", # { expect_that(raster_sf, is_a("RasterLayer")) } # ) # p1 <- rbind(c(-180, -20), c(-140, 55), c(10, 0), c(-140, -60), c(-180, -20)) # hole <- rbind(c(-150, -20), c(-100, -10), c(-110, 20), c(-150, -20)) # p1 <- list(p1, hole) # p2 <- rbind(c(-10, 0), c(140, 60), c(160, 0), c(140, -55), c(-10, 0)) # p3 <- rbind(c(-125, 0), c(0, 60), c(40, 5), c(15, -45), c(-125, 0)) # pols <- spPolygons(p1, p2, p3) # sf_pols <- st_as_sf(pols) # r <- raster(ncol = 90, nrow = 45, vals=1) # test_that("crop using sfc works", # { expect_equal(crop(r, pols), crop(r, sf_pols)) } # ) # test_that("mask using sfc works", # { expect_equal(mask(r, pols), mask(r, sf_pols)) } # ) # test_that("rasterize based on sfc works", # { expect_equal(rasterize(pols, r, fun = sum), rasterize(sf_pols, r, fun = sum)) } # ) # test_that("extract based on sfc works", # { expect_equal(extract(r, pols), extract(r, sf_pols)) } # ) raster/inst/tinytest/test_rasterize.R0000644000176200001440000000076614160021141017603 0ustar liggesusers p1 <- rbind(c(-180, -20), c(-140, 55), c(10, 0), c(-140, -60), c(-180, -20)) hole <- rbind(c(-150, -20), c(-100, -10), c(-110, 20), c(-150, -20)) p1 <- list(p1, hole) p2 <- rbind(c(-10, 0), c(140, 60), c(160, 0), c(140, -55), c(-10, 0)) p3 <- rbind(c(-125, 0), c(0, 60), c(40, 5), c(15, -45), c(-125, 0)) pols <- spPolygons(p1, p2, p3) r <- raster(ncol = 90, nrow = 45) x <- rasterize(pols, r, fun = sum) # rasterize works as before expect_equal(sum(values(x), na.rm=TRUE), 3481) raster/inst/tinytest/test_getvaluesblock.R0000644000176200001440000000052314160021141020574 0ustar liggesusers #test_that('we can extract from a single layer of a RasterStack using the lyrs argument', { rast <- raster(matrix(1:16, nrow=4), xmn=0, xmx=4, ymn=0, ymx=4) stk <- stack(list(a=rast, b=sqrt(rast))) expect_equivalent( getValuesBlock(stk[[1]], 1, 3, 3, 2, format='m'), getValuesBlock(stk, 1, 3, 3, 2, lyrs=1), ) raster/inst/tinytest/test_subset.R0000644000176200001440000000117514160021141017073 0ustar liggesusersr <- raster::brick(nrows = 100, ncols = 100, nl = 2) r_z <- setZ(r, as.Date(c("2018-01-01", "2018-01-02"))) s <- stack(r) s_z <- setZ(s, as.Date(c("2018-01-01", "2018-01-02"))) #test_that("subset keeps the z attribute if present",{ # on brick expect_equal(r_z[[1]]@z$time, as.Date("2018-01-01")) expect_equal(s_z[[2]]@z$time, as.Date("2018-01-02")) # on stack expect_equal(s_z[[c(1,2)]]@z$time, as.Date(c("2018-01-01", "2018-01-02"))) expect_equal(s_z[[c(1,2)]]@z$time, as.Date(c("2018-01-01", "2018-01-02"))) # NULL if no z set expect_equal(r[[1]]@z$time, NULL) expect_equal(s[[1]]@z$time, NULL) raster/inst/external/0000755000176200001440000000000014160021141014337 5ustar liggesusersraster/inst/external/lux.shx0000644000176200001440000000030414160021141015670 0ustar liggesusers' b@ QH@Kŭ@ڿ_?I@2 p  "VH' x3; 8AF `J hT b r Xraster/inst/external/countries.rds0000644000176200001440000002133414160021141017067 0ustar liggesusers}sX)bnwɺ'%&$D\h, -MjW.?>*yJURT!ߕ;$AIvTe}|y>z7[[*o?bGѣG;ޓFxCpDΥޣG(>ӐS)-{G>w$ǻ y<[G0թ7 ʣMh3 . Nϓv§OG|Tt3xU9xyb ?ѩl7K$6;Ǘ .:<ЋE0J@ࣟ `?b4k$U8 5‘D<M$&t<H3G"|ϔ7F8}O$m~yW(KIş]?0Y F Ǽtb:%i`Z8SZr%wucQ&Ԫ)(x׾4{7;>Xn$VQH+@2 5Kv³v4N4V6d\a5ÿ?O@ysu#) Hz7 nu|/J4Y0ϸz''_H]'3JՙILR'LjK`Egl7#|,f״qC2\Aлe~$9>zwpG7Suq&;@V7V[Tӽ mݧ@Hq89ЃT\Q. zdh&h<1w`r9ME&| (X`v㟧4z g,IѻayEO"H7 2SStk/=V+c;Mx d$<q@A) 'feN.I565^b1 )؆>%Ze]A-=]:.;ǩ֣ O=aAGD #7d6{= S(]=Q8a{כEDhTx!N۷(`+`W)8գ< FE)\2bʌQ;Aon0ġt>~:<brb"q5:^,> %7'g\%!2=$9RJ ^bXq#0$'S3#>GbxDDB ɔc (d+Ga^r)[Y|2c<Q"{i59SvnUkdÛN;%7zޡ&K(ޣ8n@HR?{·`16s8솭S] c'7R{OUDr+ķ[n憔T]RD$.a{1Znx꥖Х ľ艔;K1BBB; /fj=?N G? ^?g]0 ?u&b*($kJli<3DӔ<3Lx# R"!9PIhg@*d(y6>t#|d 䈼6w顚R= _tL_? Nl7r4M27Iy£uSM&۩&o8BpEDMM6iU54h;FSvlˠCঊ#*hwx_ 7unfmPmL2B>&t\`1pD-A 2jM`oˌfO-̡ {{C ˺2ԿX`@mc.c> zOh8]XM ]hxa;<nb&o$[t2r:8-7.# 7ٿuc,s{\\v].ĵx3'v^ x]fۇYX&o@&/cY-,ŶH UXec=!g h%4O0DBKC Zml 墅s8A 4hŻ8xZHm.e=W@e:V;!+H+(*yvAYqؖBPG >`Luȯ+a9 *Xb-xVq  Uq*u}}d#J*}@?,! :|+NpѣZljKN²bnIͦ9? ۲ޠ2w۪٠"#O2PM6vz}MGW6]V\ 3}Y4dGƽ#m>5(Pl<︶| Y;Dݐ;pWtm>r&uܴx˜\n[ԨWm|jf),]5,SlhRװ"l'j0 ud7@u |GW [s5#ifS#[JM53ij ordiA2gѷԒaioH\Wda5DUBW#ɔA]E@jZ=QcC6sR!Q#V,7tYt4$>U:6IUB/K釮JaXe4X˰lHܾbYܒ]ϕ%5b| , l[-ذl+}[VՔKDU:yb"-?b fIVK|TMCF٩$v[v4o[MJ";H(ޒmK1fz̴lTTUhL0>,T4C$5gM-7X)rZڪEڤ XavEJ_k۪ wD/6 ՏLzSխ>³-18e\'d {.2\1[DwU~,4ɎyWXf?P-u-D۝If*k[SՙiLRJ{|0;*GB;h*Ȁci-tɏTeUZ;&>'rvULj Z$# &.[ROz)>첧Ur\:ہ/еF*}I$rUqUx]s;TtߪQj࿥!s-[:-蠀[v!.z, P-k ~t:m?Sx<'sr'8N1cuUP!kT;6UbJqØ>7,i h"ji6SpTK}bFr5qȊ(-|&#Xn{e$c#W5 >:jU=SF3MǦz$)sI'RlSh@yӲ[͆Z۵ &iV^^7DDRVjƣޓZZω(M$H">Tx-2*2 O{rvAYJ'hz*ףIh,qOs%cr{x͌쑻p-$RR}#Ⓞ9756, xLsi5 4) *Bx11xnC>Lh ""rf*v)Vڮ#ƒj eIegE&DMmfeN;B}.KF!u dIW-Tv}e)ӐoCNRSW|XF* ܟJ~>vc!P.%54~3WE{7_gZuz"*ĎckM|VM/;dI| D.nkǠr"JHG{b;b3燿weH*=ۚ:wXDӴ 3sOYICpf{ \'eQU釁p3$Ǜ&zB6TW(˼t悮/}e2˹W%]87&d"Ņ=s_z;uws+9qs񹸹x0cU|%3d̑nw՚/r{Q|AvI:c.MҗZWt+iȋ?%Ü^6gN㠲w s,uBD$u)/\&d =}y¿ۋR;dA0 )J 3?+Ux7^-[gA.qGQm9[@zV)_x޸KD#җ_d?/3Q@;AziS"呝wu=%U>r-+UbVuϖKvN.K6i/R_ .Pm*! -Nޛ:W=N^RZyF|,9y*;OV|:R5W\t/z*3-#'LKbQ\I((%5(>QE. H H&7+A~) LUo(A4~;gJH|z{J ՚V'gn4Y0N><JLtnRE 1ČqjIV"v(&}2WF&dm2]XWP($р ?1VN!ɫ(r/E,s堹鍟ߺǮOk7 ?zSyM"&o^Uo#kUA~LB&*El\I&mի:y~t>E ?/+=MJFW!$h?kHe%+WK]$$(,2rSpJGý]{7+GMGO{2l'HKH{Ƽĸ/!Œ%"'LQhf%oa=jDKM֔DxGDeJUG|CPgvLQoieLg(~x_sMpBUS.IU77+JNԛ64G{Vcy)Jmĸ{9knz~t/ z4s&ه*〥Di}q*>y:8I‘gM Q424@jem(jjy~U+s_fu_慫\ ȾH~aa ^\W4# eK\=WTi_}/cRٛgUUΰHUo gDW]Tn8RJ~V"xĻ$?7%J^SxK#̏~/%}5/Lū{AW\!*+";P*>~ϰ/Lѿ/%uP%_]j@&% Iμ^]_(﯑5=. (L'Vq*+bϮ֎@LhXkB˽kg{b6-eB/zATQ/Ǻ 7O4N{ L4Wd6z?={K~}2-1B{ ook$ <^lγ~If'~( ØQɝ_iZbLt}>Y1,d~VF;/@R{M*',Z WH3crO_م`Rue;fe!lVkuX]w.k[hB/w9"KgEgol"KDj0ѸbY($۷ŵk\BB05enEb#Z1BRB6%|,&t*-gLxI2-B+μ=D)ڗB >ed-_o"R acVbڭR [b֖,1bSwc_$ِE~.Fx"K}.I0%"!"^څ 7WGbQH3 Ey.$⎅( 0,\]8FFî%ڵzt@r|]W>hO2+c.pbQ.^&y^btKfE\rwZbz7`vXЦaE_/theZE)gŞ|_B,lhכ/2e[v-U{vn,-o+4V±j2"ܕx:eͩm&vl/j%5[;ҕ*O>/'3k[;w}Y++r_(sWJaiWqnaDA7cF erc|^y薞[ޑl6P;pm+p-/w9Pxڬi$+^ÓMB`nwU fR]Rћy0W]lvb ecXk WwV?eO ?)Vo!.Pڈ8WQxzڬůpp {s`kbR2X5->4rK!P)#Q:~$uʯfiSb7nn[Ij7gCtvs[| sC;C:C4C4C3C3C2C2C2C1C)C)C*C*C.C2C5C7CECSChCyCC~C{CuCCCvCtCzCCC}CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCCCCC~C}C}C~CC~CCCCyCpCfC\CVCJCMCJCHCDC@C=CC=C:C8C8C8C7C7C6C5C5C5C7C5C1C.C,C,C-C-C6C.C$C!C0CKCkC~CtCCCCC{C}CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCCCCCCCC~CCCCCCzCwCpCjCaCXCNCICFCDCBCCCCCCC@C?CCCCC;C>C>C>CC9C6C5C5C6C-C)C"CCCCC#CCCC9C`C{C~CxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCvCjC]CRCJCECJCJCICICICHCHCGCICKCNCPCQCQCPCOCKCKCJCICGCGCGCFCFCCC>C9C6C5C5C6C-C)C"CCCCC"C CCC9C`C|CCyCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC}C|C{C}C}C{C{CyCwCtCiC]CPCGC?C:C?C?C>C>C>C=C=C?CACACDCFCGCGCFCECACAC@C?C?C?C?CC@C@CDCECDCCCBCDCCCBC@C@C?C?C?C:C3C+C&C#C!CCCCCCCC(CMCpCCCCCCC~CCCCCCCC~C|CCCCCCCCCCCCC~C|C|C}CC~C}C~C}C{CyCsCuCyCwCwCuCiCTCGCICEC=C;CCC@C;CC:C9C;C=CACDCECBC?C?C>C=C;C;C:C:C:C5C.C&C!CCCCCCCCCC CECjCyCyCyCwCxCtCvCyC{C}C}CCCC~C|CCCCCCCCCCCCCC}C~C}CCCCCCzC~CCCCyCgC\CRCKCICNCNCICICOC_C_CcChCaCNC;C4C0C.C,C)C(C(C*C,C.C/C0C0C0C/C.C-C,C-C/C3C7C;C>C@C>C=C=C;C7C0C(C!C CCCCCCCCCCjC~CvCtC}C}CzCCCCC|CzC|C~CCCCC~C~CCCCCCCC}C~C}C}C}C}C~C~CyC~CCCCyCgC\CSCLCJCOCOCJCJCOC_C_CcChCaCNC;C1C-C+C)C&C%C%C'C)C+C,C-C,C,C+C*C)C)C*C,C0C4C8C;C=C;C:C:C8C4C+C#CCCCCCCCCCDCkCCwCvCCC{CCCCC|CzC|C~CCCCC~C~CCCCCCCC}C~C}CC~C~C|CzCtCvCwCwCwCoC]CPCEC>C:CACACCuCCCyCyCCCC~C|C}CCC~CCCC~C~CCCCCCCC~C~C~C~C~C}CzCwCzCwCwCuCkC[CLCFC@CFCHCHCDCICWCfCOC?C,CCC C CCCC CCCCCCCCC CCCCCCBBCCC C CCCC%C'C%C$C&CCCC C C C CCCC8CoCwCwCsCsC{C}C}C~C|C{C}CC~CCCC~C~CCCCCCCC~C~C}C~CCCCCCCtCeCXCQCPCSCZCTCTCaCsCmCFCCCC C C CCCC(C*C+C.C,C&CCC CCCBBBBBBBBBBBBBBBBBCCC(C)C,C(C CCCCCCC CCBCqCCC|C~C~C~CCCC~CCCCC~C}CCCCCCCC~C~C}C|C}C~C~C|C~CCtCeCXCQCPCSCZCUCUCbCtCnCGCCCC C C CCCC*C,C/C0C/C(C!CCC CCBBBBBBBBBBBBBBBBBCC C*C)C+C'CCCCCCCC CCCCpCCC}C~C~C~CCCC~CCCCC~C}CCCCCCCC~C~C}C}C~C|CzCyCyCwClC]CNCGCDCGCNCGCECTCfC`C9CCC CCBCC CCCCC"CCCC CBBBBBBBBBBBBBBBBBBBBBCCC!C&C#CCCCCCBCCC>ClC{C{CxC|C|C~CC}C}C~CCCCC~C}CCCC~CCCC~CC{C|C~CCCCuCnCcCWCRCQCTCWCWCjCqCXC/CCCCBC CC#C/C4C5C0C,C#CCCCBBBBBBpB`BLBPBC9C1CC CBBBBlBHB BBAAAAAAAAAAAAAAAB B BB(BDBXBpBBBB CC&C*CCCCC CBC:CvCCC~C|CCC|CCCCCCC}C~C~CCCCC~C}C~CCCC}CyCaCYCQCQCYCdCjClCrCNCCBBBBCCC(C3C;C>C9C2CCCBBBBxB`B$BBBAAAAAAAAAAAAAB BBB,BCMCSCSCTCSCSCSCSCSCKC7CCBBB`B4B8B,B0BDB4B BCCBBxB BA`A?@@@@ABAALBBBC'C;CLCTCTCWCVCVCVCVCVCNC:CCCBBdB0B0BBB(BBBBPBpBBBBC CCBBBBFCvC{C{CzCwCC~CCCC~C~CCC~C~C~CuC~CxC[CYC[CWCZC|CiCCCCBBBBCC?CXChChCLC+CBB`BBAA@?AA AA$BBCCCmCtC~CCCC~CCCCCCCCCCCCCCC{CgCZC CBB0BHBdBDBB8BlBBBBCCCBCBCVCCwCCC~C}CCC|C~C~CCC~C~C~CvCCyCZCXCZCVCZC|CiCCCCBBBBCC?CWCgCgCKC*CBBPBBApA@A@@ABtBB>ChCrC|C|C~C~C}C}C}C}C}C}C}C}C}C}C}C}C}C}C}CwCfCYC CBB8BTBhBHB B8B`BBBB CCCBCBCWCCxCCC~C}CCC|C~C~CCC~C~C|CqCyCsCUCSCUCQCRCtCaC;CCBBBBBC7CRCbCbCFC%CBBDBAAPA@A@@A(BBCECoCwCCCC|CyC|C|C~C~C~C~C~C~C~C~C~C~C~C~CvCdCWCCBtB$B8BPB0BBBDBBBBBCCBBBBRC{CsC}C}C|C}CCC|CCCC}C~CCCC|CcCTCXCWC]CvCqC;CBBBBB C8CWCoCsCcCAC CBBB A??AADBB>C|CCC|C~CC~CC~C}C}C~C~CCC~CC~CC~CvCwC{CCCCCzCC{C{CQCCBB`BBlB`BBBBBCCBBBCJCuCCCxC{CC}C|CCCC}C~CCC~C{CcCTCXCWC]CvCqC;CBBBBBC9CVCnCpC`C@C CBB BAAADBB=C{C}C}CzC|C}C~C}C}C|C|C}C}C}C}C}C~C}C~C}CuCvCzCCC~CCzCCCCUCCBBdBBlB`BxBBBBCCBBB CICtCCCyC{CC}C|CCCC}C~CC}CzCvC[CLCPCOCUCnCiC3CBBBBBC3CQCiCkC[CCBBB@AxB3C|C}C~CC~C~CzCxCuC{C{ChCuCxCxC{C|C}C}C}CvCvCuCvCuCvCuCuCwCxCzC}C}C}C{CzCoCrCtCtCzC~C}CzCqC~CCTC CBBBBBBCBBB CkCCCyCzCCCC~CCCyClCOCQCFCPCmCZCCBBBBB(CRCqCzCnC:CBBB A|B6CCC~CC}CC}CCCCC{CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC{CCCVC CB|BBBBBBBBBCfC{C{CwCxC}CCC~C~C~CnC^C]CRCVCqCgCCBBBBC+C^CCCmC5CB\BA@AACtCCwC~C~CgCwCkCrCdC8C8CFC4C:C:C9C7C4C2C0C0C:C;C:C;C:C;C:C;C=C;C6C2C/C1C3C5C=C3C*C0C7CCCOCYCyC{C}C|CnCBCBBBBBCBBBB&CpCCvC~CCCC~C~C~CoC]C]CRCVCqCgCCBBBBC+C^CCClC4CBXBA@`AACrC}CwC~C~CkCCuC~CoCDCACPCC;C:C:C8CCCBCCCBCCCBCCCBCFCBC?C9C8C9C;C=CEC;C3C6C>CICUC^C|C}C}C}CnCBCBBBBBCBBBB'CqCCvC~CCCC~C~C|CjCYCUCHCJCeC[C CBBBBB#CVCwCwCgC/CBHBA@pAACuC~CwC~C~ClCCCCC^C`CsCcCkCkCjChCeCaC^C_CjClClClClClClClCoClChCcC_C`CbCdCjC_CTCVC[CcCmCrCCCCCpCDCBBBBBBBBBB!ClC{CtC|C}CCC}C}CzCgCPCXCLCsCzC#CBBBBC3CYC}CCkC9CBtBA@@??ABkCwCCC~C~C|C{CtC0C9CZC@C)C3C,C/C/C/C-C,C,C/C4C.C.C.C.C.C.C-C.C*C,C0C1C1C1C1C3C)C'C+C.C(CCC)CC9CZCuC{C{C]C;CBBBB CBBBBTCCyCCCCC}C~C{ChCOCXCLCsCzC#CBBBBC3CYC}CCjC8CBpBA@?ABiCuC}CC~C~C~CC{C;CEChCMC5C?C8C:C:C9C7C7C7C;C=C9C9C9C9C9C9C8C9C5C7C;CCBBBBCBBBBPC{CwC}C}C{C}C~C}CcCRCRCMCpCwC*CBBBBB/C]CwCCuC6CB`BA@A'CCCCCCCC~C{CwCCC7C_CQC+C;C:C>C=C:C:C=CC1C5C1C&C"C#C CCCC C6CpCwCrC{C\CBBBCBBBBB}C|CCC{C~CC~CdCTCRCMCpCwC*CBBBBB/C]CwCCtC5CB\BA@A'CCCCCCCCCC~CC$CACiC^C8CJCICKCJCDCDCHCGCBCGCFCDCCCGCKCGC@CGCJCJCFCDCFCHCICCOCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCzChCYCRCLCICFC0C1ClCC~CuCpCCBBBCBBB1CzCuCxCCC|CgCQCKCRCkC`CCBBBBCEClCCyCTCCBA?AA\C}CCCCCCCCC~C{CoCC CBCCBBBBBBBBBBBBBBBBBCBBBBBBBBBBBCCC,CC?CLC`C/CBBBBC#CRCjCrCVC!CBA@@ BVCvC}CmCCCCCCCC~CCCECJC>CSCECCB CCCCCCC$C(C.C5C:C8C6C7CC;C8C8C4C-C'C'C)CCCCCC+CC-CC C,CCyC}CuCyCCBBBBBBKC{C}CCCiCPCFCOC\C\C CBBBBCRChCvCjC=CBLBA??AUCCwCCCCCCCCCC~C{CpC CCBC CBBBBBBBC0CCC`CSCICHCECAC@C@C;CCBBBBC)CfClCqCVCCBA?1CCoCCCrCCCCCCCC~C{CwCC CCC CBBCCCC2CXCjClC>C#CCBBBBBBBB CCC#C1C+C&CC CCBBBBB C CBBBByCwCCCsCwCCCCBBBkCCCyC^CICHCTC]C>CBBBBC)CfClCqCVCCBA1CCoCCCrCCCCCCCCCC}CCCC)CCBCCCCC:C`CtCsCEC*CCCCCCCCCCCCC*C8C4C1C'CCC CCBBCCCBBBBzCwC~CCtCxCCC CBBBlCC{CsCXC>C;CFCSC4CBBBBBCZC`CgCLCCBA1CCoCCCrCCCCCCCCCCCCECTCdC_C^CSCEC:C6C1C/C1C4CKCBCCBBBCyC|C}CoCrCB CCBBBgC}CCpCRCACECRCYCCBBBBCHCdCiCeC9CB0B@ AB{C~CC|CxCCwCCCCCCC~C{CqC CCCC CBBBCC&CLCcCICCBLBAAAAAABAABCCCqCSCCCGCTCYCCBBBBCHCdCiCeC9CB,B@AB{C~CC|CxCCwCCCCCCCCCwCCCC%CCBB CC C1CUClCSC CBdB BABB BB0B B B(BTBBBC#C3C5C&CC CCCCBC#CBBBB(CCtCCClCoCBCCBB?CC{CkCMC8C:CFCOCCBBBBCCFCRCTCBBBBC,CcCWCcCXCCBA0AAkCtCCCyCyCCCCCCCCCCC}CCC CCCBC CC+CAC`C^CCCUCKC&C,C4CHC[CrCCC+CBBAAAAAAAAAA$B0B@BBB C6CSCQCHCJCHC=CECLCECECCSC;CBBBBCECXCaC[C[CBTBA@CCCCCCCCCCCCCCC~C{CwCCCCCCBBCC C7C@C/CBA?@A AA@A@PAAAA B8BBBCCC C CCC CCCBBBB^C~CCC|CzCfCCCCBB~CCYCCCCHCPCRCSCKCMCFCCBBBcCCC}CzCvCaCCCBBBzCCUC?C8C;CLC1CBBBBCICWC]CZC0CBHB@ABVCCCCCCCCCCCCCCC~C{CwCCCCCCBBCCC-C5C$CBA@ABBBBBBBBBBXB BHBhB4BBBCCCC C CCCCCBBBB?CzC~CCCCsC-CCCBBCCVC@C:C=CNC1CBBBBCICWC]CZC0CBDB0ABTC~CCC~C~CCCCCCCCCCCC~CC CCCCBCC C'C6C?C-CBBPAABBBBBBBBBBtB0B`BBXBBBCCCCCCCCCCBBBB>CyC~CCCCtC.CCCBBC{CPC8C/C0CAC'CBBBBC?CMCSCPC(CB4BABUCCCCCCCCCCCCCCCCCC:C8CGCUCRC#C-C:CQC\CoCtCXCBhBAABBBBBBBBBBBTBBBBBC;C@C;CDCMCPCVCOCQCJCCBBBFC~CCC}C{CoC(CCCBB{CCOC9C6C:CFC%CBBBB%CNCUCVC_CCB$B@AB~CCC~CCCCCCCCCCCC~C{CwCCC CCCBBCCC%C)CCBB$BlBlCtCsCzCpC{CzCzCuCyCzCiCCLB|BBBBCBBC CCCCCBB`B`BCxC~C|CCC~CJC$CCBBCCPC:C8CCHCPC]CVCTCQC"CBBB"C}CC|C}C{CzCECC CBB{CCJC4C4C9CBCCBBBC+CPCRCPCUC CBA@@BC}CCCCCCCCCCCCCCC~C{CwCCCCCCBBCCC%C%CCB BBLB{C{CyC{CxC|CyC|CzCsCpC{CzChCBBBB CBBC CCCCCBB(BXBB|C~CxCC{CCjC0CCBBCCKC5C6C;CDCCBBBC+CPCRCPCUC CBA@BC}CCCCCCCCCCCCCCCCC~CC CCCCBCC#C'C.C/CCBDBC&CBBBC)CKCJCFCGCCB BAAWC~CCCCCCCCC~CCCCCC~C{CwCCCCCCBBBCC%C%CCB B@BB}C~C~C}C~CuC~C}C~CCC~C|CwCdCCC C(CBBBCCC+C-CC|BB8BBzC}C~CzCC~CC=C CCB~CCKC-C%C+C@C&CBBBC(CKCJCECFCCBBAAUC~CCCCCCCCC~CCCCCCCC~CC CCCCBC C C'C0C/CCB4BLBB|C}C~C}C~CuCC~CCCCCC{CjCCCC5C CBCC C)C2C5CCBBC!C CB~C{CEC'CCC3CCBBBC#CCCBC@CACBBBAAVC~CCCCCCCCC~CCCCCCCCC:C6CECTCQC!C-C5CNC[CfC`CECBBBBCCC}C|CsCzCyCzC}CCCCCC:CGC@CaC:C&C;CHC]CdChCdC-CBBBCCCCzC}C|C{C8CCCB|CCLC+CC"C;C'CBBB C+CKCICDCACBBAB\B[C|CCCCCCCCCCCCCCC~C{CwCCCCCCBBCCC%C%CCB$BBB{C}CyC~CyCC~C~C~CCxC~C|CwCdCC"CC1CBBB CC$C/C.CB`BB4BCxCyC~CxCCzC~CAC!C CBCCMC,CC$C=C'CBBB C+CKCICCC@CBBABTBYC|CCCCCCCCCCCCCCCCC~CC CCCCBCC$C(C0C/CCB4BBByCzCwC~CyCC~C~CCCzCCC{CjCC+C#C>C CBCC%C/C9C6CCtB B8BCwCxC~CxCC{CCBC"C CBC{CGC$CCC0CCBBBC#CCCAC>C;CBBABXBZC|CCCCCCCCCCCCCCCCCC:C4CECSCOC!C-CCVCMChC9C!C8CMC`CgClCdC&CBhBB CC}C~CxC}CvCyCC>CCBPB0B4B0CCC|CC}C|CCyCCCCC~C~C~C}C{CwCCCCCCBBCC&CC#CCBB,BB|CC~C~CxC{CyC{CzC{CxCvCwCyC:C1C(C@CCBBB C$C3CIC*CBBAB3C~CyCC~C~CCC8CCB>CC|CmC)CCC C-CCBBC(CBCEC=C=CCBLB,B0B/CCC|CC}C|CCyCCCCC~C~C~CCC~CC CCCCBCCC3C(C,C!CB4B8BB{C~C}CC|CC}CCCC}CzC{C|C?C9C1CIC!CBBCC2C@CUC4CB BAB2C}CyCCCCCC:CCB?CCtCeCC C CC!C CBBBC8C;C8C8C CBCDC8C=CCBBHB4BCCCzCC~CzCCC|CCCCC~C~C~C{CwCCCCCCBBC C"CC$CCB$B8BBkC{C{CzCsCxC{CyCwCyCwCyCmCbCPCCDC7CCBAAABtC~C~C~C~C}C}CUC:CCCtCCCzCMCC CCC'CCBBC2C?C6C7C'CBB\B\BBhC~CvCCCCCCyCCCCC~C~CCC~CC CCCCBCCC*C%C,CCBBBB_CqCxC|CzC|C~CzCjCaCdCgC`CXCIC[CmC;CBBCC=C`CnCDCBBAABsC~C~C~CC~CCWCC_C~CCdCChB B,BByCC~C|CyCvCtCLC1C CCpC}C~CyCjCC C CC"CCCCC&C:CC)CB?CrC}C~CyC{C-C CBCC CCC CC5CAC5C5CCBBBpBBvCCC}C~CvC|CCCCCCCC~C{CwCCCCCCBBBCC CCC CCCC"C+C,C*C+C(C7C;C8C1C8CQClCtCjC?CBBBC ChCuCrC0CBA@`A\BfCC~CCvCzC~CgC=CCBtCCCCzC|C.C CBCC CCC CC5C@C4C4CCBBBlBBuCCC}C~CvC|CCCCCCCCCC~CC CCCCBCCCCCCCCC#CC,C3C5C3C5C0C?CCC@C9CACZCsCxCnCDCCBBC+CpC|CyC5CBA0AA\BgCC~CCvC{CChC?CCBuCCCyCtCtC&CCBB CCCCCC-C;C/C/CCBBB\BBqC{C{C{C|CtCzCCCCCCCCCCC:C4CECSCOCC+C7CKCRCNCNCFC@CDCNCNC]CbC`C\CYCTCcCgCdC]CbCyCCCCdC'C CC.CACCCCHCB(BAA|BkCC~CCtCvCyC`C4CCBpC{C}C~C}C~C\CCBCCCCCCC-C=C;C0C$C CBBBB/C{CCxCCyC}CCCCCCCC~C{CwCCCCCCBBB CC CCC CCCC#C;C@C;C>C:CBCNCYCdCmCkCSC8CBBBBCPCnCqCjC2CB ABC~C}CCzC}C}CtCOC"CB'C~CC|CC~CC]CCBCCCCCCC-CCBBBBCXCwCxCoC7CBPA?BC~C}CCzC~C~CuCPC#CB(CCC|CyCxCyCUC CBBB CCCCC%C7C5C*CCCBBBB*CwC{CtC{CuCyC}C}C}C}CCCCCCC:C4CECSCPCC+C4CLCOCKCGC:C;CCCKCWC_CoCoCfCgC`ChCwCCCCC{C`C CCCC8CkCCCCJCBAPAA(BCCCCxCyCxCoCHCCB"CzC}CzC~CC}C~CCCBB CCCCC%C7C?C+C,C#CBBBBBbCCyCCCCCCCCCCC~C{CwCCCCCCBBB CCCCBBB C C0CZCgCfClCiCkCaCGC"C CCBBBBC:CgCjCvCUC CBAPA@B|C{C|CCoCCC^C6CCCwCyCC|CCC~CCCCBB CCCCC$C6C>C*C+C"CBBBBBcCCzCCCCCCCCCCCCC~CC CCCCBC CCCCCCBCC.CAChCvCtCzCwCyCoCUC0CC CBBBB CACoCqC~C[CCBA?PA@B|C{C|CCoCCC_C7CCCxCyCC|CzCzCyCyCCCBBCCCC CC1C9C%C&CCBBBBB^C{CuC{C{C{C}C}C}C}CCCCCCC:C4CECSCOCC+C2CLCPCOCGC/C(C*C@C]CoCCCCCCCCrCMC5C,CCCCC*C]CCCCiC CB$B`AAAB|C{C|CCmC{CzCYC/CCCsCwC}CzCCxCyCCWC CBBBC$CCC(C$C7C2C0C)C CBBBB ChC~C}C~CCxC|CCCC}C|C}C{CxCCCCCCBBBC C C CCCBBBBBBBBBBBBBBBBBBCHCpCjCGCCBPB@@@@?xBaC~CCC}C~CClCCBBBB C)CCC0C4C2C2C.CCBBBBBCxC}C~CxCCCCCCCC|CwCwCCCCCCBBC CCCCCC$CCCC C CCBBBBBBBBBB C:ClCPCCBBA?4BOC~CzC|CCCCiCOC*CB!CeCC|CCCC~CxCC~C?CBBBB C(CCC/C3C3C3C.CCBBBBBCyC~CCyCCCCCCCC~C{C~C C CCCCBCCCCCC C'C,C$C CCCCCCBBBBBBBBCCDCuCXC CBBA?0BOCC{C}CCCCjCPC+CC"CfCC|CCC}C|CvC}CyC:CBBBBC$CC C*C.C+C+C&CCBBBBBCtCyCzCtC}C}C}C}C}C}CC}C|CC;C3CECSCOCC+C9CFCRCWCRCICKCPCHCJCICECCC=C1C*C*C(C C C'C)C+C6CBCgCCoCCBPBB`APA0A ADBMCzCvCxC}C}C}CeCKC%CBCaC{C|CCCyCCCxCCrCCBBBBCCC'C/C2C3C1C)CCCBBBBCmC}CCuCyCCCC~CzC|C{CwCCCCCCBBBCC!C/CCC]CnCqC`CLC?C:C;C;C;CCC CCCBCC4CTCUCB0B@A0AABrC~CuC~C~CCzCrC^C/CCB]CCC|CCCyCCCxCCrCCBBBBCCC&C.C2C3C1C)CCBBBBBCnC~CCvCzCCCC~CzC~CC~CCCCCCBC CC!C*C7CLCdCvCxChCUCGCECFCFCFC+C&CC CC C CC>C`C`CCHBpA?@@PAABqC~CvCCCC{CqC]C0CCB^CCC|CCCyCCCvC}CpCCBBBBCCC!C)C*C+C)C!CCBBBBBChCxCzCqCuC}C}C}C|CzC}CCC:C5CECSCOCC+C4CDCUCaChCmC~CCCC~CuCrCsCsCtC[CVCLCCCJCGCGCRCqCCC!CBBApAA@ABBvC|CpCyCyC{CvCmCYC+CCBYC{C{C|CCCtCCCuC}CCcCCBBBB C(CC&C1C5C0C.C*CCBBBBBCtCCC~CCC~C~C~C~C{CwCCCCCCBBBCC)CICjCsCtC=C&C CBC CC C3C7C.C"CCCC#C,C@C(CBBAA BCrCeC~C~C~CyCCiCRCDCCB>CyCCC{CCCtCCCuC}CCaCCBBBB C'CC%C1C5C0C.C'CCBBBBBCuCCCCCC~C~C~CCC~CC CCCCBC CC#C3CQCsC{C{CDC,CCC CC"C)C?CBC:C.C%CCC/C8CMC5CB,BA?? A BCqCeC~CCCzCCjCQCCC CB>CyCCC{CCCtCCCuC}C}CbCCBBBBC"CC C)C-C(C$CCCBBBBBCoCzC{CzC}C}C|C|C~CCCC8C4CECSCOCC+C2CECUChCCCCCVCDC/C'C-C8CFCPCiCoCjCbC]CTCWCiClCyCXCBB$BAPAACWCmC%CCCCCBB CC,C.C.C#CBC3C5CHCRCPC.CCCCCBBC\CxC}CyCzCC~CxCCCCCCCCCCCCCC}CCC{CyC}CC~CTCBtBBB\BBBBBBBCC#C%C)CCCCCCCCCC CBCCBBBCC#C$CC|B$BBdBxC~C}CtC}C}CrC{CGCBBBB CB CCBBBBCCBBBBB.CkC~CCxC}CC{C~CCCCCCCCCCCCCCC}CCC{CyC}CC~CTCBtBBB\BBBBBBB CC%C'C+C CCCCCCCCCCC CCBC CC,C.C.C$CB@BBdByCCCvCCCtCCNCBBBBC CCC CBB CCCBBBBB3CoCCCxC}CC{C~CCCCCCCCCCCCCCC}C}C}C{CwC{C}C~CTCBlBBBTBBBBBBBBCCC CC CC CCCC C6C=C;CVCNC!C+C8CKC`CdCaCMCBBDBB}CC|CsCzCzCsCCXCCCBCAC3CBCGC:C%C%C:CKCC;C?CC5C>C:CLC1CLC.CBBBBCCB CCCBBCCBBBB;CwC~C~CzCxCC~C~CsCCCCCCCCCCCCCCCC~CCCCC{CCwCzCcCCB|B\B\B\BhBBBBBBBCC(C,C)C%C%CC!C C C(CCB C CC,C/C.C$CB@BHBtBACCC@C8CAC?CQC5CQC4CBBBBCC CCCC C CC$CBBBBACzCC~CxCxCCCCsCCCCCCCCCCCCCCC}C|C}C}C}C}CyC}CuCxCaC CBtBTBHBDBHB`B|BBBBBBC C$C!C C(C*CC^CJC&C5C8CKC`CeCaCLCBBpBBDCBC;C1C8C8CKC6CWC@C CCCCDC8C6CECMCFC@C=CLCQC!CCBBMCCC~CyCxCCCCsCCCCCCCCCCCCCCCCC~CuCxCCCxCC}C}CCRCCBBdB8BPBdBXBdBBBBBBBCC"CC!C CCCCBBBCC$C$CCxB$B$BtB1C3C4C5CBC@CC=C=CCC;CJCFC9CDCCBBBBCCCCCCBC CCBBBB?C{C~C~C~C~CC~CzCCCCCCCCCCCCCCCzCzCCC}C{CC}CCC{C|CCxCUCBBdBdBhBCMCHC=CHC%CBBBBCCCCCC CCC&CBBBBCC{C}C~C~C~CC~CyCCCCCCCCCCCCCCCzCzCCC}C{CC}CCC{C|CCxCSCBBLBLBPB$BBC9CMCNCRCGCCCIC9CCBBCC{CC}CCCqC}C}C{C}CCCCCCCCCCC~CCCCCCCCCCCCC~CCCCCCnCHCCBhB\B4BBB4B4BBABCCCC CBBBCC)C(CCB,BBXBBBBBBBBdBhBTBA,BBBBBCCCCC CC CC CBBBB-C}CtC~C~C}CC{CCCCCCCCCCCCCC~CCCCCCCCCCCCC~CCCCCCnCICCBhB`B4BBB4B4B BA4B&CCCCCBC C!C)C2C2C CBPB8BlBBBBBBBBlBxBhBBHBBBBBCC CCCCCCCCBBBB.C}CsC}C~C}CC{CCCCCCCCCCCCCC~CCCCCCCCCCCCC~CC}C}C}C{ClCDCCB`BLB,B BB,B,BBAlBCC7CECQCICC3C7CPC]CiCeCICBBTBxBBBBBBxBBXBtBtB BpBBCCC:CJCCWCQCC3C6COC\ChCeCJCBxBpBBBDBABBABBA BTBBC CCC'CNC?C;CSCMCSCJCDCGC:CCBBB}CCCC{CCrC}CzC{CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCyCyCCC~CCCpCQC%CBBB|B CCCCCBBBCC&C&CCBBB`BABABB B4BBC9CfCxCcCBBBBC CB C C C CCCCBBBB C~CoC|C}CCCC~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCyCyCCC~CCCpCQC%CBB(BBCCC$C$CBCC!C%C/C0C CBC!CB,B0BB|C~CCCCCC}CwCCC~CxC{C>CBBBCC C#C0CCCLCC5CYCYC*ChC}CCCCzCNCBBdBB}CC{CwC}CuC|C~C~C~CCC{CCCC C C C=C@CYCCCCCtCbCIC CBBB7CCCCC|C}C}CC~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~C{CyCCCCCCC'CACBCECFC3CCBBBB{C}C{C~C|CCCCCC~CC~C{CtCCECGC?C-CCCBBBBnCxC{C|C}C}C~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC}C~CCCC}CC C C$C$CC1CKCMCPCOC<@2I@`=`=@`'I@1ܱH@@I@xfO@;I@<@R@mI@}g@G' I@$Bm@[I@Q{@bOI@P6@U I@LA ^@(TI@8> @BI@b;@}@"`I@Q{@Ju {I@Hw@I@ؿ%w@\_I@06}@gieI@ D @j/I@}\ @I@?4@V4I@@?I@C`8y@0I@f$!z@y MI@XZ㿂@OI@?mz@( I@؟z@0 \ I@_ @p^ I@_l@ I@'t@D I@<t@S@h I@L8{@`? I@n@o I@Zp@* I@ ߤi@ I@źi@ I@1p@I I@=Zp@2_ I@&tv@j I@}w@3 I@_p@nI@o&q@d_SI@Aq@t}(I@_j@&I@@j@j5HI@%? f@;^I@sZd@`CI@R d@I@ؘpk@5I@) #k@<I@#q@|`I@/%?;r@ߞI@ sr@1GI@\ (y@wI@5 ty@ XI@m7)@J2I@Wy@ HI@%_[z@{I@?_@I@B_Ň@`I@n_@N|I@QI@ I@ 1@KI@)@{@ 0 I@@ _!I@?d@#I@@`I@D @U 0I@;@OdH@)wu@?H@U ă@H@?n@Ym_H@%@l@H@?h@o H@~ܟf@@AH@Rï?&a@,dH@N_@6H@3^@H@?[@ H@zZ@7H@|NQ`X@ yH@,W@~fH@o?T@OH@T"S@Y:H@YNQ@TH@q˿P@;H@<@N@+H@ * `5L@G~RH@VMJ J@`H@-#`G@f H@,_AF@h?UH@ wC@zH@r@@QH@ǻ*9@P KH@P@E7@DH@5@\3H@1Y4@z`H@rER3@Y H@LY3@HH@JV3@3H@p?3@?H@)3@H@D3@X @H@2@IqH@L_T2@ecH@@0@> @LH@Z/@g9H@˲P+@@H@5=*@H@?)@H@ 2)@=jH@O_(@U `H@\*s(@?H@<:'@_H@_%@H@M $@_H@/ן!@M#H@j@HH@vs@qhH@@3H@>C@S?H@ @X@H@J@eZH@a@z`EH@#@fqH@;}@tH@r@H@A7 @&`H@k-#@KqH@7`O'@PH@5)@/`jH@= *@x}H@,@_H@|`1@,H@3@H@G,6@H@-7@H@g_*9@_H@_D?^:@7,H@,?:@&@@H@ 2;@~ UH@J;@$H@;@H@#;@b`H@;`&;@\I@w?8@ ~I@wP`l7@?I@J 5@ޚ I@3@@I@0#@v0@ I@f.@|ߥI@&@u)@I@܋&@ @iI@3#@F II@&H*@I@Y@I@YNj@# I@|v@NI@S @'I@S @9C?I@*Ʒ~@?]I@?@]I@?@$ I@o$߄ @PI@K @5I@ؿ @6"I@GR@cv3I@п@;R <I@@JI@@@AxI@з?@KqI@@I@{&@;?I@U@ I@(@&`AI@҂d@*hI@vI N@0I@?@2I@| f@ TI@?@I@@4_I@@@mI@:@o 1I@ì@V `NI@M0@1eI@?M@.nI@쿭?@I@ɿ@@I@M@ɠ`vI@__@G' ]I@CH@2I@z ,@k_I@l@I@җ+@7I@ V@@?jI@0@/e HI@_@k_;I@@8I@0@0 9I@+3@@BI@Z@O۹@oKI@Ű?`@?bI@:Q@I@1@WI@?a@ I@F*ԯ@KI@@@I@_@WI@dޫ@J`I@؟@nI@|X@ I@O`@mI@ٟ8@bLI@)֪@,)I@R@pI@A͟@/"I@! z@|cI@@^_kI@@ZI@%@0 9I@_i@I@yo5@tI@ Ү@I@g'ſ@,nI@٬@ ~I@M:4@9+lI@ߩ@= ZI@"4@q@`4I@jqި@.I@K@fB_I@ `@2pI@J@^I@)@S.I@W@o$I@@W`H@Y߿@H@G@H@Ia @FH@}@v@H@a_@H{H@@&@@H@1@cv3H@x1 @%0H@MK݃@V4H@@ŭCH@~f|@3 H@{@B?H@9Wޟz@oc?H@k[9 y@dH@Ax@ngH@:]w@tH@&4eu@wPH@IQ`Ct@x1 9H@>\0Wo@+H@C@Sm@H@]?)k@$t`H@Yh@lH@7@^@pH@MT%Q\@H@/[@H@Β:>W@lKH@K O@ H@}˿N@>dI@p<N@aS`I@"bO@;_I@U@2I@& b@ـI@k@,I@{PUr@I@=p@4TI@bo@ө I@XE, o@ I@`kt@@)I@,@5u I@J_*@u I@8ߡ@s I@:? +@\! I@# @@(@ I@<"@.}  I@\M?@ I@Q@ L I@"Nx@ I@j @ I@*s@ I@0@U>I@[?@->xI@5@_)I@Nz@fB_I@ ` @U>I@}7@@kI@ @oI@<`@q?wI@͓@6uI@y.K@F?I@.@,nI@?@ڿ_?I@'@@l I@ C@ tH@1 ZC@,dH@uv@ ;H@. @_mH@ٟ@H@^>@@H@yD@=?H@I6@YH@W_@^;H@__/@ bH@۽?R@H@_@_H@ V9@r@?H@ߖ@WJ H@Զ@JJ5H@|5@?@H@@*hH@6  @N%@H@" @LYH@ jӿ@H@o?@N=_H@@_H@c+`@IH@' X@ڧ@H@u@H@s@H@L@N@:H@|M@;R @CwH@@MH@ ?1@`H@B v@\9H@/,@d^`H@_ @cH@?o@{H@(E@0H@@sH@t@ H@@2$@H@C@)%@H@<+*@H@?0@$H@(f9%6@.H@JG_<@@l H@/ =@~G`DH@6@:H@)8S7@sH@D_`p=@oH@?=@0aQH@1 ZC@L`H@}C@,H@I A@nH@״@@@KH@U@-@@ ;H@I>@ H@HF=@wI? H@vu;<@_H@K:@@H@(6@AH@=)@Z_ H@/"/%@H@pI "@# H@^ɟ @Y $H@!@QH@C@u& 3H@P@?H@8E4@F H@&S`\@\!H@~@ bH@<@>H@B@'H@84`@Ǽ H@i@NH@Զ @FH@  @(H@ @k\ H@ @(H@@ @Ym_H@-$`t @OH@?@H@ O@_H@EDֿ@_lH@5`@CH@RGr@0H@=@_H@ ` @P H@. @AQH@ @/"/H@ٮT@o@H@aN@hH@^9 @`YH@k@T~`9H@X?{@H@K H@$t`H@Lv@:H@& @ɠ`vH@@V `NH@ZT8@8@@H@K @ H@@BH@W=@ tH@9@@cwH@t@ H@hbb@n @H@º_@ jH@zŸ@l?H@*&@ߢH@k=@&@H@@DsH@M`@h@H@*@_H@5@6 @H@% @VH@do0@H@y_@@ZH@#%6@:H@j,@_@H@m w@H@n{_z@_H@-$`t@)c_H@'_n@ H@mo@\H@߃@:H@D1@H@@H@>;@7H@_v@_H@% @tH@ܟ@7H@z?@kH@ս_@ZH@n{_z@ H@ @V4H@U@=uߔH@K@e@=?H@mJ`@ eH@_)@(H@$ÿB@r/H@C N@+H@`@j H@ O@0sH@ޛ׿@ 1H@ɿ@kH@۟@?H@'D@G`H@>;@6"H@XC@>H@#N@v@w@_H@+෥@ oH@@ H@˷_@H@I7?Ý@(@H@ +&@0 H@@@ `H@,@n(`{H@! @Ym_uH@? @b`nH@(?@҂dH@ם՟P@YH@ZR y@* QH@V'@@:H@ @H@˄@^H@1 @. H@@@) @7 H@O @mgH@}@J`@H@1Y|@11 @+H@?z@WJ H@a u@`, H@ s@H@S?r@>EH@ 3o@?H@#Ol@*H@DE j@H@lf@"MH@'c@`(H@H"c@?2H@3@.`H@ؿ<@?bH@ ;@@@`H@Xߟ9@UH@X8@DsLH@;n7@s_7H@'?53@ H@(U2@@@H@R0@2pH@/@eH@S?.@y-H@G@,@¢@H@ )@WH@PK9&@. H@_."@2H@2G@2_H@H@Y߿H@@_H@2.ɿ@OH@qߗ@@H@ @H@~ @vH@l@H@&@:vH@1O@o ?H@D@!H@h͟@@?H@F+S@lH@nAL@H@82n@,H@`)ß~@H@wؿ@ `H@@5H@ I @7H@ןH @wH@C@_H@_@aH@[@H@l@4_H@҂d@ H@@X@H@*@qr`H@_@k\ H@@+?ZH@/"@H@߈@`H@ٟ8@H@Ag@y-BH@٬@h@WH@/ @jt?kH@5M@ 0H@A@@H@@@ө H@@4_H@,@@bH@L@?9H@$@ueUH@aR:`p@H@#;@-VH@  @Ǒ?H@4@cH@}@.H@]a@_BH@:P@WH@xE@/ H@C@lXH@G' @s@H@&@cH@Kڿx@!H@K$@n@._H@` @PH@?@qH@z @?H@cv@~H@b@ H@@>@%`H@G@_H@G?@?,H@>@2-4H@r/@r?H@'͟>@> @LH@b0@AQH@@ecH@zk&{@~H@$`@CwH@A_ @`?H@lݟ @H@_Q @`5H@f @ @HH@ @?oH@ @_H@韷@WH@r@g*@CH@z^@AiH@{9?2@?H@ff@aH@D@=H@_?@aTH@_@q yH@~_@% H@@\#H@Y$@ ?MH@?~@W`aH@N.l@@H@V@Y H@$s4`@&`H@O\,@_WH@M,@YH@R,@H@+@v H@N@)@> @LH@mo)@H@WJ )@H@դ%)@V `H@FW_*@2H@˲P+@@H@Z/@g9H@@0@> @LH@L_T2@ecH@2@IqH@D3@X @H@)3@H@p?3@?H@JV3@3H@LY3@HH@rER3@Y H@1Y4@z`H@5@\3H@P@E7@DH@ǻ*9@P KH@r@@QH@ wC@zH@,_AF@h?UH@-#`G@f H@VMJ J@`H@ * `5L@G~RH@<@N@+H@q˿P@;H@YNQ@TH@T"S@Y:H@o?T@OH@,W@~fH@|NQ`X@ yH@zZ@7H@?[@ H@3^@H@N_@6H@Rï?&a@,dH@~ܟf@@AH@?h@o H@Oi@)2H@&_h@H@mh@tH@p֟Hh@v %H@Z}g@H@gߞe@bH@`d@LA ^H@>Ad@fB_H@rc@6_H@z)Lc@sOH@P@b@1 H@;`@bH@`@?H@O_@?oH@Od7_@ H@ka@k?H@E Eb@v@H@ub@E|H@0I`~c@͓(H@4_c@$H@߽g@ @HH@h@]`'H@<%R`"j@wI? H@+ j@_H@8l@>EH@+ Vo@va_H@?p@߱H@Dr*cq@;H@q@7H@2){q@sH@n&p@G:H@p@y*H@5p@`H@ @'q@u H@<_q@@H@4 r@OH@! zt@;_H@u@H@DHv@lH@w@H@;`Gy@tH@I }@baH@A@?UH@;@?AH@ ۪k@K'H@OM΃@N| H@%@H@I@І@BH@$@Y H@u@4<0H@쟆@ @H@"@6_H@_ @5H@ ` @S@H@3@H@p?ܗ@~ H@&4e@{<H@7T @?_H@T;`@.:?H@g*@Ü@lKH@ @_)H@@`, H@'j@bH@:~@6 @H@9@͡@H@ߣ@#H@"d(@w@H@)NAR@-@H@v @H@8Z @(H@ҫ-@*hH@Y@ 8H@3@nH@vu;@11 @H@@]H@uv@ ;H@ &k`@H@J?@@H@5;@ԑ aH@ËՆ@7H@)!@6H@@;H@  @>]AH@PvL@@2TH@/ @q@b`nH@! @H@)^@4 H@@H@Ӂ0@ H@V@;H@9Qח@&@@H@;B@:@s@H@G?Ҙ@J'H@R0@Ro?=H@i@ H`H@ o@H@ÿ@0 \H@0r@+7H@ @\#H@ @_H@ @->xH@Gؿ@INH@q_S@58_:H@W@@&H@H:Ϣ@H@A@u@+rH@-Jb@QHmH@q @~G`DH@5@'@y@H@$qP@Y H@@Ǽ @H@6٨@g+H@?D8@qH@L?@fH@J_*@H@BӲ@\!H@B@zTH@ε@y'H@/y$@_BH@&@jH@ʋL@JH@VN@?H@U @[H@!c@"kH@B1@HH@"P?@ H@t@H@ "@]@H@'@6H@=@+rH@PS{@H@@l =@@H@ԟ@_mH@J @G~RH@w @v@%H@O@ZU@H@N@LH@,@@bH@@4_H@@@ө H@A@@H@5M@ 0H@/ @jt?kH@٬@h@WH@Ag@y-BH@ٟ8@H@߈@`H@/"@H@@+?ZH@_@k\ H@*@qr`H@@X@H@҂d@ H@l@4_H@[@H@_@aH@C@_H@ןH @wH@ I @7H@@5H@wؿ@ `H@`)ß~@H@82n@,H@nAL@H@F+S@lH@h͟@@?H@D@!H@1O@o ?H@&@:vH@l@H@~ @vH@ @H@qߗ@@H@2.ɿ@OH@@_H@H@Y߿H@2G@2_H@3>@@MEH@dl@H@>@SW H@e;@@(H@ `@_H@W@~H@ ğ@_XH@@z 7H@`@>EH@:g@zH@_@J`H@J?@ОH@|߱@WJ H@A ]@H@=/ @2~H@@ZfH@3N)@ueUH@O% @x1 9H@ BP@% #H@p ?@Ju H@-VK@rZ @H@g;_@ZU@H@״ @ H@П @`^H@u @KH@ S @ _!H@_$ @@@H@/ @tH@v @ H@E `@?H@LB@H@H @_H@Kŭ@<H@ @\H@@3H@_@@@`H@H?@ =H@>$@M@)H@q?@v H@eߋ@UH@#ٟ@VH@E#@ QH@@d)H@ @WH@%@. H@-1v@H@t@H@b@b}H@by>@iH@)k@h@WH@?_@7G6H@(?@ H@ކ @N=_H@>@ H@@4H@?+@H@3@@H@I@$t`]H@@j5HH@S@&@H@:?x@L`H@@ H@, @rrH@SI@ =H@@lH@(O@,H@+@"kH@꿵@KH@C@P?)H@P&O@RH@/d;^@|ߥH@/y$@:H@/J F@FH@˙_@Y H@@#@H@s+@58_H@S q@H@dB@ JH@bw@''H@i_@H@H`9@Ê H@B v@YH@g_@H@@Tj@Y $H@'+Lz@d)H@%@f@C4*H@_d@oc?'H@3u@&@H@@}_H@~@2H@@ H@_@pKH@ٗ* @ZH@*\@Q@H@\@[H@E"@?H@@OdH@5_#@fB_H@|@/ H@ @9+lH@* Q@GH@aC`z@l?H@%?z@H@ g@W`H@Oر@_H@@d)H@by@5uH@P-@j H@g?@4 -H@"_}@)@H@8ߡ@@H@Ia @/H@?<@b@H@oU@S߮H@@҂H@_χ@_H@ѿ@zoH@y@H@?_q@/H@ٮT@oh@{H@ц `d@@H@ S@9H@׿S@tH@m?S@-@7H@8E4O@cH@!Q N@;߀H@0aQ-@'_H@K+@IN`,H@+r!@VH@EH@R`@v"@@H@ٟ@H@. @_mH@uv@ ;H@@]H@vu;@11 @H@3@nH@Y@ 8H@ҫ-@*hH@8Z @(H@v @H@)NAR@-@H@"d(@w@H@ߣ@#H@9@͡@H@:~@6 @H@'j@bH@@`, H@ @_)H@g*@Ü@lKH@T;`@.:?H@7T @?_H@&4e@{<H@p?ܗ@~ H@3@H@ ` @S@H@_ @5H@"@6_H@쟆@ @H@u@4<0H@$@Y H@I@І@BH@%@H@OM΃@N| H@ ۪k@K'H@;@?AH@A@?UH@I }@baH@;`Gy@tH@w@H@DHv@lH@u@H@! zt@;_H@4 r@OH@<_q@@H@ @'q@u H@5p@`H@p@y*H@n&p@G:H@2){q@sH@q@7H@Dr*cq@;H@?p@߱H@+ Vo@va_H@8l@>EH@+ j@_H@<%R`"j@wI? H@h@]`'H@߽g@ @HH@4_c@$H@0I`~c@͓(H@ub@E|H@E Eb@v@H@ka@k?H@Od7_@ H@O_@?oH@`@?H@;`@bH@P@b@1 H@z)Lc@sOH@rc@6_H@>Ad@fB_H@`d@LA ^H@gߞe@bH@Z}g@H@p֟Hh@v %H@mh@tH@&_h@H@Oi@)2H@?h@o H@%@l@H@?n@Ym_H@ o@->H@ r@ H@֡t@_H@u@H@ߪv@ H@nRM Wx@UzH@(y@;?H@q.{@_H@Bc|@k?IH@g~@_H@xĶD@H@I"g@GH@@H@b:B@@+rH@1_|@9nH@Ku@=}H@ x@bH@;@@I@l| f@ TI@?@2I@vI N@0I@҂d@*hI@(@&`AI@U@ I@{&@;?I@@I@з?@KqI@@@AxI@@JI@п@;R <I@GR@cv3I@ؿ @6"I@K @5I@o$߄ @PI@?@$ I@?@]I@*Ʒ~@?]I@S @9C?I@S @'I@|v@NI@YNj@# I@Y@I@&H*@I@3#@F II@܋&@ @iI@&@u)@I@f.@|ߥI@0#@v0@ I@3@@I@J 5@ޚ I@wP`l7@?I@w?8@ ~I@;`&;@\I@#;@b`H@;@H@J;@$H@ 2;@~ UH@,?:@&@@H@_D?^:@7,H@g_*9@_H@-7@H@G,6@H@3@H@|`1@,H@,@_H@= *@x}H@5)@/`jH@7`O'@PH@k-#@KqH@A7 @&`H@r@H@;}@tH@#@fqH@a@z`EH@J@eZH@ @X@H@>C@S?H@@3H@vs@qhH@j@HH@/ן!@M#H@M $@_H@_%@H@<:'@_H@\*s(@?H@O_(@U `H@ 2)@=jH@?)@H@5=*@H@˲P+@@H@FW_*@2H@դ%)@V `H@WJ )@H@mo)@H@N@)@> @LH@+@v H@R,@H@M,@YH@<>\,@_WH@?+@.H@jx+@iMH@+/)@H@T'@Ju {H@b/$@c7H@Z'#@߱H@3@#@Z_H@2"@S vH@aP!@cUH@N-!@~@GH@1@@S.H@RŸ#@!H@69@_H@O@> @LH@r/@r?H@>@2-4H@G?@?,H@G@_H@@>@%`H@b@ H@cv@~H@z @?H@?@qH@` @PH@K$@n@._H@Kڿx@!H@&@cH@G' @s@H@C@lXH@xE@/ H@:P@WH@]a@_BH@}@.H@4@cH@  @Ǒ?H@#;@-VH@aR:`p@H@$@ueUH@L@?9H@,@@bH@N@LH@O@ZU@H@w @v@%H@J @G~RH@ԟ@_mH@@l =@@H@PS{@H@=@+rH@'@6H@ "@]@H@t@H@"P?@ H@B1@HH@!c@"kH@U @[H@VN@?H@ʋL@JH@>&@jH@fB_@/"H@q$@@UH@X?@% H@K @ `H@_P@ oH@}@ PH@n@ H@Y7ƹ@H@xH@ @_H@ @\#H@0r@+7H@ÿ@0 \H@ o@H@i@ H`H@R0@Ro?=H@G?Ҙ@J'H@;B@:@s@H@9Qח@&@@H@V@;H@Ӂ0@ H@@H@)^@4 H@! @H@/ @q@b`nH@PvL@@2TH@  @>]AH@@;H@)!@6H@ËՆ@7H@;@ԑ aH@& @H@5?R@H@ܟ@Ym_H@*ǿ*@CH@`@vH@ş}@H@'|@DH@%, 8{@NH@z@@XH@# y@^{H@8TJw@߭H@ t@_H@?*m@@H@_li@7H@b@ԑ aH@E `\@SH@5W@H@/7U@ޚ H@8Z S@2~H@RN@LA ^H@EX_@@x1 9H@kT=@)@H@!S ;@@XH@?_W9@O_|H@)8@g_H@)6@|@ H@o`4@2H@3џ2@ MH@@0@?YH@/@*@GH@72@&@j5HH@&@8XH@I"$$@)H@;#j@GH@J@YH@oL>@cwH@+@H@ r@F IH@tz@@AxH@@[H@`&9@H@d@iH@D @H?H@@ H@R@ؘH@aF@OYH@{ݿ@?VH@@7H@9n@hH@i 1@MߩH@k @VbH@yK @5H@*@ H@ٕc.@kH@Q1@_H@'T?4@QH@E4@N PH@;Q3 R>@|`H@WI;2C@~H@e;@C@b?H@ X?FD@_}H@cN@7H@X7 :O@UH@{gY@pH@| _@nH@l_@G' H@@}_@`YH@/[@H@MT%Q\@H@7@^@pH@Yh@lH@]?)k@$t`H@C@Sm@H@>\0Wo@+H@IQ`Ct@x1 9H@&4eu@wPH@:]w@tH@Ax@ngH@k[9 y@dH@9Wޟz@oc?H@{@B?H@~f|@3 H@@ŭCH@MK݃@V4H@x1 @%0H@1@cv3H@@&@@H@a_@H{H@}@v@H@Ia @FH@G@H@Y߿@H@@W`H@W@o$I@)@S.I@J@^I@ `@2pI@K@fB_I@jqި@.I@"4@q@`4I@ߩ@= ZI@M:4@9+lI@٬@ ~I@g'ſ@,nI@ Ү@I@yo5@tI@_i@I@%@0 9I@@ZI@@^_kI@! z@|cI@A͟@/"I@R@pI@)֪@,)I@ٟ8@bLI@O`@mI@|X@ I@؟@nI@dޫ@J`I@_@WI@@@I@F*ԯ@KI@?a@ I@1@WI@:Q@I@Ű?`@?bI@Z@O۹@oKI@+3@@BI@0@0 9I@@8I@_@k_;I@0@/e HI@ V@@?jI@җ+@7I@l@I@z ,@k_I@CH@2I@__@G' ]I@M@ɠ`vI@ɿ@@I@쿭?@I@?M@.nI@M0@1eI@ì@V `NI@:@o 1I@@@mI@@4_I@?@I@| f@ TI@W=@qH@Kŭ@PH@LBȊ@#H@@&H@YK`@x}H@EL`@לH@U)@kH@B!@H@ӕW@H@,@YH@;}@_XH@?@D_PH@忴@;H@Ƭ0@H@y(f@h?UH@ `@ _!H@?k@B8H@F?@-VH@8`@U;H@ٟ@G~RH@@&@1H@@H@6@PH@?X@xH@6@@)@6"H@s@P?H@H @Ǒ?H@.%` @zH@ASD@"H@*\@dH@EX_@m?H@ @H@Kŭ@l?H@c2@״H@_9@<6H@'_n @wH@3@!H@s @H@:2(@0I`~H@/:@H@ @>EH@ _.@Ê kH@!Q @YH@}6`F@J`H@ 7 |@]`'H@޿ @^ H@I@L@H@`@?H@]@4TH@z@\H@ @ @7 H@R0@f_ H@3@f_ H@@f_ H@ ?@xH@P߶o@;_H@[@6@͓H@) @/"H@(_0@H@o Ͽ@ W@\H@+@jH@D@@?fH@8~@XH@?@DH@N@;H@@X@, H@@WH@`&@@d`H@;Q3 R@`?H@s. @*H@e<@X@H@v@sVYH@`P@Y:H@9:@y@H@Ls@_H@t( @<H@_@`kH@1ܱ@(gH@-#`׿@ H@UR@=@ nH@IxJ @_dH@6ź@baH@A=@ eH@L`!@_hH@a?m@5uH@Ꟗ@$H@δ@bH@3\@iH@T@H@״@!@H@RS@@|H@%ϛ@H@" @H@7_@'_H@{@.:?H@(@@->H@m@΋@ _H@;?<@N H@n&ˈ@&H@~@LH@ -c@tyH@@gH@"@`UH@9@Q@?,H@W]$@@@H@1_@TH@i_@@AxH@KI o@`OH@@@?>H@OO@,@8H@ @(@H@ ?}@H@" z@H@$wv@) H@FCOr@_H@ _Co@H@wRm@4H@}!`k@H@$ÿBi@\9H@B_g@HH@V'@f@H@=_f@H@t7@zd@H@@_@H@/]@`zH@$\@>EnH@aW@=ZH@z_U@"JH@mR@y'H@wFJ@qH@!@bF@.:?H@C_5B@ _gH@ 7?@H@Aߓ=@Ro?H@21<@vH@JN`:@OH@bM 7@H@ 25@:H@zߐ3@xH@`j0@r?1H@;,@(TH@ (@PH@kT /'@fB_H@k:$@% H@zT@H@~r @H@b@sH@\@L`H@ :f@-`VH@ۦ6@@zH@hQ @H@%[@ H@[@ 1H@@qEH@G0@ ZH@̀?@Y H@t_K@g*@H@?@_H@̮A@''H@]: @$H@i9`?@H@@WH@ @ـH@@$1DH@5< }@ XH@r@2H@/@ H@@&6H@ 7@S@hH@߅R X@H@m w @@H@8̟ @H@l-@ @H@Q@XH@.K{@њH@DE @rH@&Aџ@2pH@?"@PLH@9@P H@6g@$H@C@ 8H@W=@ tH@@BH@K @ H@ZT8@8@@H@@V `NH@& @ɠ`vH@Lv@:H@K H@$t`H@X?{@H@k@T~`9H@^9 @`YH@aN@hH@ٮT@o@H@ @/"/H@. @AQH@ ` @P H@=@_H@RGr@0H@5`@CH@EDֿ@_lH@ O@_H@?@H@-$`t @OH@@ @Ym_H@ @(H@ @k\ H@  @(H@Զ @FH@i@NH@84`@Ǽ H@B@'H@<@>H@~@ bH@&S`\@\!H@8E4@F H@P@?H@C@u& 3H@!@QH@^ɟ @Y $H@pI "@# H@/"/%@H@=)@Z_ H@(6@AH@K:@@H@vu;<@_H@HF=@wI? H@I>@ H@U@-@@ ;H@״@@@KH@I A@nH@}C@,H@1 ZC@L`H@>TD@H@V{D@BH@D@gH@/ >@1H@?@fH@R@3H@?Q@ H@'S@;R H@U@?H@.ϿvW@?H@M@%b[@H@#@^@IH@_g@#H@2s@PH@{@@)$H@ǿK̀@u& H@@H@LBȊ@#H@8ٟ@H@qӟ܆@5H@0ICD@9H@E@`H@0G@ŭH@RH@1H@:OK@H@ ^L@H@'M@H@N8`M@H@7O@H@P@H@ )S@ H@)#.V@3H@=Y@?H@[@H@C\@xH@]@y MH@9[^@+H@w_@mH@9,`@H@t8a@Ǒ?H@}֟ib@DH@D=(c@=H@cf@>H@QEh@kH@k@;?#H@R q@v@%H@12?t@@*H@L;@w@ H@e,`#y@H@ޝJ@+|@# H@wF~@5VH@jG@ө 4H@_@^H@1@CH@|@#5H@@+zH@N_a@0aQH@@ *H@o$߄@y@H@^@Z_ H@. Q@+/H@I@~@=H@#Q`z@~H@'Qw@,ߦH@_5{@?oH@] ~@~ UH@2@EH@ @%,H@'@?_"H@qӟ܆@ОH@9@ͅ@RIH@u@ H@>p@wH@t_z@>EnH@W33z@ H@h:_w@ H@(;& `t@`zH@>@{w@H@wP`l{@`YH@f4|@o ?H@.@H@@жH@@ H@A@3 H@A <@? $H@Ag-`]@@)$H@":U|@v@%H@tQj|@GH@uSl|@߭H@׮z@2_H@2D%u@ ` H@Fq@~H@l,qp@=uH@nT`p@?H@q@FH@aA+x@ĆtH@ "z}@-H@ u@3H@0ICx@ _H@_ `Fx@ H@dH`w@H@ִu@H@0?u@G`H@Iw@ H@~Q@p@H@ Xp@r/H@3S@Vk@H@~^+g@ǻH@pc@ECH@j_@0H@M`iV@)K@ƻH@'U@1ûH@>pT@J2H@U@-L@H@L@4_H@w:L@" H@l_K@ H@rERG@H@@ߎ3@H@D=(c@=H@}֟ib@DH@t8a@Ǒ?H@9,`@H@w_@mH@9[^@+H@]@y MH@C\@xH@[@H@=Y@?H@)#.V@3H@ )S@ H@P@H@7O@H@N8`M@H@'M@H@ ^L@H@:OK@H@RH@1H@0G@ŭH@E@`H@0ICD@9H@}K?@5H@D@>@`+H@PLd=@ tH@"@<@z`H@ @@J:@3H@&?6@.H@`L3@0H@1@:H@24$0@ LH@14K.@gieH@,-@@H@EƟ,@KH@'+@%_H@J(@)K@FH@9 [&@ H@U%@7H@6%@_H@$@tH@$_K$@H@()=$@zH@ #@\!H@E?#@?-H@?d@pߘH@_@H@2@`H@`s@ H@@wH@@ AH@,EU@DyH@(?@ H@Q޿`@Ê H@C`Y@b H@P@''H@q_S @\3H@߰ @GH@^m@ L VH@+@ W@\H@ӬC@6uH@M`|@IqH@ҟ`@*hH@_$@?@H@@@ߙH@G +@}߶H@5)^@m@H@-U`m@5H@:?x@"e?H@v@O`H@ r@VH@N!s@`H@ٿ_@_H@+q@H@1@H@@@)c_H@|@H@t矅@=`H@H@wH@E"@H@wI? @_H@Fַ2@H@7@)H@傯W@* QH@@@qH@e@]`H@-B@|H@D@ H@۟@TH@*@1CH@}_@_lH@c̟g@U H@1*@H@ `@LY2H@@LvH@؄@AH@ZR y@OH@_.@ H@=a @8@H@D@2@@_H@(@@>H@V_@ H@f+?-@;H@*@i_>H@x?@ؘpH@ȿ@X@H@i8@o`H@&(@6"H@%@g*@CH@s @eQH@`$@/`jH@2!@@}H@IN`,@@H@@?H@¿c@H@P@J`H@K@H@1Z@F(H@j " @INH@#ȵ_F@H@L'@E|H@j@mpH@ʳ? @1eH@? @QH@\@L`H@b@sH@~r @H@zT@H@k:$@% H@kT /'@fB_H@ (@PH@;,@(TH@`j0@r?1H@zߐ3@xH@ 25@:H@bM 7@H@JN`:@OH@21<@vH@Aߓ=@Ro?H@ 7?@H@C_5B@ _gH@!@bF@.:?H@wFJ@qH@mR@y'H@z_U@"JH@aW@=ZH@$\@>EnH@/]@`zH@@_@H@t7@zd@H@=_f@H@V'@f@H@B_g@HH@$ÿBi@\9H@}!`k@H@wRm@4H@ _Co@H@FCOr@_H@$wv@) H@" z@H@ ?}@H@ @(@H@OO@,@8H@@@?>H@KI o@`OH@i_@@AxH@1_@TH@W]$@@@H@9@Q@?,H@"@`UH@@gH@ -c@tyH@~@LH@n&ˈ@&H@;?<@N H@m@΋@ _H@(@@->H@{@.:?H@7_@'_H@" @H@%ϛ@H@RS@@|H@״@!@H@T@H@3\@iH@ hIxJ h@^;H@ 8e@C4*H@*BH@@TSH@1@H@O@giH@Y @H@+ @mH@U#`M@xH@_@3 H@IQ`C@XF&H@V 5@`'H@;@(@i&H@v @,nH@EM@ H@0-@WH@f_@tH@|ο< @WH@0 @,@H@T"@H@cQ%@P?H@sj_6'@?H@ ? (@PH@r)@xH@t'+@ؘpH@nxm.@ՍjH@_O0@ՍjH@%+2@>EnH@_3@ yH@9,4@i_H@a?m6@xH@a淿7@U H@uv:@*H@ϣ<@H@O=@v 5H@G@>@]H@@kE@a H@R_H@PH@jK@H H@|?rN@b H@`?hP@jH@{T`3R@QH@; #V@DH@:W@MH@[ Z@/ @H@/N^]@?H@@&`@ yH@Qc@Ro?=H@$a@?_"H@`@H@o]@H@o\@vH@?b[@?H@i_X@SW jH@_ Y@48H@IY@_H@_Y@}H@9_tZ@AzH@"@\@x? H@>\@ H@(k]@dH@i_^@̫|H@wO_@ TH@kLH`@#0H@o:Ub@HfH@.d@_H@ 8e@ ZH@Hd@mH@<`d@#RH@(`}d@H@N`@\xH@Y_@=H@ s%_@HfH@B4^@d`H@3m^@(@ H@,H^@ H@Hc]@ H@g`]@H@(\@-H@~X@H@:W@k\ H@9WޟV@IH@g9V@E?H@_U@a H@TU@%H@F_U@''H@9T@9 (H@ExT@'H@U@-T@v %H@MCT@6DH@ֿ-T@@pH@oH@S@uH@34S@e @H@kR@#H@_LRQ@mH@KP@xH@#N@H@ݿL@WJ H@vJ?vJ@f H@&)G@7H@O`D@H@_C@~ H@,H>@0aH@ # <@1H@@%0:@aTH@9@+H@^?I6@H@އ,3@PLdH@fN1@H@Ǽ /@Q H@.@BH@ff.@+H@U `.@\H@C`8-@tmH@*@5{@SH@ڪE(@>H@\F&@y@H@L $@H@|S#@H@c5"@|`H@?L!@ߌH@=@ @(TH@@Li@ H@S`@zH@;7/@H@H@>H@o$߄@lH@0@WH@N>@8H@{g @ H@ T @(H@l @H@2߉@_H@wܮ@va_H@M:4@2H@4@}6H@p@wI? H@ĴN@! H@@S?H@@@H@(@`=H@} @@\_H@ _%@@Ju H@ڿ @v H@r?9 @h@H@,@?H@}!`@ bH@u@H@?@aTH@(@tH@9K@ H@j@H@;@?H@4@H@O@1H@0LC@H@L@RH@&@H@2L@{{ H@R@q H@R?@*NH@v>@6 @gH@S)ߗ@QxH@F6 @)H@e:@WH@}@b}H@H@PIW@f_H@i_f@H@St@l?H@-@tyH@@/ @qH@@ \H@@;H@v@̫H@?n@eZH@Ah_Dz@H@^9 @H@ؙڭ@ H@,'@cH@H@ H@?@c7H@ia@H@6-B@ɠ`vH@+ğ@d^`H@7@@?8H@՟@@H@9@->H@@O`H@,Q @ H@g@H?H@>@@yH@E@H@@hH@V߀@SH@E @t_KH@c–@J`@H@??ʔ@^;H@}`ő@ =H@o@AH@He/@*NH@} F.@`H@QH@6"H@;@sOH@_@J2bH@C#TZ@)H@F,ޟ@H@@[H@mJ`@H@λb@yH@[@6}@aH@*.x@3H@EZ2{@ `sH@r՟q@H@W7U@ɠ`vH@ݵ5@''H@0t Dy@* H@cy@H@!S s@ ?MH@IxJ h@H@A`ai@/ H@>zj@||H@*uEr@ H@-.w@dEH@_ |@_H@I8{@H@>\0W{@PH@OB{@ !ߐH@,@HbH@r?φ@o 1H@@ SeH@Ϳ؅@ _H@>]@u@H@w 5@o H@d[Ӗ@H@@Tj@eH@ц `۠@H@?@2pH@@j5H@HM @Z ^H@i_f@ZDH@d@zH@eC_@ H@@B2H@@CwH@1}@}_H@ |@_pH@>7@7H@@0 9H@]Iٿ>@H@oU@S߮H@?<@b@H@Ia @/H@8ߡ@@H@"_}@)@H@g?@4 -H@P-@j H@by@5uH@@d)H@Oر@_H@ g@W`H@%?z@H@aC`z@l?H@* Q@GH@ @9+lH@|@/ H@5_#@fB_H@@OdH@E"@?H@\@[H@*\@Q@H@ٗ* @ZH@_@pKH@@ H@~@2H@@}_H@3u@&@H@_d@oc?'H@%@f@C4*H@'+Lz@d)H@@Tj@Y $H@g_@H@34@} uH@S@cH@/v@*3 H@lSf@MH@@H@7@H@B?@2H@ߖ@_ؿH@;_@5H@ Jڟ@9nH@ٗ* @2pͿH@_ג@H@<t@t}(H@߽k@AH@] _X@|cH@ NW@eH@1]@KH@p`@ H@'`\@~H@ե=X@oXH@NܿO@H@ TƿD@`H@hNB@m?H@aS=@;H@1A@hH@D B@H@٬B@/e H@ƿB@4H@ C@H@N@B?H@+N@H@O@H@(9U@:j?H@X0_@06H@f@H@U@m@hcH@j_kx@`(H@z( x@%0H@*.x@3H@[@6}@aH@λb@yH@mJ`@H@@[H@F,ޟ@H@C#TZ@)H@_@J2bH@;@sOH@QH@6"H@} F.@`H@He/@*NH@o@AH@}`ő@ =H@??ʔ@^;H@c–@J`@H@E @t_KH@V߀@SH@@hH@E@H@>@@yH@g@H?H@,Q @ H@@O`H@9@->H@՟@@H@7@@?8H@+ğ@d^`H@6-B@ɠ`vH@ia@H@?@c7H@H@ H@,'@cH@ؙڭ@ H@^9 @H@Ah_Dz@H@?n@eZH@v@̫H@@;H@@ \H@@/ @qH@-@tyH@St@l?H@i_f@H@PIW@f_H@NH@>H@%, 8@F H@pެ@?H@@fH@*!@LY2H@_@5dH@@6 @gH@R?@*NH@R@q H@2L@{{ H@&@H@L@RH@0LC@H@O@1H@4@H@;@?H@j@H@9K@ H@(@tH@?@aTH@ @s@dH@_5@+ `oH@@2~H@^?.@H@_ @H@O @2H@:>@r/ H@,!@H@wؿ$@:j?H@X(@tH@~ڰO-@ H@pH.@<-H@40@baH@1+3@ߌH@s5@nH@H6@l H@n;#8@H@_ @@UH@C@|`H@S E@s_H@m&ZF@H@6F@o H@DF@Ǽ H@5F@H@բ1G@ H@R`}G@XH@PG@_H@䶿H@H@iI@KH@J@nH@3N)J@`H@EJ@?H@K@3H@cxK@@@H@M`K@*H@%K@?H@ `K@H@RC L@RH@Z/L@(H@ ~ +L@H@7*L@H@pL@H@º_L@U H@lo" L@H@iL@3 H@ `&L@_H@Y.SL@X @H@{_L@H@N@9fH@6~N@G' ]H@t$N@-`VH@P = N@%OH@0`,N@Ah_GH@RN@ ?H@DN@\3H@N@?(H@B{N@ H@66N@^H@N@BH@aSM@xH@M@v H@< 翬M@c H@f~?M@:H@(߿M@XFH@48@M@?H@RŸ#N@(gH@2-4N@_H@_9N@H@ S1N@@?jH@8N@@cH@HRN@ \H@*`mN@YH@EDֿN@DWH@0N@ueUH@bO@SH@XP@PH@x? Q@vNH@#5;Q@2pMH@Q@9JH@; #R@ _CH@QCR@j@G?RH@t֟j@t_KH@I;j@v@H@" j@58_:H@ jӿj@z?4H@ ?j@1H@?j@e @/H@-k@`k-H@'l@y'H@u_l@H@Xm@cH@*yn@H@ @o@N%@H@_Zo@2_H@"P?p@ H@6up@qH@'p@H@)^q@KqH@yH@q@ H@ r@H@65-r@(@ H@y.Kr@ H@=``r@X @H@:r@x? H@1_s@`=H@<ןs@ _CH@# t@HH@u@[H@_bu@@@`H@-6 u@?fH@au@N=_hH@>w@lYH@<_y@w`QH@@@H@ƕp@}6H@ `>@'H@=@H@ O@H@ƘG@}@ـH@ n@ܣuH@*@'jH@b0@״9H@3֔@/"/H@U `@H@$_K@rZ @H@@UH@9_٢@H@@ H@3D n@{nH@&l_p@\H@N@lYH@v@HfH@o@hH@ !@ @H@+@8?H@?'@H@*@͓H@G ^@xH@i@}_H@\L@K@_H@C_5@~@GH@,B@@va_H@/@ _H@?b@H@(@\H@;,@?YH@9@Q@TH@ `?3@`H@W?x@ŭþH@TM @ nH@:@j@?H@F@ݾH@R@sH@- }@H@"n@T[H@G}'hf@ڿ_H@"g@О.H@9@0g@c7H@2;g@u@H@_e@q3H@ ,d@_ H@F^@0H@ğUX@?VH@1?J@"kH@_I@H@.)N 9@2_H@S5@NH@@,@wH@OY+@?YH@z)+@ QH@N.l(@`H@ M:4@$t`]H@}K?@ @H@ߴ@H@Y"@@e @H@KT@(@H@8~@kH@R4 @P H@l@,H@Fַ2@H@wI? @_H@E"@H@H@wH@t矅@=`H@|@H@@@)c_H@1@H@+q@H@ٿ_@_H@N!s@`H@ r@VH@v@O`H@:?x@"e?H@-U`m@5H@5)^@m@H@G +@}߶H@@@ߙH@_$@?@H@ҟ`@*hH@M`|@IqH@ӬC@6uH@+@ W@\H@^m@ L VH@߰ @GH@q_S @\3H@P@''H@C`Y@b H@Q޿`@Ê H@(?@ H@,EU@DyH@@ AH@@wH@`s@ H@2@`H@_@H@?d@pߘH@E?#@?-H@ #@\!H@()=$@zH@$_K$@H@$@tH@6%@_H@U%@7H@9 [&@ H@J(@)K@FH@'+@%_H@EƟ,@KH@,-@@H@14K.@gieH@24$0@ LH@1@:H@`L3@0H@&?6@.H@ @@J:@3H@"@<@z`H@PLd=@ tH@D@>@`+H@}K?@5H@& =@H@ÍJw9@$\ @H@&6@7@! wH@sZ4@@XH@IM7`2@ DH@A1@g+H@J ,)/@P H@@RM-@L_H@eG,@H@l*@kH@ G*@ W@\H@C(@9C?H@ g'@(H@uv&@H@E $$@ H@$F"@S H@e,`#!@Z H@ @ H@y@/"H@_l@ `H@Y@(H@J)@\H@3u@G??0H@뿔@4TH@M@sH@# ?u@H@n+ a"@H@fm \$@@H@F&@^H@)?'@}H@5+@ L VH@ -@G:H@L_=/@`$H@(E1@ H@.3@&H@yA?1@ZlH@'.@.H@u)d,@H@u*@S H@P5_)@KH@y1(@"H@;&@ `H@ǀO $@m?H@n"@kH@@߼ @/"/H@)@?8H@jq@;H@%O@?8H@:?@4 -H@A@@@H@!;@HH@ow@DsH@d@cvH@0? @fB_H@( @f[H@" @}9H@K_" @H@z @H@I7?@^_kH@pM@RIH@LB@r?H@X@8H@ @?-H@M@tH@@ H@Iy @C4H@d@QHH@#ȵ_F@J`H@6L@_H@ng@d`H@ @ `H@;'G@ H@ٟ@H@4!1@58_H@ M@wH@ҟ@LH@l.@@H@2`^@;^H@?'@H@+@8?H@ !@ @H@o@hH@v@HfH@a>N@lYH@ӿN@+H@ @j H@i @'H@_2@ W@H@E@H@ޯ_@N H@ɼ@H@ÞǺ@0aH@`ϸ@H@*" @H@^G@ECH@d R@2~H@W@VH@)_@H@8@_H@Jq@$t`]H@/?`@4_H@w@/ H@`@b`nH@ȧS`@H@<@_H@Ŀ@ĆH@C@j5HH@+@H@j5ȩ@H@`@_H@o#+@ _!H@:M@-VKH@@'H@ƕp@}6H@@@H@<_y@w`QH@>w@lYH@au@N=_hH@-6 u@?fH@_bu@@@`H@u@[H@# t@HH@<ןs@ _CH@1_s@`=H@:r@x? H@=``r@X @H@y.Kr@ H@65-r@(@ H@ r@H@yH@q@ H@)^q@KqH@'p@H@6up@qH@"P?p@ H@_Zo@2_H@ @o@N%@H@*yn@H@Xm@cH@u_l@H@'l@y'H@-k@`k-H@?j@e @/H@ ?j@1H@ jӿj@z?4H@" j@58_:H@I;j@v@H@t֟j@t_KH@by>j@G?RH@9j@8XH@T"k@aH@Uݟbk@AiH@ k@etH@(Tk@~H@ k@7_H@k@.} H@#u_k@v@H@I8k@H@'4 k@Ώ_H@1 k@v H@&@ok@ H@0 9k@&`H@߳j@H@kj@@H@_rj@H@ۻHj@H@޿i@H@Fi@AH@ixai@rZ @H@~+i@y H@=h@ H@0g@.H@o.f@D H@(f@H@g_e@`H@7e@MH@Ye@1H@5/e@H@%m_d@,nH@c4?d@a H@)?/d@x?H@d@!@H@jc@6H@@,@c@? H@&@r/ H@O @2H@_ @H@^?.@H@@2~H@_5@+ `oH@ @s@dH@?@aTH@u@H@}!`@ bH@,@?H@r?9 @h@H@ڿ @v H@ _%@@Ju H@} @@\_H@(@`=H@@@H@@S?H@ĴN@! H@p@wI? H@4@}6H@M:4@2H@wܮ@va_H@2߉@_H@l @H@ T @(H@{g @ H@N>@8H@0@WH@o$߄@lH@H@>H@;7/@H@S`@zH@@Li@ H@=@ @(TH@?L!@ߌH@c5"@|`H@|S#@H@L $@H@\F&@y@H@ڪE(@>H@*@5{@SH@C`8-@tmH@U `.@\H@ff.@+H@.@BH@Ǽ /@Q H@fN1@H@އ,3@PLdH@^?I6@H@9@+H@@%0:@aTH@ # <@1H@,H>@0aH@_C@~ H@O`D@H@&)G@7H@vJ?vJ@f H@ݿL@WJ H@#N@H@KP@xH@_LRQ@mH@kR@#H@34S@e @H@oH@S@uH@ֿ-T@@pH@MCT@6DH@U@-T@v %H@ExT@'H@9T@9 (H@F_U@''H@TU@%H@_U@a H@g9V@E?H@9WޟV@IH@:W@k\ H@~X@H@(\@-H@g`]@H@Hc]@ H@,H^@ H@3m^@(@ H@B4^@d`H@ s%_@HfH@Y_@=H@N`@\xH@(`}d@H@<`d@#RH@Hd@mH@ 8e@ ZH@.d@_H@o:Ub@HfH@kLH`@#0H@wO_@ TH@i_^@̫|H@(k]@dH@>\@ H@"@\@x? H@9_tZ@AzH@_Y@}H@IY@_H@_ Y@48H@i_X@SW jH@?b[@?H@o\@vH@o]@H@`@H@$a@?_"H@Qc@Ro?=H@x e@`OH@9nj@Ju {H@k@H@bM o@jH@ ut@ @H@$@y@r/H@,@{@`H@I~@wH@)@.nH@ҙ(΀@WVH@ 6`@H@1$@,@ _H@T@H@:E`@?H@Y@@H@e@H@ߴ@H@ X:?x@e @H@]: @?bH@h-6 E@`, H@NI@P?H@NJ@SH@\*sL@ uH@EM@^mH@/N@@?jH@A O@kH@O@%_qH@忓P@q yH@?Q@?H@a_S@?H@?T@<H@[U@BH@2X@`H@+:Z@;?H@º_\@etH@ ~_]@G~RH@!h7]@8/H@N49^@F H@"? _@`H@?_@SH@~`@AiH@3EH@ s@H@a u@`, H@?z@WJ H@1Y|@11 @+H@}@J`@H@O @mgH@@@) @7 H@1 @. H@˄@^H@ @H@V'@@:H@ZR y@* QH@ם՟P@YH@(?@҂dH@? @b`nH@! @Ym_uH@,@n(`{H@@@ `H@ +&@0 H@I7?Ý@(@H@˷_@H@@ H@+෥@ oH@#N@v@w@_H@XC@>H@>;@6"H@'D@G`H@۟@?H@ɿ@kH@ޛ׿@ 1H@ O@0sH@`@j H@C N@+H@$ÿB@r/H@_)@(H@mJ`@ eH@K@e@=?H@U@=uߔH@ @V4H@n{_z@ H@ս_@ZH@z?@kH@ܟ@7H@% @tH@_v@_H@>;@7H@@H@D1@H@߃@:H@mo@\H@'_n@ H@-$`t@)c_H@n{_z@_H@m w@H@j,@_@H@#%6@:H@y_@@ZH@do0@H@% @VH@5@6 @H@*@_H@M`@h@H@@DsH@k=@&@H@*&@ߢH@zŸ@l?H@º_@ jH@hbb@n @H@t@ H@9@@cwH@W=@ tH@C@ 8H@6g@$H@9@P H@?"@PLH@&Aџ@2pH@DE @rH@.K{@њH@Q@XH@l-@ @H@8̟ @H@m w @@H@߅R X@H@ 7@S@hH@@&6H@/@ H@r@2H@5< }@ XH@@$1DH@ @ـH@@WH@i9`?@H@]: @$H@̮A@''H@?@_H@t_K@g*@H@̀?@Y H@G0@ ZH@@qEH@[@ 1H@%[@ H@hQ @H@ۦ6@@zH@ :f@-`VH@\@L`H@? @QH@ʳ? @1eH@j@mpH@L'@E|H@#ȵ_F@H@j " @INH@1Z@F(H@K@H@P@J`H@¿c@H@@?H@IN`,@@H@2!@@}H@`$@/`jH@s @eQH@%@g*@CH@&(@6"H@i8@o`H@ȿ@X@H@x?@ؘpH@*@i_>H@f+?-@;H@V_@ H@(@@>H@D@2@@_H@=a @8@H@_.@ H@ZR y@OH@؄@AH@@LvH@ `@LY2H@1*@H@c̟g@U H@}_@_lH@*@1CH@۟@TH@D@ H@-B@|H@e@]`H@@@qH@傯W@* QH@7@)H@Fַ2@H@l@,H@R4 @P H@8~@kH@KT@(@H@Y"@@e @H@ߴ@H@e@H@Y@@H@:E`@?H@T@H@1$@,@ _H@ 6`@H@ҙ(΀@WVH@)@.nH@I~@wH@,@{@`H@$@y@r/H@ ut@ @H@bM o@jH@k@H@9nj@Ju {H@x e@`OH@Qc@Ro?=H@@&`@ yH@/N^]@?H@[ Z@/ @H@:W@MH@; #V@DH@{T`3R@QH@`?hP@jH@|?rN@b H@jK@H H@R_H@PH@@kE@a H@G@>@]H@O=@v 5H@ϣ<@H@uv:@*H@a淿7@U H@a?m6@xH@9,4@i_H@_3@ yH@%+2@>EnH@_O0@ՍjH@nxm.@ՍjH@t'+@ؘpH@r)@xH@ ? (@PH@sj_6'@?H@cQ%@P?H@T"@H@0 @,@H@|ο< @WH@f_@tH@0-@WH@EM@ H@v @,nH@;@(@i&H@V 5@`'H@IQ`C@XF&H@_@3 H@U#`M@xH@+ @mH@Y @H@O@giH@1@H@@TSH@h͟@t>H@ G w@ _!H@:Y@BH@_@(TH@L@/`jH@B@ H@ކ @N=_H@(?@ H@?_@7G6H@)k@h@WH@by>@iH@b@b}H@t@H@-1v@H@%@. H@ @WH@@d)H@E#@ QH@#ٟ@VH@eߋ@UH@q?@v H@>$@M@)H@H?@ =H@_@@@`H@@3H@ @\H@Kŭ@<H@H @_H@LB@H@E `@?H@v @ H@/ @tH@_$ @@@H@ S @ _!H@u @KH@П @`^H@״ @ H@g;_@ZU@H@-VK@rZ @H@p ?@Ju H@ BP@% #H@O% @x1 9H@3N)@ueUH@@ZfH@=/ @2~H@A ]@H@|߱@WJ H@J?@ОH@_@J`H@:g@zH@`@>EH@@z 7H@ ğ@_XH@W@~H@ `@_H@e;@@(H@>@SW H@dl@H@3>@@MEH@2G@2_H@_."@2H@PK9&@. H@ )@WH@G@,@¢@H@S?.@y-H@/@eH@R0@2pH@(U2@@@H@'?53@ H@;n7@s_7H@X8@DsLH@Xߟ9@UH@ ;@@@`H@ؿ<@?bH@IM7`>@.`H@A-@@@ iWH@aA@]OH@8A@cC@ 8H@-6 E@`, H@raster/inst/external/test.gri0000644000176200001440000010770014160021141016026 0ustar liggesusersb#DUDitD-D:DCYC, CBCCCCƆC޽C}C]FCCC#CiCD%DDD$CC0C~C?CZC{(CR\CLbCْCėCTѝC٥CC CWCg`CDDPCCCo`C C0C|'CwCoC!_CqC; CC CâC9CdCѰCȅD;9D*rDCVCCsCCCd2C CpCbnCzC0cC;CNCQC?CWIC_CnD1.Di DPDC)CCRC \CCC5CȍCCICCpCuwCCǠCC3 DDDC֪CbpCNChCC堏CCƕC2CCC Cc)C~CCJCқCD(DDDuCC *CCͬC}CC֔C#C*MCހCgCKC]C/]CsC1CDFDL DDԓCބCCC*C\CCzC uCofsCxCMC:C>RCoSCF~CO?CT"DDnD+vC C*C2'CICNCQCSVC;C%CJvCtCCkCCBzCRn{C>CI0DI DD@0ChCCRCCՂC4COGC}CCLmkClC(CCbCDN|DrCzCFCzCǷC CC}CCbCK@C5{CPCؐC'5CuCfZD>AUDGD92D\DL DCCbCfCaCCϝCrC¥CҨCC`CyCeuC+C|D|jVD֝JD2HD2DD DcC7C CCCwBCMC=CCyԔCC?}{CC`CC) D]Dg[D?Dʉ5DY$D D:Q DC !CCKC xClCOCCɖCaCڔCJCϕCCHtDDCbD8lCCCC'rjD]PD,HDSCD`>Dn8DG1(D D XCCCVC'8CyCC9C׫C1CCCΉjC{fCtCCƟCcC넨CLD}DKDnDrQDG6KDBD:9D80DYDxCCxOCC\~CCRDC%Cy#CŲCϥC3CuCnC]CCS^CCBD QDDCD˟DgDǿDf{D5TD*LDnADa7Dz.DDGC϶CCCCCaC@CCQCܫCI*C䥁C{C~%CNC䒦CC#cDDD[?D_čD~֪D DR Dn8D ѩDtDtwDxQDMBD7Dt8,D@De DCC5Cq.CѬCC-4CC/CCEC|CC#CC CC/C^x[DaDWDgޥDD[DfDg5DD|tD`ׯD0DlD6FD7D/D9!Dr DC\C lC C zCCmECCC$Cz7C"CCf!CsBC|C}?CFCZD0`DSDZDxdDٶsD56_DMDWD\jD]qnDXuD8DAkDl+JD {5D$/D0D+DD[CIVoCɽCCPqClϚC CCbC CyCfClCC9PCfiC9C}^DtYDXDDID AD 9D0D!D+D(=D&ADt1D DmDLDJ!D@#D(DDBCk C'CYCCN4C]CKCp2CCCC.CIC6C CUC瓼CLGwD_xDZDlAD U/D D, D!DED6DԢ'D%Dy DCyxCD¹ D| D DGCn`C҉C۱C{CC CnCCܽCkCrFCCCvC7CDCҿCsDD5SD-DDYD:DD&D%DQLD\DD CC_/CCQ`CMCEZC\ CsC ӢCCv.CCUCzC)CCUCSCCCbCCCgCDDQKD^=DDDBDCѰC`D DD9D( DRD;aC CCCl~CCCC#CCu0C/CRCICžC*C ,CCoCCgCCGCCoJD;-DVCڠC C4C)CC-CJC(DWDwDԲC,C C'C2OCCHCmCCܑCu_C_QtC*C>WC^C!CC'C$ C'CbC C"2CHC.OD,+DCCg׷C>0C!CCD?CC~CEC~CCkCLCCjCpCmںCܟCCC Cu>CtYCM-CFVC۫CcC4rC;C7CaCŚCuCLC7Dc8DCt DDu7CACtC/CiCCTCCRC4RC*C}CCr0CCCǶC槲CiCZCwnCklC1CYICҥC͕CCB̻CCYCv]CFCGC%D DhD DC!C ;CCBCC1CBCؠCCC;CSCWCCwCrCCCCPnQCCCqCsSCw4C)C C۸C5C>zCCBCUZ,D/D D,MC8CCCR%CyCLCC2C#C')C2C"CJC꼄C˃CCCHCߔCheC[3C1$C`C"CiCCC/CCCC2DvR!D" DVC3C̹CCCICCCCBCYC)C ֞C&C7CC5C;CCCC oxCUCdOCoC{ÊCC>CjCCCCnC'MDd#DDCCeCJMCKCpCICȋCC(CC sCp}CCCCC CCdC\NaCbCDC9KCKipCYCsCI:CيC C4CəCDDg}D&VCѧCJCVCC/CGCCϿC7Ci֜CCC}CĠC}CeCC3CBC"IC]SC=$CY2CviC%܉C|C9Cg;CLCŵCCDDD8CCǠCPCCCCEC6CCE_CCduC7C*ןCwC_CyCCYuCMmC\^gCʌMC>TCxCRCzCۡCaCCдCDS DwFCCWC4CߴC,CtBC߾CUECCoCClCICAC̖CJCUCCCdCCHC2vCyCMCÏCwC̡C6ӨCCC{D(C CVjCl.C"CbC`{CCC*Dۘ-DD`CSCܜC`CC2 CCcyC΅CC"2|C-iC7C0C}^C{CCtCC]CoVCgCQAzCSЂC1CCaCˉCCCaCX&C(-DD5D +D9D` D5uCC|CCCCvCOK~CZC=8_C0YC=XCwECxDC][bCjtCuC{qClCjCynCtCaDzCwCk܂C^/C;C CsCeCɏCZ+)D2DKtC?fDI/DD?0D@$D~DrDDgDBD' DGDDhCCC֬C Cr CCMCYއCiC-Cu%0CXCJoCD*rC)"kC`CbyVC SCC\CgmCCCCeD:}D ?wDX,KD0h1DfH#D~}Dx^D/ D,UDDEDՏD CLC~C;C|CtFCC0CCWCCʬiCԯeCuCֈC5CtC_C~ACZ=CJ+VCsC.C CrDFDxlD+3jDЮ[DP>*D o D(DKD:CbCUoCvC\ZCCsCCOCCcCI|CACC~Cp0C*CCCC,CCqC~CblC~jC}C/xC!bCOC.D9DFD~HD;DDI4DZ.DMY%DPlD[DCC^CECCGCŋC]CCCYҝC;CC2CAACC lCC͔CCCyCFuCIłCJC>RCECwCCw˝C6*Du>D ^DDQD~4D'D;%DͱDD^u DCCLӄC˜CCCXC<_CCapC CvCدCC?C9o D8+(D0DTeCqCXCC%݂C*]C@ZCCtCCCCˣCdCD%DݢCCצC}CìCRCqCfCbCԫC. CuCJC#CfC&1CC6CifCCC,C(CZC}CsfC(CDF D DGDDZD\DDD=tD*DD>CC^CLCC߮CPC6CC7C8CCzCܥCjC=CPC6ŖC'CC|CuCx_C4C4CCCCCmCfCCCCDsf D7T DP DTD9C.fCPTCbCfCoC mC6CCCgFC,CźCyzC|CnWCFC}CCS͟CCCC\=C+>XCnCCʭC|CrrC:kCCC}CUC2gCCCDCCCjC?Dh^DӖDE DMvDCqCC_CCCC2CXCCCЌCɾCD%C]'C CBvCˈCC#qC3C*vCBC,CzqC9C UCC!+CCC3CyC`DD(DrD=DO D!DD]SDC^CDpDjLD wDDCCR\Cm0C2C]CECCaECSCKC׿C+^CZCUаC˧CšCC9cCCDC݄C7oC ~CnC$CqCCC+CCCȃDΩD٤!D.D2D,DA$D>DܸDWDs DD(CD~aDDDECbCeCC̤C-gC)C_C2CkCCcClCCUC̨C,CFYCnCCVC8C/CZCaCd0C^CxCCAC!CMCC-C>JCvCIDDyyGDaj}DRaD]XD{DCMD=6D//Ds&DCDjDDCC Cg=DDDCdMC C㠾CCUC4C6CC9CC}CCC}CȏC7C&CC*}C@CNMCxvCVCCӏC3ҘCb!C-oCGCsCCЁCM Dg,D&y^D0DDiD6DF6YDk:D3Du+Ds2DDDY.CCC4C:C;ECUC CdC)CCC C3ԷCU;CIC CO1CeC6CC* CҟCICCCCbmCejCuCCCQCC6CCC#C@}CC(C+<Dr/D{aDD;D#D]Dw\D;D}y2D)D)DD5D4{CCFCCvCCC{CC8CC@CCCDjCJCC$CJC8$CQCCTCvC?CAChCyCZCysC.Y[CcCCRCΘC+AC5ҳC'CC=CC\D)D~PDDDDDcXD&;D,".D$DexD} DwDdC@C,CƒC!CCH*Cj>CCC0mCCBCDCGCUC CC(YC}$CeCC7C%>CCufCߐC5CCnCN'iC6C/fBCS0vCsCCBCڒC ?CCdCȆCk D!D?DY_D1Di)DYDDDPCI$CqCCCrC(CJC CiCC+CCC`CMCJC##CCvCQ,CCfCoCÊuC9Cл~CECdCCCCqC-LCZUCCmfC^]CͫCC C`CC*CzDDC$pCCCdCqYC]CCC;$CCC7CCCbC]xCwCM"CCC&C)C|CYgCJC%]CxCOtlC&{CC(CCV~CwCeCC"CCC<CCwcCC`SCC4CSC,CCFCXCvClQC*gCCC!CC CoCfC{gCCC)CPC˕C C|CRyCuCC}C,C#}CؔjChqCcCBCӸC(C\rCέCCՑCdψCcxC\ vC"CCC!cC'"D,D(DDw DBbDWD DӣDCWCCppCCfC4CPCjCCCCDmC D}D\DDGDmDD}D3 DeDY DtDKChC> D,bD-DAC(CCFCC CbC D D DDCD<DUD- D2 DbDC'D D)DDC;CCS C)D}DuDDѬCfD;DDCCCռDD%DCYCV~CMCfCقCC:C~C|CgCraster/inst/external/rlogo.grd0000644000176200001440000000066314160021141016164 0ustar liggesusers[general] creator=R package 'raster' created= 2010-04-16 14:57:47 [georeference] nrows=77 ncols=101 xmin=0 ymin=0 xmax=101 ymax=77 projection= +proj=merc +datum=WGS84 [data] datatype=FLT4S byteorder=little nbands=3 bandorder=BIL categorical=FALSE levels=NA minvalue=0:0:0 maxvalue=255:255:255 nodatavalue=-3.4e+38 [legend] legendtype= values= color= [description] layername=red:green:blue history= raster/inst/external/lux.prj0000644000176200001440000000021714160021141015664 0ustar liggesusersGEOGCS["GCS_WGS_1984",DATUM["D_WGS_1984",SPHEROID["WGS_1984",6378137,298.257223563]],PRIMEM["Greenwich",0],UNIT["Degree",0.017453292519943295]]raster/inst/external/lux.rds0000644000176200001440000011261614160021141015670 0ustar liggesusersŽ|I=*@2A"眣&ǁ$r9JCf`!'3 d6m޵^~;{}RwWWUWse2I"9e2WgxI*t8n8̥+ Jd!/W8x=M1m]I'͞5nI_hY,?|/mR"X>&bmĺ߆=fNxܢKx 4q)轢=qlm䴙 0u9>tҬiy={;iL`& omI N_}Yj6@/so869axsrvbS9 ؞7klK7=-vW;-;kӏ{͟)f9Ɋ%/s/+-Y▂%l'Ζ^.M'χ_EϹsf.2gv*Osq.ĻDzg^_ϓʸgT+6{ج93'u:͝?mc9#̙?伛Ue"hx&֩#e0A &6-&$uL;]>i\0QlM\sYġYELb3xb bG m &Zӕ]g1q+ "Yᯈ9(Пf,p>3 *ULp_=V3q\]եCM~<"LUL!PF5CdƖOp_U]9uC~31*@Adb6J&=;;& :߄/4fb%LddNء&9}^^k0| 3'Օlq L/{-lIn0. 9LlllWذB ^_^*ifb AŸ@p4|ڱsQ RYCX>{o&o ojǵn뱱+\Od#jP14\oWu,TvVۣ0)s;8ʦ6་dʭ]`>8ﵸq= [Llڡ]{΋~q0TCR`t:,s0Pkn|$T Nu5lV&T]=~ofh6z>vojdKx X(&=/ ƝIr U~>mwow(mD!K< +kIJ/U߬ʨ,VhR,0N~}jzZqh&:_6Y= U,LR|τrOOv0!LHM~ _xLy 8Px`]h,'+}V^dB\*m bD&ĸhY2 3!L6 =Usg&|`υŠv'YLx)Y{̄J|&?ߚ ~7~vtۻ1rp[>+z:&t]9Ba|Zo 1ru0Ř'pk] NG̛pS|ɄS? '2l~ p,ru$kTba=:Xv)dqL]=m~ńM]7\0 -l4 ke`6&l,ܰ +~688ń#;0aEeg0aO7h%c 2a$Y밺LXC3$;gL5dŒ*cLh gYvL=DWg8fjWߍj# 01h#2s[501 K)ϳm#L?)vsOٸ(8 : 1&}z_d@n:bFJUL؞Jݬń*Y xC0`4XTl t_l 2Aܒ5eL0 6L^„W%5Evx%,LvMS3\wia5]V?_yd*zҷ}L|+baw%'|+^Tu:hޕ\\ RFwЍvZWN3+~'\TV?іApY28\o"-q{QpkQ_[}-wH}s4$)l_*91̷lkm;[涪Ju?O.2n3RoJ{7k̘|KrIVWm)[*'QEm449o+>;E)-Rkp~^|^K\`N5%ֲfdsO(`s}l7o >v6f;ä"~_"~RU]30\3&{O+@"r&fL*HC&)7>%̌ m.st\opu~#V';&ׄ>aVۧ ՅLp<_Uތd@ t|d]>& kԹ7se[sLn]ff}hph}Ev7?>OHEmeN,/; ϛR EgY_a^|2KK8ςVٕ\]|}Y^&^'PLȤTr!~=Nj< s6we8^nMJ4!W~xHp< p/ˤ{Wڢ)y>7ݶOSpV.vjFV37~3 Όȯep6 N NUfunu*0hs0Q$h^)  7rf0V| ]țp)tqE,KK7('sj|Ӣ t@lxvP:iEjfBh\s`~yK\mp 7:a~d'ۙ_(gOXrra>ͻYp(*] YeEAπ+V:ρ΀+S2{t.ǧ,WU29TSq-`+E NCarzg\jN* _N/evg\[J:P$m{ ƂRdn|oRdJK-ᶼI m|nt8Kyw xW\aɔ8J5ց熍?%[K?lsv\<)U7~ s`QuPz(yƼF:xmE0 3a-Oo!2~&ǫ6/ s"`Wa㠝pTi|H&Ӆ}D_/>zنt>0N梀qEzg^ueZ 7G XbnVQ:Q?O|K7x*UNV-?|Kd?{U&뤥okr,Wd}KT`Wỵ-N彪п*u')2q, vN0F]Wa_ st 3MOAbso%@5w朅O7VÀo:SsOz!]~)vr'̙5kst#nkh/n͊Wݘ~R9߲~<ޅek+aiLELlz8f61NuL|fme}hVk11fbP`ޙ L :|Wv[%ʘ䕷ixp|8A|lxlɽ &Æ_ crqLÆL<$lN+TFm.J{ĢƼ>ù0=k?&̂~Ŗi$pu-xS˩sO6?6w<)+[+8+;k+#n|\{-7{0.+C14ol2`un|+L=_O 1^0GZTeff&z}uu{5(klQBWiP aeʡ?6zczsޯ-L)Wo bo0q%jQ1q{q 28*ðLʤL2q kZLQ٫g'o6y< 9zp^j,K&j5QLTQ?XBfv0~0cMX]}o5̓Q(~gTKm-#~ޛ8\PE+a<'W%<c#0qP'`IŷnL z=`b$a^=a;^mC0֭=|֤4}z^T*W&vx*m9[7QAh9ೣ>_ oX^xMPlle} bMdb<]~Xϡ}W[ GuR(&VNac@ӖL,<&/r 'jӇW|A(Dה5?e)naF@ ,Gٔ͞l<"caזƄj ]OpYo0!cqLUש#hP^(p6*qwv<˘k)|R- Y<(dm_Y٬~4eՊۙ7u^37Bf%x2O 9Ϊ>p9OM]W6|&غA5W_DP&՝.Mmg^~nWXB?uJ!O%_? X7u{X+M}bҁ[ R Ɇj{,.<\6\eu=Sԩa=S 7*VKkN,jos,-6XO {fh#uz9Z#7sg [kмnb ܯ6`]3y?ߦ.ląXea<.~hK`_[xeQx? $]@qO|:bR,W@NDHT9]vc?ooڥo¿VʊgRzU8XdyOJ\ *s?GK%@z:4'3S:/D}~򀤔X籤p>4.AC5p'R*'Jo,Cs@ORh7ĶW[#x] 6ω5)ƩjW/ җ!ڼqpyHJmQs} %Yi<3`Iw :?93v ׽8a̟R2Jɵn߻"J]{rEUaz|?8>n}RͦhyLJD$`\W"Y7KJa|ln1)5J`h!Vr>U{k ~x}*E`Hb/vɭBG@byXyk8K1W9ݡ,Td) SlET@ 8"V*Gj~{Ey<*ro O)vpPLhףR1mhgR;s3Řڱ:'gX=wBOQ񐀁ׄE]q'NyynOR&}v#hĵvB[J\Qb r 9`ߧHL@N(Hi 9Lp&22oRV|+%xևl;"%='(]BH(srXZ FX? OnM_ӳӬ⿙=@/%4b-Z⼖PBX(Sd&*n?{&>V 7= +(P-OhirWYKf>L~3  e.L|a)8 s)3kH%nW: =OYVş[z$Q<+<Ǭir-Ic5-78!3s0/&2?IE̳0hK|np_Ws,|>46C'J|kuj yx.hP=/BɖA.Eq 5<%! z[ޑH&lڒ_߮=vLJ@7> |L}"'ē[2_y' ̤c`yFW9{".%w<;3TRm5Oɜ9&%s]P!}auχ/d) `*7SX&}HiILβ)sZPkGsR3 ǔfՖ.[_>5^M}gwVqB<Gƽ?iԹ3~ژ{J?4|n!ARҸCJ/ouژTN14%}+} וW7KH `MNV1B.L6 ۷cJY]Lʨ\q0XdG $3p]̪x20Ghso@f. LPd^deUfRVYS;x? n,K*~fT.;Rv{1r}s~{u箇q̟9ivO H @$8  P@ $p  HA L8( CpA d@$@A < !ii)hSϟ|$,(BYL`ݓE?Wy\/qNթۮs[4mR3;Q,UYwa`)qvd#Rk=`}pLʲqBzV@\wfɸ`&suY'W39.e.B̎\L^vSe!qac9*epb^qP)Csጅ:CՋǍu<ӌ|fWJYzۅNҷ0ݲw~գ3̻3/Wx~ʹ0Ly!;.yQu50}E+wK_9k:#Ĺڒ'@7gg鸿Huc۴(mA,wHq+I^1z}JCeWZkfZ/?#Q-Q4_NհǭĖ< 6tN1/I{F&o p "2/̄W3-vUEwcxwOogw!!Y_qZα| yohu;vǫ 1Q%0ራ1YaybL8TĄXnL85׹ `yL8]yYpڀGAlwYghSńO3"ku?Ƅ7MϘp#v["n]֌ :(̄~v)3nov,LeƒL0^D1: _p^ExRu>&oh;^Tk2)[˅Lx3t-Ʉw\]%|8kr > ˁ,"yր}K),vH!n?t <)HOA{GǠ?D I D RH" RH "- RH"=!RH"MD!RAB$ 2DiC$:k=Lg&1֮ZӺIO4S ?){Vmky1ޚX-Tus_+ȕ(S6*Y'1ѧu`LXY &VdW./;M$X7ˊ:*Ep?*X[}xAv70ؒ8lvD'oW) O1!ܪJL:\wEX\VZW&dW[u$ZfxK/~&9+䮕թ oE=0"e!hl< Ysy&dsUxTn`BzWKyVHiʸ 69GZ &Ϝ|>o zTuAG-j[<=4 ~lLeg·T]#=pƤp=\ 2 +4|W z+~S_-\llS/mnYBui4gYqE$B#upaH_.ߨ\dV ?$*y:q5'bW[RGMa 9lֆϡÞ+BGGi`kY`{VK}n++ OüS .媛u:E`•P5kÛO`^^fxQώVԩM*~1 bf6uv|ݨ9<5TF)~J2Ʉe-7sa^UU>?5564°Ɛ*g1aJ y  ӿqjp5PC+L(f複3K7&xX k4j> GuN&|o_Vlʅ` Utx2xޘ$xV'V6ge @\&y62/2MWcc7`_@O>˗[l ӵwCƃ¬'];KʆaE{e:LXY^Pϟ .럮9i{MX汵\"Jn \Id޿l's.v3PpJc[albR/(Z>ߔrէVoPAzܾ.]TsjRaEt@"t & &&<&_`sQ63iujh)gH-:˖# D"UΜ)MR AF)= b"/M*U)`8lS)lBR!3R\lWKsiJŠn*KR/R:KG_"z3)s-;| YRx_~م}1 ;?U2=4uz<^'A^Ť<{EǷ~s\xȳ#<8>}x6҆8Y fY|@2E }٥&sʚCJƠ~2SNr|ɂ/C̞%}l/TyN?o2fF) p}iBȳ,jp% ]Z.H^}/YȳxRue<AJ]ΎT||ןa*SqLYiR*iyWn:I_tB:>/XDdk:/gŖ+i _yCL* R/ڳԟE9>glo zבnS<;>&O9T]d\*W4 rk 1*4&eD#LLMt,jD  ?E4Vebjc]LxaӖY:GaJ=;vB0C21C4QC6qC8C:CC@DB1DDQDFqD5Rn|#%)H)G9Rґv#%)HG=R򑲏~#% )I)HAR<$%")IHER2|$%$)#I)IIRRҡD%)1LTjr$')?I JPRr,%))OIJTRrl%+)_I KXR:u(kQiKQdERd)ESd9ETdIEUdYEVdiEWdyEXdEY8Oiq@d@d@ $KZ.0ɊS,R>.PW9ՀMV~y 䗱zLs)t^nQJ7bH~s*mQP<-塢)ItR.r?  Y܊DCfgH3 >\eRn2f#0Kb&s;G>tKG>u[>vk#;#_<#<#_=#=#_>#>#_?#?$_@ $@$_A !O!!!""O"&"*".:|ї|HHII#I3ICIJL1G:aQ:#= (}(((=(}(((=(}(()=郔NH酘nH釔H鉔H鋔H鍔H鏔鑔.HtJJtKJtLGz&ktNGz'{b'Rz(:G)K1ݔO)S)]WIiCR2:!%){HCR2B"%)HiD#R"2J\"%)HD'RB2R"%)HiE+Rb2ˡ"*HEJ/R~a*HIF2RhL#)HF6Rp#)HIG:Rڑxs(&cbY&gb&kb&ob‰'sb҉Y'wb≙'{b'/hBC횾LjC{޷ U*7y XU{BV9fU*t}aSm]LbrZзLrk'&nUP?RVТ4˲R3rx췬{"cGi&4+ -X\DD\t#G#9$DKDMOHt)Jt*Jt+TLQ:#=kLrsQz{Q*,(=̑.FcNenH?t4JOt5J_t6Jot7Jt8JsQQza9(](\HtAJ`#S"ECaE+R`"Z")Hᅊ/R9a#)HQF 3RiPC)L?)H8RȑbtE)0I <"zs(HG?R" )IQH CR"*IP4‘$E$)$I1I JRT’}b1H "H( )0NR(b hp(H@ RDB@E), R`"emhx_1m+>_ly~y?o,}~lUw'uY0f:k@8^Te=|߱RQz|J-y&/x% ,?e0G[#~Q6`_q9kW%)05[eѵmd,) p3P.M{g`mz26T>wݒwjjѲ;h2y;oӀ񛙼 '䭶["O6R Cc϶*){`\9(roe\loZ!UL>{G\7=b㋘L}3? =ɪԂyn Wz0UВW<0,i6)cGpK  -<^F,="x)+ץp ?i/R&ts)].c:Pei`ᏹwc8zkG<12׫)GpῘ<* _q(,noOy^)%4-LÖ=c8O.ɤ+WKޟ"1--S$z\FȜF[^TFnGoRzEߖh^N^/s#7 %ɇܳ3-uM[WFtFGhgR *H^I^I^MĠ yu:;˓=JޠHwKEkG\$Rw)y)y)z7+SKU^J^J^J^J^W%oX%X%oYxqϯtN>}.ɥϨ|{~~i9?9& /(}AKm{Q#),Qjg(kͿL(cӰo˩nV=D&yU6}^j-כ3 .M:0y ްXP,hljE<`(l("kZ 6w=JgPڻGhW/Qb_Ը/Oӿ\꛺ GLɧFjoXE&W4tJЖy_ue4'ul`6ްy$l?| W׬G8"$ 8u@,`) MO\a*qCYni58JYؼ_ͺ$|䤲C#xz"#6G+͚ 1Nh6bw-8pKNww?y:xW_omз-6x&{21e/\9&T-kqj+{= izܳI^k-\6W yzqPVw_n Axd.ŲuaLޥPYl9g Ÿ}}nFI\ĘcA'-EaQ T(2xC56XUIh(,zУ$`~$ n7# 33fxOֹe'}~C p?E<-Vz`1ǽy O GxphPfz}4FwCv"ɳG/@,p׏fcpWԖ7x||v`t E-e1hAQ<*I{#2%\c|mW8J& \lj nW"r&Vz#(V=7yOyq6TC ?HCfݏW8ro 5<⿋+1x+R̭A]ɜɍ0m3Vq&W @%SO@K8O `< #Wtg+JV2x{ \a 3 <`wt{\y>ߗ瘞9jϹSzt6=&.57\)c. y ~k/$ T().[<_g=6/EM=f? _7ym鿼cШ!0C  _Nu{Ǩɳt2HCI%1hI'1ĈCJ)1ĨJ+1CK-1K/1CL11(#L.7>%(=k:a>Th#jZ K*,MH(u>^ei<]SO2y&2_~V6H.<(@C sroyh>L椽 so=UI+SVv|M6@y{hHǡwXK,~yآL~Өͅ=B5]rܯ!L~֙K*~ _S[eSoي+Gj2F곭2aQ{%OpXA^ 񐤫t1k͗Tfa]?|ۘ"u򋣰k󓿦ca;]u?7ŴIM3miSMlt&6IM;miSӦ  (@A 2PЁ -(AA rPЃ  M(BA PЅ0 m(CA PЇ@@Wo]&#LWe&ؗLV]w^kB`i)-5iڧ/ra4> 6YbX2lj6n{dL&Q3qO =/w7G]L `sYNy@7ե=DUX؄?Mli0WY P^.WLoa>+oѫ1lFST`s1F .VyOoآlͦ'#wkn7L\`DF:? {W|HYz6L|5K3\&FŶuζ;L4/} ~Vê3kCL"WAWfn**Ը.Loz YՏ)`b5v7Qm4ڣ2_pNfL|hm4hà=>z@;Śjm0nD'~ܡ[&fb`l{&?W4+}ڳ?`}ʚ^әƒ%rz72GL]Zu-UW|>!E)DH1B R„'@!E )THB R…/!E )dH1C RԐ†7!E)tHC R‡?"E)H1D "RˆG)PD%Mp")HE )RLU")HE -RlO旘`b)&昘dbi&晘hb&lbL71Ą3L91&udډyw0Sb>1tOyp_G6ᘦ7sScV?GDRAɫ ax]Ƞd)t]$hp.$ w)e!h'#=k{(Bzחi8G `-5Ioe-h@TƤ/ry /Ky|}"#@Ȑ?G9Of\.~!3M#G0Kl(8E* ^Q0ܢ`(F1 QL( 9u`(Q0,t)HE 6bP$+)xrbp:C)8JR e#'Oy:V|s ~U _{I&MĴWҫt^uoz kLx/͛6Yoz[LczA{i[dt ;޽)`<_{ d*BWDŽ`%!X5,BS+d% K*!:+!I5FRφDia R/!`p&n챺Pq+X! y{}}#as(V Ӿk,r%[hU 6  a.#`p-G>rNU1HH? Yby7'>'4Ϗ20-ÇܞL4U\ApT D+lҸ̴e݂M}Gbcg|X0mЂW3$ *'HyP2:!%){HCT2ȡ")HYDJ#RɡLyء\"%)HD'RB2R"%)HiE+Rb2ZB%)J/R~ as(HIF2RhL#*HPҍo#e)okpkаݿ=> Wv]G/˩9K5fp8z:O`ɖ?`񱂉%>LtUDş[Du3{E&ڤTkZ#X^y-+r Re`]><瞋Zx&zܜ n*;Vfnba2!ڪf"cbCzIn:r~l&6#gbF)u*Odabk .x3n;Qmmc)r]76]?YY8^3X/Zsq(M׾nSU48fL̻S Gu|?D+?~f☱fL"qm}Ɛ#L7"l9s28 GR&R۹~K(Jо?,TvH`8S{33q`7&eA,I3~guxZ=' J߅:)(cMgU[rw/7cCu;K_%C_m&H;4eML5Tem_'`b}_"riĪ0?>Lw񗠽|C%ԫbٮƟ`ʄȮ/= 1!ܢlSo&|쨿-NbBzvT=ɄLx[|!^X!1E{>b.C*PRcyw0MV_fbi c\c{6T5p%>&B>pc*h&\WOƄK܊שּׂLX3^n0VqRHXZdhÊ_- ߡ̣MsI MWR}`TN7GXJ;'zB L(nzC; uB){51R~)ap!݃T fRK t;+^5p>A܋&$ў'R~/d:ZҞoc0Q*<(^O={a׻Z;5mŤ6mdxi$oʍ_g H1`o0oh7<}\zSZ`Y}[Ľ~io|po vA7yS_zC# Iiul 8@ٯ/^xytxZ[4J%ߢgV٧^K+t|coM#n=R^sRz-^vcҫJC1M&}v#?_~eYƬ|w/1m1%=_/{J/ZBɕk\ Lw 2рs4@ sLyKEL|Ez#`5uŊ&^A!*X Ug@Lw ep O<2cpÌf3*3Ό sW1k$3r#` 7XsIRp^9kP0U0XfF%y07y>n17/0sчdƪQf c)lG%^]XMO%@L+P揞l~\C?~x=r:a<%?|~XP}=_7jf @<+"fTXy/fh> &0O`=`W`'; o[NAh8mAUӐg+y<(STzMmg `|od7^b9 |Whp @zŃ0ޘ۱\'|;q%|^yo!{rȨ0,{H _lhOUUܨUyêoTQȨjV*ssTQ:$EUwTQ yJFU/s3Mkl69:mi3O{f7  (x@ .P+ fPp`G(XB Pp-|` g(XC Pp=`(XD# &QpM|`(XE+ fQp]`(XF3 Qpm|`#8Ӭ2\)E{)z+5U}@Ie0xJ XΎLXVZcbm1_ eUF=cbAV34׭تV؆{bmۧjuy؃++^%ØYݳ&)r&_Bq;U>d`&J\d [شߙطk `V)^~rEKeL<ph/ WxڂؿJL~ HWbu)vO_N{朙eoՔ+ ̹oW0q vu f!`KIƚI/Xb _ #;^k۶|+[!8Jx&>!ުԥqgšH 3?ck|l ,M ?:z8;M:Xէzz?fi,WDco(>%Q=Wb50@+ ^|04uɾ!9hh&FWiǵttvB<,WY+Lp@_cbkVkTm8'oLߙ<:%78yUqU¾~sT4ÆD֔5?)KxZXezބW?*"cjIhJ4xP8p~*+%@ј:<]D8߬BMc;'n15שLaO: $\LBDr86Oɑ91?||tj p*uԴqKaOM]:K/wzW~Oqn ,8oNstl ^P g_.2W3P* n+6A6uW->3.:B8⽶/ V!UIP*nz;eU1q&/!,P\tFi0f/34tqg%<P {Ĺ@8+Ĺzp>xqM&_^ӀM,7۴'k |o3shW CxZXRahWX.:l6%<!.qja+ĵ]5r^_p2q*g/lYV&(a'/#|dlHJy񨇩;x S_xu]5W'f+{s13>+aOk xڨ eixoSF.? c8nu6澃r4W3p+GO^Ө%p|y~|9W| jl7ny eMkC&zaWw_^.hDZj%WF۞+kKW)oB@Y6?^ߘvkw0oѾ)怬F)<(Ht|JϧttLk1uT"<;\UlIdnF3q5750&'-w}ac@ۼt޷N;क़ ;ٝ+n)ǭD;6y w0w :Hwы^{^2O缏i5&9L2ֱ쐌epw@ A6Z[]^ЈA"~[~TVj! *qf${FyYGQ9XH=^3)V|J&mt@8оޕB>]]߯Vi <Fԣ #GA@ RD")HAHGP &5)IAO RP4 *U)R-q)KA^ R_(h"SPt 4)HMAk bcP܎7)(NAr Stw)(OAz SǠ?D I8  13 q\yZ[2!)J֠&&[0?aFE.Aܨ\ ♓R%@4B&覺H q B& O2k֏jARV BeqP6AV~8m"5~n/# CP$zI“*p&ϟA Ay].>O=ldAvAx&CP{ͼ dDž3f81̌Of,XcFf^{!6̧H|.7ͼ0d~3,y%{$1CÌzx)\5c$])hE_?wX|@鴪$#,3p:1D#O"(D( CT"D $R H@"D$@&HDA Y!@Q4HA"D$ BH$B!2! PH"D,$j! ^HCɐhD4{$qnHChD<$!~PD HDC$"BQ#!(DJ$ZrPD"'DP("HDE*YDX$"HE.yD`$ #HDF2QF(eR(eRF)eR)eRF*fRъȀXʐYʠZʰ[\Х]ौ^_`a vdc1eS2e$S2e,S3e4S3ehPw \bе\ƂvY#B~-@!Aqt#&˂r?x<㯢*aQ R"qn_KU˪CC/~yS=mu^~/ YRցL[( t G1qO%6<<(0qPIŷn!&KL16bīNbⰊqYL.g;Gb6e2รS]}oLAof Ջ \B&j0j9VLPf^qzo89z 9Ld+ þ3qATqW~o{yW}S|}:AL\SZـ1&E6t]6d&7a X }lw([T68%Tyݙ{Ʀߘ󋡱+|n~+;X}uuBff&]kS'nZeW1b6 &^o˝]1S3xu<&^1d 9&Ӡpw52==x nY ><WVqD3/+f*Djs˙\f`ba|&-V^8wg\cFN&?ۢ'CZͱDď՗/ndD.jx&ƴ5ԩUN^vLdg;LR&vSgbj&JbRu2=ҐLGo3f_?pEFYVQĜ.O#ۣ2b˭sC1*#W2?l_L:d["{cMf&>yQʡ-L^曵]p&/_v W0jÛo+xV);`KUnBR&4;Lc ʎcnuɫd·j.ons:ry{J\~>_^=d*=3Yֱ?P* CEbh q"3TtPQ*RCEk "7TPQ*CEsա";TtPQ*CE{"??TQ *DECTZԋf$u#IHjHb] b# b3 bC!bSȯϙ/OoɏɯϚ/Ooɏɯϛ/OoɏO+'r$_NDN$_O[nwHe8PPMd<|a"rl^˃ V ]7Vi"` CGH؃ 7IτLegB Cِ LU1B2/#|bu- W ʆE! `6+*&/u--nnWKpGJ&d紐V_ws9@"\!cmD_+S!ϟB&/ (d~>pIU1Xk]/JL:\! ~rW c%~A~p߹茪HOWMIWg|7 zs4?q[AG/+XwKWP_4ey[,Be apw+܁u(pPld1ng^DyZ澀OԦoM?ɭpW?b yb}!x O4񄧬ӺI1֮Zx>nb0| ֕U&ut qk* #az`}Дf04EĖ# >;|Fv U1vwXdwXnvZmcc,%P6V"&nvî-qgs[JhW"s8&nW*&b2 Z\*%Ł18T`3g̀><6%2 OFq69%U&`sBiEрL7= EI| M)2Ou'` n StNTzz|tkZ7/N)%b"XL&-Ek^"˓H]4{ۙWN}5OYߘ˫*DOenà_FqT!HѼQ&f Xq92^o?"e5>EbZVY{ bVxT̲ ׂe*Cŀ8 ATL Q!G!d8X/bFT܈Q#,DőŒxSq%G%*DŘ8kMT SrPT, GQ1)Gq)*6EŧbP%P͐T5! E(EQ-rQ `sD(jFQ4QnE(jG׍&o&?p'p'?q();ɟ|}?__'vkw;OOE?yw͓<ѓ?=գ*:|Yѧ|[Ǖ|]?1杇+ N8Ix_׍I GFG\ /9 x’ )B4kUL9 /L3ycby}"j}jHDD$-"pLhX+2dW#DVQ#s#jo(MV kQnj93q=-'7S3w( s3L6xGv'{ ^W 1V܈bJńsn{ߏ%vȺav8󸟸qQ>q!_ih2Yɶ7{dr8 _7_)Gezk9Fq!spbBg %5Sa9hm'>`NG'>4Yoώy품ER;&낤|}!iڷV6=G=qFfΜ^]8gɔ[wiPC?s8lͤNsqC[u礋7raster/inst/external/test.grd0000644000176200001440000000102314160021141016010 0ustar liggesusers[general] creator=R package 'raster' created=2020-05-02 16:05:26 [georeference] nrows=115 ncols=80 xmin=178400 ymin=329400 xmax=181600 ymax=334000 projection=+proj=sterea +lat_0=52.1561605555556 +lon_0=5.38763888888889 +k=0.9999079 +x_0=155000 +y_0=463000 +datum=WGS84 +units=m +no_defs [data] datatype=FLT4S byteorder=little nbands=1 bandorder=BIL categorical=FALSE minvalue=138.707073391626 maxvalue=1736.05793034568 nodatavalue=-3.4e+38 [legend] legendtype= values= color= [description] layername=test raster/inst/external/lux.dbf0000644000176200001440000000565614160021141015640 0ustar liggesusersv  WID_1NNAME_1CPID_2NNAME_2CPAREAN 1.000000000000000Diekirch 1.000000000000000Clervaux 312.000000000000000 1.000000000000000Diekirch 2.000000000000000Diekirch 218.000000000000000 1.000000000000000Diekirch 3.000000000000000Redange 259.000000000000000 1.000000000000000Diekirch 4.000000000000000Vianden 76.000000000000000 1.000000000000000Diekirch 5.000000000000000Wiltz 263.000000000000000 2.000000000000000Grevenmacher 6.000000000000000Echternach 188.000000000000000 2.000000000000000Grevenmacher 7.000000000000000Remich 129.000000000000000 2.000000000000000Grevenmacher 12.000000000000000Grevenmacher 210.000000000000000 3.000000000000000Luxembourg 8.000000000000000Capellen 185.000000000000000 3.000000000000000Luxembourg 9.000000000000000Esch-sur-Alzette 251.000000000000000 3.000000000000000Luxembourg 10.000000000000000Luxembourg 237.000000000000000 3.000000000000000Luxembourg 11.000000000000000Mersch 233.000000000000000