[med-svn] [r-cran-raster] 04/06: New upstream version 2.5-8
Andreas Tille
tille at debian.org
Fri Oct 20 10:29:57 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-raster.
commit 3c895edd7e015eaa6079035d40acf2404d6519b9
Author: Andreas Tille <tille at debian.org>
Date: Fri Oct 20 12:27:38 2017 +0200
New upstream version 2.5-8
---
ChangeLog | 694 +++++++++++++++++
DESCRIPTION | 40 +
MD5 | 551 +++++++++++++
NAMESPACE | 11 +
R/AAAClasses.R | 319 ++++++++
R/GDALtransient.R | 123 +++
R/Geary.R | 73 ++
R/RGB.R | 131 ++++
R/RcppExports.R | 55 ++
R/addFiles.R | 31 +
R/addLayer.R | 65 ++
R/adjacency.R | 303 ++++++++
R/adjacent.R | 157 ++++
R/aggregate_3d.R | 467 ++++++++++++
R/aggregate_sp.R | 249 ++++++
R/alignExtent.R | 118 +++
R/animate.R | 38 +
R/approxNA.R | 104 +++
R/area.R | 279 +++++++
R/arith_sp.R | 40 +
R/artith.R | 375 +++++++++
R/as.array.R | 38 +
R/as.data.frame.R | 119 +++
R/as.logical.R | 108 +++
R/as.matrix.R | 46 ++
R/as.raster.R | 33 +
R/as.spatial.R | 78 ++
R/atan2.R | 43 ++
R/bands.R | 38 +
R/barplot.R | 34 +
R/bbox.R | 27 +
R/bilinearValue.R | 117 +++
R/bind.R | 369 +++++++++
R/blend.R | 131 ++++
R/blockSize.R | 42 +
R/boundaries.R | 136 ++++
R/boxplot.R | 59 ++
R/brick.R | 300 ++++++++
R/buffer.R | 96 +++
R/calc.R | 274 +++++++
R/canProcessInMemory.R | 70 ++
R/cellFromLine.R | 35 +
R/cellFromPolygon.R | 54 ++
R/cellRowCol.R | 92 +++
R/cellStats.R | 456 +++++++++++
R/cellValues.R | 77 ++
R/cellsFromExtent.R | 30 +
R/clamp.R | 60 ++
R/clearValues.R | 53 ++
R/click.R | 226 ++++++
R/clump.R | 136 ++++
R/clusterR.R | 241 ++++++
R/coerce.R | 443 +++++++++++
R/colortable.R | 16 +
R/commonDataType.R | 33 +
R/compare.R | 148 ++++
R/compareCRS.R | 75 ++
R/compare_Logical.R | 328 ++++++++
R/connection.R | 107 +++
R/contour.R | 74 ++
R/cor.R | 38 +
R/corLocal.R | 178 +++++
R/cover.R | 83 ++
R/coverBrick.R | 93 +++
R/coverPolygons.R | 138 ++++
R/crop.R | 104 +++
R/cropSpatial.R | 129 ++++
R/crosstab.R | 121 +++
R/cut.R | 82 ++
R/cv.R | 68 ++
R/dataProperties.R | 68 ++
R/dataType.R | 110 +++
R/density.R | 80 ++
R/destair.R | 48 ++
R/dim.R | 89 +++
R/direction.R | 77 ++
R/disaggregate.R | 121 +++
R/distance.R | 99 +++
R/distanceFromPoints.R | 46 ++
R/distanceRows.R | 70 ++
R/distanceToEdge.R | 28 +
R/dotdens.R | 59 ++
R/drawExtent.R | 31 +
R/drawPoly.R | 30 +
R/drivers.R | 36 +
R/dropLayer.R | 59 ++
R/erase.R | 94 +++
R/extend.R | 165 ++++
R/extension.R | 99 +++
R/extent.R | 197 +++++
R/extentUnion.R | 4 +
R/extract.R | 18 +
R/extractExtent.R | 81 ++
R/extractLines.R | 291 +++++++
R/extractPoints.R | 123 +++
R/extractPoints_sp.R | 68 ++
R/extractPolygons.R | 356 +++++++++
R/factor.R | 221 ++++++
R/filler.R | 34 +
R/fixDBFnames.R | 31 +
R/flip.R | 166 ++++
R/flowpath.R | 67 ++
R/focal.R | 313 ++++++++
R/focalFun.R | 70 ++
R/focalWeight.R | 93 +++
R/fourCellsFromXY.R | 15 +
R/frbind.R | 84 ++
R/freq.R | 153 ++++
R/fullFileName.R | 21 +
R/gainoffset.R | 76 ++
R/gdal.R | 36 +
R/gdalFormats.R | 108 +++
R/geom.R | 94 +++
R/getData.R | 422 ++++++++++
R/getValues.R | 95 +++
R/getValuesBlock.R | 213 ++++++
R/getValuesFocal.R | 120 +++
R/getValuesRows.R | 138 ++++
R/gridDistance.R | 197 +++++
R/gridDistance2.R | 71 ++
R/hdr.R | 78 ++
R/hdrBIL.R | 51 ++
R/hdrBov.R | 32 +
R/hdrEnvi.R | 57 ++
R/hdrErdasRaw.R | 51 ++
R/hdrIDRISI.R | 57 ++
R/hdrPRJ.R | 24 +
R/hdrRaster.R | 101 +++
R/hdrSAGA.R | 51 ++
R/hdrVRT.R | 82 ++
R/hdrWorldFile.R | 18 +
R/head.R | 85 +++
R/hillShade.R | 25 +
R/hist.R | 101 +++
R/idwValue.R | 55 ++
R/image.R | 45 ++
R/imageplot.R | 232 ++++++
R/imageplot2.R | 271 +++++++
R/index.R | 156 ++++
R/indexReplace.R | 183 +++++
R/indexReplaceBrick.R | 277 +++++++
R/inifile.R | 91 +++
R/init.R | 105 +++
R/intDataType.R | 94 +++
R/interpolate.R | 199 +++++
R/intersect.R | 64 ++
R/intersect_sp.R | 319 ++++++++
R/is.na.R | 129 ++++
R/isLonLat.R | 122 +++
R/kernelDens.R | 36 +
R/kml.R | 108 +++
R/kml_multiple.R | 128 ++++
R/labels.R | 43 ++
R/layerStats.R | 104 +++
R/layerize.R | 178 +++++
R/localFun.R | 44 ++
R/makeProjString.R | 72 ++
R/makeRasterList.R | 70 ++
R/mask.R | 674 ++++++++++++++++
R/match.R | 30 +
R/math.R | 198 +++++
R/maxDataType.R | 12 +
R/mean.R | 233 ++++++
R/merge.R | 439 +++++++++++
R/metadata.R | 28 +
R/minValue.R | 160 ++++
R/modal.R | 68 ++
R/modalRaster.R | 47 ++
R/moran.R | 67 ++
R/mosaic.R | 170 +++++
R/movingFun.R | 36 +
R/multiCore.R | 95 +++
R/naValue.R | 42 +
R/names.R | 98 +++
R/ncell.R | 32 +
R/nchar.R | 7 +
R/netCDFread.R | 198 +++++
R/netCDFreadCells.R | 174 +++++
R/netCDFtoRasterCD.R | 342 +++++++++
R/netCDFtoRasterGMT.R | 41 +
R/netCDFtoStack.R | 51 ++
R/netCDFutil.R | 123 +++
R/netCDFwriteCD.R | 256 +++++++
R/newPLot.R | 171 +++++
R/nlayers.R | 45 ++
R/notused.R | 45 ++
R/nsidcICE.R | 57 ++
R/origin.R | 62 ++
R/overlay.R | 209 +++++
R/pairs.R | 46 ++
R/persp.R | 29 +
R/plot.R | 154 ++++
R/plot2rasters.R | 174 +++++
R/plotCT.R | 92 +++
R/plotExent.R | 28 +
R/plotRGB.R | 131 ++++
R/plotRaster.R | 82 ++
R/plotRaster2.R | 55 ++
R/pointdistance.R | 148 ++++
R/predict.R | 238 ++++++
R/print.R | 146 ++++
R/progressBar.R | 67 ++
R/project.R | 59 ++
R/projectRaster.R | 374 +++++++++
R/projection.R | 109 +++
R/properties.R | 61 ++
R/quad.R | 43 ++
R/quantile.R | 39 +
R/randomize.R | 18 +
R/range.R | 74 ++
R/raster.R | 482 ++++++++++++
R/rasterFromASCII.R | 124 +++
R/rasterFromBIL.R | 197 +++++
R/rasterFromCells.R | 28 +
R/rasterFromFile.R | 129 ++++
R/rasterFromGDAL.R | 308 ++++++++
R/rasterFromIDRISI.R | 89 +++
R/rasterFromRasterFile.R | 285 +++++++
R/rasterFromSAGA.R | 98 +++
R/rasterFromSurferFile.R | 116 +++
R/rasterFromXYZ.R | 95 +++
R/rasterOptions.R | 609 +++++++++++++++
R/rasterToPoints.R | 94 +++
R/rasterToPolygons.R | 111 +++
R/rasterize.R | 65 ++
R/rasterizeLines.R | 366 +++++++++
R/rasterizePoints.R | 234 ++++++
R/rasterizePointsNGB.R | 22 +
R/rasterizePolygons.R | 587 ++++++++++++++
R/rasterizePolygons3.R | 200 +++++
R/ratify.R | 134 ++++
R/read.R | 67 ++
R/readAscii.R | 66 ++
R/readCells.R | 252 ++++++
R/readRasterBrick.R | 203 +++++
R/readRasterLayer.R | 170 +++++
R/reclassify.R | 120 +++
R/rectify.R | 26 +
R/replaceProperties.R | 54 ++
R/resample.R | 168 ++++
R/resolution.R | 34 +
R/rotate.R | 61 ++
R/roundExtent.R | 37 +
R/rowMinMax.R | 19 +
R/rowSums.R | 97 +++
R/sampleAlong.R | 103 +++
R/sampleInt.R | 54 ++
R/sampleRandom.R | 204 +++++
R/sampleRegular.R | 246 ++++++
R/sampleStratified.R | 127 +++
R/scale.R | 44 ++
R/scalebar.R | 144 ++++
R/select.R | 134 ++++
R/setCV.R | 30 +
R/setExtent.R | 67 ++
R/setFileExt.R | 49 ++
R/setMinMax.R | 108 +++
R/setValues.R | 256 +++++++
R/setZ.R | 32 +
R/shift.R | 74 ++
R/show.R | 300 ++++++++
R/shp.R | 74 ++
R/simplifyPols.R | 26 +
R/slopeAspect.R | 107 +++
R/speasy.R | 58 ++
R/spplot.R | 56 ++
R/stack.R | 245 ++++++
R/stackApply.R | 104 +++
R/stackFile.R | 56 ++
R/stackQuick.R | 123 +++
R/stackSelect.R | 84 ++
R/stretch.R | 95 +++
R/subs.R | 173 +++++
R/subset.R | 134 ++++
R/summary-methods.R | 98 +++
R/summary.R | 79 ++
R/symdif.R | 37 +
R/terrain.R | 143 ++++
R/text.R | 133 ++++
R/tmpFile.R | 140 ++++
R/tmppath.R | 24 +
R/transpose.R | 80 ++
R/trim.R | 113 +++
R/union.R | 32 +
R/union_sp.R | 94 +++
R/unique.R | 95 +++
R/unstack.R | 26 +
R/update.R | 553 ++++++++++++++
R/validCell.R | 26 +
R/values.R | 40 +
R/weighted.mean.R | 71 ++
R/which.R | 66 ++
R/which.max.R | 125 +++
R/whiches.max.R | 120 +++
R/writeAllAscii.R | 49 ++
R/writeAllGDAL.R | 31 +
R/writeAllRaster.R | 89 +++
R/writeRaster.R | 237 ++++++
R/writeStartStop.R | 123 +++
R/writeStartStopAscii.R | 66 ++
R/writeStartStopGDAL.R | 77 ++
R/writeStartStopRaster.R | 153 ++++
R/writeValues.R | 223 ++++++
R/xyCell.R | 151 ++++
R/xyMinMax.R | 88 +++
R/xyResolution.R | 53 ++
R/xyValuesBuffer.R | 225 ++++++
R/zApply.R | 20 +
R/zonal.R | 341 +++++++++
R/zoom.R | 72 ++
R/zzz.R | 13 +
build/vignette.rds | Bin 0 -> 288 bytes
debian/README.test | 8 -
debian/changelog | 6 -
debian/compat | 1 -
debian/control | 27 -
debian/copyright | 60 --
debian/docs | 2 -
debian/examples | 1 -
debian/rules | 3 -
debian/source/format | 1 -
debian/tests/control | 3 -
debian/tests/run-unit-test | 19 -
debian/watch | 2 -
inst/doc/Raster.R | 366 +++++++++
inst/doc/Raster.Rnw | 566 ++++++++++++++
inst/doc/Raster.pdf | Bin 0 -> 336013 bytes
inst/doc/functions.R | 343 +++++++++
inst/doc/functions.Rnw | 416 ++++++++++
inst/doc/functions.pdf | Bin 0 -> 148993 bytes
inst/doc/rasterfile.Rnw | 141 ++++
inst/doc/rasterfile.pdf | Bin 0 -> 95427 bytes
inst/external/countries.csv | 257 +++++++
inst/external/countries.rds | Bin 0 -> 8938 bytes
inst/external/lux.dbf | Bin 0 -> 2821 bytes
inst/external/lux.prj | 1 +
inst/external/lux.shp | Bin 0 -> 64692 bytes
inst/external/lux.shx | Bin 0 -> 196 bytes
inst/external/rlogo.grd | 28 +
inst/external/rlogo.gri | Bin 0 -> 93324 bytes
inst/external/test.grd | 28 +
inst/external/test.gri | Bin 0 -> 36800 bytes
man/Arith-methods.Rd | 75 ++
man/Compare-methods.Rd | 47 ++
man/Extent-class.Rd | 45 ++
man/KML.Rd | 60 ++
man/Logic-methods.Rd | 58 ++
man/Math-methods.Rd | 40 +
man/NAvalue.Rd | 45 ++
man/RGB.Rd | 45 ++
man/Raster-classes.Rd | 89 +++
man/Summary-methods.Rd | 45 ++
man/addLayer.Rd | 43 ++
man/adjacent.Rd | 71 ++
man/aggregate.Rd | 90 +++
man/alignExtent.Rd | 44 ++
man/animate.Rd | 42 +
man/approxNA.Rd | 62 ++
man/area.Rd | 45 ++
man/as.data.frame.Rd | 61 ++
man/as.list.Rd | 34 +
man/as.logical-methods.Rd | 40 +
man/as.matrix.Rd | 66 ++
man/as.raster.Rd | 40 +
man/atan2.Rd | 34 +
man/autocor.Rd | 68 ++
man/bands.Rd | 42 +
man/barplot.Rd | 46 ++
man/bind.Rd | 63 ++
man/blockSize.Rd | 43 ++
man/boundaries.Rd | 44 ++
man/boxplot.Rd | 47 ++
man/brick.Rd | 105 +++
man/buffer.Rd | 47 ++
man/calc.Rd | 154 ++++
man/cellFrom.Rd | 85 +++
man/cellStats.Rd | 54 ++
man/cellsFromExtent.Rd | 42 +
man/clamp.Rd | 43 ++
man/clearValues.Rd | 39 +
man/click.Rd | 66 ++
man/clump.Rd | 43 ++
man/cluster.Rd | 116 +++
man/colortable.Rd | 35 +
man/compare.Rd | 52 ++
man/compareCRS.Rd | 45 ++
man/contour.Rd | 37 +
man/coordinates.Rd | 68 ++
man/corLocal.Rd | 74 ++
man/cover.Rd | 63 ++
man/crop.Rd | 67 ++
man/crosstab.Rd | 55 ++
man/cut.Rd | 40 +
man/cv.Rd | 38 +
man/dataType.Rd | 64 ++
man/datasource.Rd | 56 ++
man/density.Rd | 36 +
man/dimensions.Rd | 49 ++
man/direction.Rd | 45 ++
man/disaggregate.Rd | 44 ++
man/distance.Rd | 52 ++
man/distanceFromPoints.Rd | 39 +
man/draw.Rd | 34 +
man/drawExtent.Rd | 36 +
man/erase.Rd | 44 ++
man/extend.Rd | 62 ++
man/extension.Rd | 43 ++
man/extent.Rd | 60 ++
man/extract.Rd | 169 ++++
man/extractIndex.Rd | 71 ++
man/extremeValues.Rd | 51 ++
man/factor.Rd | 118 +++
man/filename.Rd | 31 +
man/filledContour.Rd | 33 +
man/flip.Rd | 43 ++
man/flowpath.Rd | 39 +
man/focal.Rd | 123 +++
man/focalWeight.Rd | 34 +
man/freq.Rd | 53 ++
man/gainoffset.Rd | 50 ++
man/geom.Rd | 44 ++
man/getData.Rd | 76 ++
man/getValues.Rd | 58 ++
man/getValuesBlock.Rd | 54 ++
man/getValuesFocal.Rd | 48 ++
man/gridDistance.Rd | 60 ++
man/hdrFiles.Rd | 39 +
man/headtail.Rd | 49 ++
man/hillShade.Rd | 50 ++
man/hist.Rd | 51 ++
man/image.Rd | 46 ++
man/iniFile.Rd | 34 +
man/init.Rd | 52 ++
man/interpolate.Rd | 135 ++++
man/intersect.Rd | 95 +++
man/isLonLat.Rd | 42 +
man/layerStats.Rd | 64 ++
man/layerize.Rd | 46 ++
man/localFun.Rd | 60 ++
man/mask.Rd | 66 ++
man/match.Rd | 49 ++
man/merge.Rd | 65 ++
man/metadata.Rd | 61 ++
man/modal.Rd | 37 +
man/mosaic.Rd | 70 ++
man/movingFun.Rd | 43 ++
man/names.Rd | 52 ++
man/ncell.Rd | 59 ++
man/nlayers.Rd | 44 ++
man/origin.Rd | 42 +
man/overlay.Rd | 94 +++
man/pairs.Rd | 49 ++
man/persp.Rd | 42 +
man/plot.Rd | 145 ++++
man/plotRGB.Rd | 59 ++
man/pointdistance.Rd | 49 ++
man/predict.Rd | 181 +++++
man/programming.Rd | 70 ++
man/projectRaster.Rd | 115 +++
man/projection.Rd | 60 ++
man/properties.Rd | 42 +
man/quantile.Rd | 41 +
man/raster-package.Rd | 377 +++++++++
man/raster.Rd | 167 ++++
man/rasterFromCells.Rd | 42 +
man/rasterFromXYZ.Rd | 46 ++
man/rasterOptions.Rd | 65 ++
man/rasterTmpFile.Rd | 63 ++
man/rasterToContour.Rd | 41 +
man/rasterToPoints.Rd | 44 ++
man/rasterToPolygons.Rd | 46 ++
man/rasterize.Rd | 175 +++++
man/readAll.Rd | 36 +
man/reclassify.Rd | 57 ++
man/rectify.Rd | 36 +
man/replacement.Rd | 67 ++
man/resample.Rd | 49 ++
man/resolution.Rd | 54 ++
man/rotate.Rd | 42 +
man/rotated.Rd | 34 +
man/round.Rd | 57 ++
man/roundExtent.Rd | 39 +
man/rowFromCell.Rd | 47 ++
man/rowSums.Rd | 45 ++
man/sampleInt.Rd | 35 +
man/sampleRandom.Rd | 50 ++
man/sampleRegular.Rd | 44 ++
man/sampleStratified.Rd | 48 ++
man/saveStack.Rd | 48 ++
man/scale.Rd | 36 +
man/scalebar.Rd | 47 ++
man/select.Rd | 73 ++
man/setExtent.Rd | 45 ++
man/setMinMax.Rd | 41 +
man/setValues.Rd | 62 ++
man/shapefile.Rd | 53 ++
man/shift.Rd | 47 ++
man/slopeAspect.Rd | 30 +
man/spEasy.Rd | 46 ++
man/spplot.Rd | 60 ++
man/stack.Rd | 66 ++
man/stackApply.Rd | 50 ++
man/stackSelect.Rd | 46 ++
man/strech.Rd | 41 +
man/subset.Rd | 57 ++
man/substitute.Rd | 62 ++
man/summary.Rd | 32 +
man/symdif.Rd | 49 ++
man/terrain.Rd | 93 +++
man/text.Rd | 57 ++
man/transpose.Rd | 37 +
man/trim.Rd | 49 ++
man/union.Rd | 67 ++
man/unique.Rd | 42 +
man/unstack.Rd | 39 +
man/update.Rd | 68 ++
man/validCell.Rd | 40 +
man/validNames.Rd | 31 +
man/weighted.mean.Rd | 61 ++
man/which.Rd | 57 ++
man/which.minmax.Rd | 65 ++
man/writeFormats.Rd | 45 ++
man/writeRaster.Rd | 118 +++
man/writeValues.Rd | 91 +++
man/xyFromCell.Rd | 65 ++
man/zApply.Rd | 45 ++
man/zonal.Rd | 60 ++
man/zoom.Rd | 46 ++
man/zvalues.Rd | 40 +
src/RcppExports.cpp | 188 +++++
src/aggregate.c | 153 ++++
src/aggregate_get.c | 73 ++
src/bilinear.cpp | 35 +
src/broom.c | 209 +++++
src/cellRowCol.cpp | 29 +
src/clamp.c | 52 ++
src/direction.c | 131 ++++
src/dist_util.c | 148 ++++
src/dist_util.h | 16 +
src/distance.c | 58 ++
src/edge.c | 100 +++
src/focal_fun.c | 124 +++
src/focal_get.c | 61 ++
src/focal_sum.c | 169 ++++
src/geodesic.c | 1781 +++++++++++++++++++++++++++++++++++++++++++
src/geodesic.h | 804 +++++++++++++++++++
src/geolib.c | 72 ++
src/getPolygons.cpp | 94 +++
src/intersect.c | 66 ++
src/intersect.h | 1 +
src/layerize.c | 56 ++
src/modal.cpp | 79 ++
src/pointinpoly.c | 300 ++++++++
src/ppmin.cpp | 158 ++++
src/reclass.c | 192 +++++
src/solar.c | 156 ++++
src/terrain.c | 410 ++++++++++
src/util.c | 32 +
src/util.h | 15 +
src/wirth.c | 46 ++
src/xyCell.cpp | 168 ++++
vignettes/Raster.Rnw | 566 ++++++++++++++
vignettes/functions.Rnw | 416 ++++++++++
vignettes/rasterfile.Rnw | 141 ++++
564 files changed, 59276 insertions(+), 133 deletions(-)
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..481e6e9
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,694 @@
+--- to do
+focal for multi-layer objects
+step-size option for focal
+support for RasterQuad (4 dimensional) objects
+add equivalent to "subsWithNA" to reclassify
+move rasterize/(lines, polygons) to C
+function for affine transformation
+add AMSR-E ice products and other raw binary products
+add orientation fixes for AVISO currents and similar NetCDFs lacking metadata on the internal CRS
+add VRT output to saveStack
+Fix lines falling between the cracks in extract (calling rasterzeLines): https://stat.ethz.ch/pipermail/r-sig-geo/2014-May/020973.html
+allow setting a 'spatial window'
+
+--- current version
+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
+
+--- 19-December-2015, version: 2.5-2
+Big 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 Lo�c 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 Perpi�an 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 Lo�c 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 Perpi�an 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 calander 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 Perpi�an 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 J�r�me Gu�lat
+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 Cl�ment 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 Perpi�an 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
+new slot 'z' in Raster* objects to (somewhat) formalize management of time series. Is to replace the 'zvalue' slot
+new function zApply (by Oscar Perpi�an 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 H�ring)
+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 Perpi��n 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 simplications 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 Sp�nola), 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 at gain and @data at 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
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..385907c
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,40 @@
+Package: raster
+Type: Package
+Title: Geographic Data Analysis and Modeling
+Version: 2.5-8
+Date: 2016-05-31
+Depends: methods, sp (>= 1.2-0), R (>= 3.0.0)
+Suggests: rgdal (>= 0.9-1), rgeos (>= 0.3-8), ncdf4, igraph, tcltk,
+ parallel, rasterVis
+LinkingTo: Rcpp
+Imports: Rcpp
+Authors at R: c(
+ person("Robert J.", "Hijmans", role = c("cre", "aut"), email = "r.hijmans at gmail.com"),
+ person("Jacob", "van Etten", role = "ctb"),
+ person("Joe", "Cheng", role = "ctb"),
+ person("Matteo", "Mattiuzzi", role = "ctb"),
+ person("Michael", "Sumner", role = "ctb"),
+ person("Jonathan A.", "Greenberg", role = "ctb"),
+ person("Oscar", "Perpinan Lamigueiro", role = "ctb"),
+ person("Andrew", "Bevan", role = "ctb"),
+ person("Etienne B.", "Racine", role = "ctb"),
+ person("Ashton", "Shortridge", role = "ctb"))
+Description: Reading, writing, manipulating, analyzing and modeling of gridded spatial data. The package implements basic and high-level functions. Processing of very large files is supported.
+License: GPL (>= 3)
+URL: http://cran.r-project.org/package=raster
+ByteCompile: TRUE
+NeedsCompilation: yes
+Packaged: 2016-05-31 23:09:23 UTC; rhijmans
+Author: Robert J. Hijmans [cre, aut],
+ Jacob van Etten [ctb],
+ Joe Cheng [ctb],
+ Matteo Mattiuzzi [ctb],
+ Michael Sumner [ctb],
+ Jonathan A. Greenberg [ctb],
+ Oscar Perpinan Lamigueiro [ctb],
+ Andrew Bevan [ctb],
+ Etienne B. Racine [ctb],
+ Ashton Shortridge [ctb]
+Maintainer: Robert J. Hijmans <r.hijmans at gmail.com>
+Repository: CRAN
+Date/Publication: 2016-06-02 18:31:24
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..33cb7a5
--- /dev/null
+++ b/MD5
@@ -0,0 +1,551 @@
+9a5e390eb536579c5839b3b0db181d72 *ChangeLog
+6f8940b992c646c467f49645bfae2069 *DESCRIPTION
+2caa26b3ce357d070c40fda829f8c7c4 *NAMESPACE
+2a5b959a5312693f06e67a78d5a6aca9 *R/AAAClasses.R
+ce2b1417f64dc9d2edc50e6bdd727677 *R/GDALtransient.R
+f180fcae52d642edc8730beda1ac1b99 *R/Geary.R
+2d4cd8898df0c27e470528bb6b604bc3 *R/RGB.R
+59516d5fb71d02ed278aba3870d3f3db *R/RcppExports.R
+a3d7863b67d7082a38f2950d6506d588 *R/addFiles.R
+1c6001cfc30178c706021870321af53b *R/addLayer.R
+9a416b217b36aa4d7ef0343e54d9d491 *R/adjacency.R
+55e0168e29c7665f009dd7ea7e30dc8a *R/adjacent.R
+e72d58c046b55ba61d0820c1907cf5ce *R/aggregate_3d.R
+b40a397d156c05c35ba692fbbbea98eb *R/aggregate_sp.R
+dd685617a2a08b296420d52788d7f923 *R/alignExtent.R
+1549fc61f14236f44bdec20a4b0b57bb *R/animate.R
+634c35e3155f202414027cadbc27e8d8 *R/approxNA.R
+c8ebdad41ce0b31b605f8e7cbb20baa6 *R/area.R
+bf04afcad4358556c49107a1520fa4de *R/arith_sp.R
+8309dcdde0e018cc4af47ffacf48fe73 *R/artith.R
+223a73282a5b7abf959de7591e3f782d *R/as.array.R
+fd3d46d6e21f9dc2e7f58fa1117365c5 *R/as.data.frame.R
+d8bf63eb2aa46c73b4262465e9bf0f8f *R/as.logical.R
+69ac4322db0e04a858126f25e2615aa6 *R/as.matrix.R
+5e89b3f75c4989294817992ce45f924a *R/as.raster.R
+eb90d83391dc29673df6b9da3dfa7331 *R/as.spatial.R
+9d954231737e1844ef48c1e03136b9ed *R/atan2.R
+2c3454d4cf365032e2b10684f9371eea *R/bands.R
+e3b004d9d3833578ffc72fae4dd5d8e4 *R/barplot.R
+ba963c932c85fc9268df2b23e1d124d1 *R/bbox.R
+5d108b47afa8efcbf0f520a6ab98143e *R/bilinearValue.R
+8b9e8bf809c47c2fa02b8e5c317e93b4 *R/bind.R
+d8ef8184c0597963bc5b394514779f80 *R/blend.R
+6c0013773548bde0b370b085caf5492a *R/blockSize.R
+071de3f0e5d040d9331b4f586c58e8f0 *R/boundaries.R
+74bbf54a95a064af65303ed1a29e986e *R/boxplot.R
+99d681803e480f1ce724eb318df3c101 *R/brick.R
+744f22f0804a2db5e679b6cc13298cac *R/buffer.R
+6976a8582d6bfc5bfb5ee8c5e96f4730 *R/calc.R
+01090018424c417f4ae431db421ef5ba *R/canProcessInMemory.R
+f3e08c626da8c736c30e3e13b72dd71c *R/cellFromLine.R
+6d1dcf8924368bf706c4f871913d292d *R/cellFromPolygon.R
+5dc8c37666a53fb07acaf70bdfb32a54 *R/cellRowCol.R
+68b71e7847d9127630bb2330d1b07889 *R/cellStats.R
+ded16172bb9a2a8eb2d114c3204d8ea6 *R/cellValues.R
+f86cc146c3a6c8f0f58be7c50a7b9a35 *R/cellsFromExtent.R
+b17b3a6ca911b8efd755df57f7414395 *R/clamp.R
+5289fa90f9f43bead14a186206a4a87b *R/clearValues.R
+561e9ca06030b320bfa5a82e143c9e28 *R/click.R
+8bd91e5da159773fb2ac68b65256cf54 *R/clump.R
+351b50b3f150e45d47a551b7b71ee7d5 *R/clusterR.R
+3e9371c843e5fa2e462c0f66b0804bd9 *R/coerce.R
+f1670f8661d7b88ab58e624cf6b9fd16 *R/colortable.R
+f6d126480109fc7634a8315b08dbf1c1 *R/commonDataType.R
+36cb51a05964ee2a460531cf2da5d65c *R/compare.R
+f0465e330c110020de7b878b6d54e115 *R/compareCRS.R
+f1b5704b4cdb92f3c9bd97ae2c2de1a2 *R/compare_Logical.R
+a290223935e80896d36675beabe177c5 *R/connection.R
+6f5fcc1f179441b5e94646e322e32bb6 *R/contour.R
+3683aa76f6958a3d6f862b4854b1925f *R/cor.R
+c44f02dac5ed1513104a937e333558e7 *R/corLocal.R
+3112262f0e64a4e969cb7af230196c5b *R/cover.R
+6ccadc53c774cd6b62936b422675909b *R/coverBrick.R
+f0bca315dbad97aa6125f1574e479d32 *R/coverPolygons.R
+9ae0b1677a3377c4097da9f1b18b5bde *R/crop.R
+9eba96fcead00c6c96094c373c306443 *R/cropSpatial.R
+b4fc69fd701e8bd685674d5cadd748b1 *R/crosstab.R
+d483e19e1a87f84fe5b8a396e4798385 *R/cut.R
+f67450ded7249f479ba4173d37bf555b *R/cv.R
+d8b805b93266a263e92f4c61f2d514f2 *R/dataProperties.R
+d03ce2e928004c4bd6c39a08f0fe4eab *R/dataType.R
+13cacffd8d9d96b4d19e3ada4ef058c8 *R/density.R
+8da912ebbd9be8b5a3292f6ea58e1bb1 *R/destair.R
+3569502b06ca9dd4ff0bed5e1b2de97e *R/dim.R
+a944bf4cdbd26469761e231318fea131 *R/direction.R
+0ad4f17e10f1908c44815b0b656db1e3 *R/disaggregate.R
+99f59a2afcea93ed7cc35840e20e3f31 *R/distance.R
+cfd4f010f7dc39c5932035e1c756e6eb *R/distanceFromPoints.R
+5146e223f08bba9b0adf4a111cee9b56 *R/distanceRows.R
+356c0143144007aeb2ec36dd8d484100 *R/distanceToEdge.R
+560b1acf051543f69d3511987797d162 *R/dotdens.R
+77f4a35b2e283a261c13e43d24ed6d88 *R/drawExtent.R
+963896ffa2d3e68b8a28c0b7c596fae4 *R/drawPoly.R
+a2be44b8b3b744ba279ee3b6bd59bf94 *R/drivers.R
+28d4608948b3e427ca4e442cf212d1be *R/dropLayer.R
+206876c029551f0f1c3d0a9f44732762 *R/erase.R
+916d33820ef98ccf0e27287d2151745c *R/extend.R
+583ba01185bea1b4f9bb99df9e4d26fb *R/extension.R
+aa033c3f988f84f778f50ad1b75c4ca0 *R/extent.R
+8139e117ac8136b28d291b9fb7bbbd63 *R/extentUnion.R
+ef34c86d2141390de40d1b0bc55883d2 *R/extract.R
+72059da5ec2ee8ab387e8e827a287262 *R/extractExtent.R
+8ff696fe8930f14eb6f66307087829e3 *R/extractLines.R
+8659418089430bf38bed72b1a9569d0c *R/extractPoints.R
+3007aca6abd178e45e0ad92d85ac1b8c *R/extractPoints_sp.R
+e5a5724ff79276db151e2a595f4eead7 *R/extractPolygons.R
+ff7d909f77aad3c2fa8a5e082e4d1e47 *R/factor.R
+65f4a18f3c138c4bc4d5330a924bc03b *R/filler.R
+0bfc093404ba39a48e5674ca43340a06 *R/fixDBFnames.R
+8406361ecd9e7d068b728e65cfa07bc5 *R/flip.R
+9c0ebeceb09632195710f8987e9ce1e4 *R/flowpath.R
+dd6a196e333ad0b6f18e9dfac2bc8cfe *R/focal.R
+b185ebd78ade2717268f47da9dfbddef *R/focalFun.R
+17a8d02df9ad576fce60396e66368319 *R/focalWeight.R
+8a3d52c8ae0c450e7ff7437a71be45fe *R/fourCellsFromXY.R
+b33d32af14b1c2134efdf9600d57bc08 *R/frbind.R
+ec88009c5f0054120ac2f5f63ac7f984 *R/freq.R
+d650e91fdce1bfee15349da3938547fc *R/fullFileName.R
+473743a1707348b5ce3587eb19b8e076 *R/gainoffset.R
+18847d5573410274724a269724541910 *R/gdal.R
+7c3b5f5949596733e6cb33195b9c75d5 *R/gdalFormats.R
+800f3e7eb24d526bd1c3ea9f0f63a58b *R/geom.R
+a63313b6e537ea53a1f4aced6b2849ba *R/getData.R
+ad5efa6cea7613327143516443a2a6fc *R/getValues.R
+d7ad2acc36386ef9df82345b2dda90ea *R/getValuesBlock.R
+6bcdd37868a10c46b415aebcd6cf05da *R/getValuesFocal.R
+be2a963fbc39eac5de60bf56488dcb43 *R/getValuesRows.R
+dccfdf7f21d32422bdb753aa4f2d2d46 *R/gridDistance.R
+4a4f36edfba4100922a8ac582120bc34 *R/gridDistance2.R
+c950e1ffb16ce685b78eac66d31a7b6b *R/hdr.R
+2a850450bfde1021d287e5448f16b8c6 *R/hdrBIL.R
+7640cca85fd501d0cc7ea2014e89e9bb *R/hdrBov.R
+023bd114ee78d1ad86d84968755914d4 *R/hdrEnvi.R
+4e489ab01ad2ac3885631678287420ce *R/hdrErdasRaw.R
+1188875b30080a2256b30a2b2fc35db4 *R/hdrIDRISI.R
+6e6245c438e14cbc04d34398bb64e55d *R/hdrPRJ.R
+4e17e0c97f654ca56cf8bd5105249a41 *R/hdrRaster.R
+f17b5f21fceb414e0f5212365a372780 *R/hdrSAGA.R
+46639113cf0960250f38a2aaee11a3b6 *R/hdrVRT.R
+714c3163e7b131cda273de02680bf792 *R/hdrWorldFile.R
+253cf831efcb643e823172056ba5772f *R/head.R
+8378539f61a0f0e5a92944158be86091 *R/hillShade.R
+19f1aa4c637023a03b2e740de5a92d70 *R/hist.R
+efa2ff4950234e2343fb36ed3bb9feca *R/idwValue.R
+04cb136c6ee22d8b548107981ae9aa21 *R/image.R
+f2415c0dff9ad3ce4e3dc6c563b512ce *R/imageplot.R
+ba0c419cc4a0aa101f6b672f097aa6ea *R/imageplot2.R
+fcf46d964ec32539038dea8262951b32 *R/index.R
+831ef36ba63b463c4465516ce0629a29 *R/indexReplace.R
+d208b8e5985d40138b2c184b693e208f *R/indexReplaceBrick.R
+87f87ac67b5e86dc8eff77a0c3c60aca *R/inifile.R
+1f8f0da80e1fb1638405e7fc807f1125 *R/init.R
+f590d5b5c82c554d8265d45ba6918498 *R/intDataType.R
+906e13b56ca82eb13dadde56e71e527f *R/interpolate.R
+122d728806c743d09365319627cff18a *R/intersect.R
+03284a8e64147f11566c5cd02a9e0e19 *R/intersect_sp.R
+c5676dcb0c5c3f3833ec20a24b8ee273 *R/is.na.R
+463cc621273ed3e43c5bfab60ea69d86 *R/isLonLat.R
+4d4d56411dc82d5e078e043a09262126 *R/kernelDens.R
+1ea3ec8baefbe2586d68280ae9c83482 *R/kml.R
+b714b990a951fd33e23bb9e38632d86f *R/kml_multiple.R
+fa4a619e4196edbbecd7e3e20d9dcbf9 *R/labels.R
+b4179153acc3a507dae81ce4f22d4d43 *R/layerStats.R
+aba1b4dcf0d95d6308bdbe23a36979a0 *R/layerize.R
+fce67465da1557ea30ce733d55ae58ba *R/localFun.R
+bdfed34cfccafd7a2531707f0804c320 *R/makeProjString.R
+bcd2edc48208faa6dee52a3c3de771a0 *R/makeRasterList.R
+18f0a67917602b996821b1a1f9729e33 *R/mask.R
+fffa806f2ed93ef421ad7fa1d35e8427 *R/match.R
+72a25b8b42a3ea558aee9483ebf053a6 *R/math.R
+1cb6fcb1766b9889e304fffe45456c04 *R/maxDataType.R
+10661364c4d01ce3799f764c287ed0cc *R/mean.R
+6631b2ff685e06f336115d11b2ea3835 *R/merge.R
+54b4a10c4d0512a7e951997ac6990b82 *R/metadata.R
+e7e9c586a34ed5b9c6342f8996a5ee83 *R/minValue.R
+41823c67f47ad5cba7fa99e59e733f6e *R/modal.R
+536b4ed767d6f1c7d4765068ca5360b6 *R/modalRaster.R
+6793dd57cb54076018eaf9401139ad11 *R/moran.R
+11dbb8fe56589f9237ccad4fcb325429 *R/mosaic.R
+723299315161be75225cfe9748bc3cb0 *R/movingFun.R
+9f083cb4990404c0368c2eeccb83b44d *R/multiCore.R
+03a7a03798a1af13f3b84dd95d5e435d *R/naValue.R
+b6ea862a16c2c641bac2e1275901da68 *R/names.R
+674f357acede97fde81ece6bb2141fd2 *R/ncell.R
+8286ef12de447ddab3b271daff054c20 *R/nchar.R
+41532fcd6695aaef8ded07afefd4800a *R/netCDFread.R
+151dfe3fecd4981ebc2c343bf8ddc5e5 *R/netCDFreadCells.R
+53f5b6584a32a930019896e65c88fb2a *R/netCDFtoRasterCD.R
+322c27edefaca28163f122af13324d27 *R/netCDFtoRasterGMT.R
+6b1521db5820e90750c788d80dc2e260 *R/netCDFtoStack.R
+18725ebfd55fc0f822d35164086eea25 *R/netCDFutil.R
+35c02515000b511593c7d6530b832b3a *R/netCDFwriteCD.R
+90fde704c1d5710f0e2fcd6c69c41683 *R/newPLot.R
+07075bf7ca758c2814aa861eb6b103e4 *R/nlayers.R
+3b100bb974182c34fa7b9a96eef8af22 *R/notused.R
+8dc0dd5225965c6eec35f881d9fe3033 *R/nsidcICE.R
+d846ce6c7b94ff7d80e24a9371f7ce15 *R/origin.R
+43d3fad9a2fbe48dcbb796415dcfab58 *R/overlay.R
+a37b86a9c87ecfd2b56d4a685b8452a2 *R/pairs.R
+00963802d04cac1411b9ede9515d520b *R/persp.R
+1d905cc6314d143342c1640b56653823 *R/plot.R
+9c6f8425d698a02398bbef9e546afc75 *R/plot2rasters.R
+b7bdaf4601dd423cabb0e8ec853d0cd2 *R/plotCT.R
+59a42f68753300c351aed2b1a056ace8 *R/plotExent.R
+fbe3a6c6459acc511e83c1d89770d49c *R/plotRGB.R
+55dd82521806975cb9ffc775bb66fa50 *R/plotRaster.R
+e05b963d86aa7a141fc0b2d81aa75084 *R/plotRaster2.R
+f2f9e5e3b6c49033668ac964798de42d *R/pointdistance.R
+cf3f748c779d61ced33ca66b5a3e919b *R/predict.R
+c928d41364c0f42923cc5c3c8940cb13 *R/print.R
+253e1b00d879156bcb58506c6a558296 *R/progressBar.R
+0b72a7f7070e090b3547931a8b5345af *R/project.R
+52847663a90e2af4161f6766ae8adfb2 *R/projectRaster.R
+284e7b2831b4345560b852a7809c1f5a *R/projection.R
+712c7df567606133082ffba0cd94e8e0 *R/properties.R
+7d8c8194a5f89aa328af2531601647e4 *R/quad.R
+8720ccfe5c4f80d78373acc4e793d96b *R/quantile.R
+a91bdbdcebd7402a4cee54d85cc707ef *R/randomize.R
+9da327b886c01486a4b73093e4034b97 *R/range.R
+43e8ea2729d370fe715bcdba5cafc6f1 *R/raster.R
+05b8d8fc2b37459bdf499945204e5e78 *R/rasterFromASCII.R
+34d2e2b2be30257a2408b71c22f5ef86 *R/rasterFromBIL.R
+c88d06484a230695481ce60f939b4169 *R/rasterFromCells.R
+a51b6dabc0ddeaaa23e89e25906618b6 *R/rasterFromFile.R
+5c5a5dc0def73484ff425358632015c5 *R/rasterFromGDAL.R
+5571b6e61118276dd449db4f7c46d9ea *R/rasterFromIDRISI.R
+522fd813fa7c6dde180d8b5124f33642 *R/rasterFromRasterFile.R
+36c1c3734c32c73c4a6488ae7fd26aa2 *R/rasterFromSAGA.R
+4e791da3a684b32251a70d8911ca4b7d *R/rasterFromSurferFile.R
+22023dcb0103e7cf2efdd130519d7f5b *R/rasterFromXYZ.R
+e97dce44bc3b445c60d57e96cbaac420 *R/rasterOptions.R
+6a2f2c40d22963f9573e2c5d555cda42 *R/rasterToPoints.R
+88c292cae4cda2a3935e0f83a2dfe50f *R/rasterToPolygons.R
+f30b733942b5242d7a1d8423cc561bd2 *R/rasterize.R
+bd4bbf9d1e897d0ea1f5fe54e018a946 *R/rasterizeLines.R
+2f2343c7f5bf73ed36fd753cd43c4479 *R/rasterizePoints.R
+dbd3935ae5db793baf63f960f2152742 *R/rasterizePointsNGB.R
+b61c871b10fe28cd0ca0f4f002571f70 *R/rasterizePolygons.R
+957bcd0311eaa1e04d51ab60eded5df0 *R/rasterizePolygons3.R
+f5e7baf56bb707b1d874f0263bb0b475 *R/ratify.R
+efcf32bd515d8cbf82d17da57be9b0c2 *R/read.R
+695f1725011a1d9425047b1bd4e3413a *R/readAscii.R
+875b42a645f62deade79deb55eb0d5c9 *R/readCells.R
+21e9a646e60bddd69d798860cb229121 *R/readRasterBrick.R
+ad792be1ca35ae5417305b01673fcd0b *R/readRasterLayer.R
+e0aab5da19f3b29ab5f3dcb5897ffadf *R/reclassify.R
+215bd42cccb53d7b323cf578de63be31 *R/rectify.R
+a5be497e4e0638602623c1f0959b0f0b *R/replaceProperties.R
+74e7c98fb63c052617578f1b49347935 *R/resample.R
+6fcdf39923733184b80af65cee26ebde *R/resolution.R
+6e26e033a8db11502fb1f7bcb32cc8c4 *R/rotate.R
+4ee55fba007b827029009d26191b007e *R/roundExtent.R
+92fb25c2ac0978e1791c2a9ca0cc5ecb *R/rowMinMax.R
+b772a963de7ce4c47da3aa59a48629bb *R/rowSums.R
+baa90747824f71f24941142f9e644f0f *R/sampleAlong.R
+6a1e363958e224d953908c61cc413c89 *R/sampleInt.R
+cc5e64b3366c2f31fc809cd5c85ef1fc *R/sampleRandom.R
+0a41864ea73b44052d8c2fcdb4977e23 *R/sampleRegular.R
+3d387291e51b228e37059d1e5f3edea8 *R/sampleStratified.R
+4e88eeadfebc7677d048b3db2d877795 *R/scale.R
+e63c3a401431d2f564d51ee935ebf5d2 *R/scalebar.R
+4fbe85660b698471b4c4566c2f445871 *R/select.R
+6de7caaa6cd0ea99b975f303c3eeb446 *R/setCV.R
+ddb8db646ec6ad69a43f5b86cfce2257 *R/setExtent.R
+ad1d6cd41053c783a4a150c151c843f6 *R/setFileExt.R
+3f27ae95635d13ccb856556ee4194399 *R/setMinMax.R
+018a732334bf50001a81088d33f36e5d *R/setValues.R
+f1e1b942bee3ed1d13ee7979e4143393 *R/setZ.R
+25b808ef8b71a67772964733aa0cce7f *R/shift.R
+a474bab8ab47f47bf59c5d983a12376d *R/show.R
+11419491cc04d71d7cc2d30b0c233501 *R/shp.R
+c9a5d1fc00d36410cbaa885de3f51208 *R/simplifyPols.R
+8678537e1359975420c8d0a607d0840c *R/slopeAspect.R
+f14fc398786001fefbfa5b209a90cb2c *R/speasy.R
+38e95be9a2c690f69f2b030e41d9a4dd *R/spplot.R
+7fd4c96846419a452ce8d11300e90170 *R/stack.R
+6d3611130908c83a2a0665801e0b1189 *R/stackApply.R
+6c6d872beb2eda2a4e5180db284dae29 *R/stackFile.R
+99f086cba085f4d5ed9d570dfeb7d52b *R/stackQuick.R
+3c9bab661c2685f5d24dead85fc3b468 *R/stackSelect.R
+56cd507232066784c6caa3c34c091844 *R/stretch.R
+ce1de0e48d38287879a6989ab94887d5 *R/subs.R
+79c839fe77151e139bb2eed7d6012a3e *R/subset.R
+578ca78311eaa7083a77068f113a5544 *R/summary-methods.R
+7e95915f252c1abc1b687d038fb835b1 *R/summary.R
+221f2156703fe798a5a4e959de1cc5eb *R/symdif.R
+c72e5021ee7bd2cba36c71f399a35146 *R/terrain.R
+5e00fbe367c1dc4327624c5973da2b4b *R/text.R
+3f376abcc300f2f678ee747440f79733 *R/tmpFile.R
+0ce9a6600bd2b110526c5c649b11cf81 *R/tmppath.R
+4a253d2fcd4f326a0bde1ead4676b265 *R/transpose.R
+846dfd93e2a6e64c5bfcc965acc082f0 *R/trim.R
+a86c8fe16a462581ade9ba743c489fef *R/union.R
+dab14efcc0f4bcb2a0c2abf7d687491f *R/union_sp.R
+9b6fcb5eadf8b515d571f8eba76419eb *R/unique.R
+2c3df52854a3eee3ee465458ddebace4 *R/unstack.R
+92d72f7021d614a02ec649dcc084a527 *R/update.R
+f37c880549f2d7b406d4236db8fa9767 *R/validCell.R
+201c69d5a4e376801aff7d3660e429af *R/values.R
+c0a682f1e8c571323969ddacdff08fa8 *R/weighted.mean.R
+8d9076e0152bc0abd23676b57d98d99d *R/which.R
+c5661f7a420f0c1eda59ac28edfe9692 *R/which.max.R
+2970db23839d7922c5a90575a31c936e *R/whiches.max.R
+875ce2e542047b8438ce4f8d4247a44b *R/writeAllAscii.R
+f4bb9da532b458441ec7ebb4f90265ef *R/writeAllGDAL.R
+2f692f9d9a80e31ba11b4bf3d15ff900 *R/writeAllRaster.R
+6f3df4fd1e4aba3cab8dc1ed6359d04b *R/writeRaster.R
+37f1396c2c7cdf0649ea8b8cfc1e258b *R/writeStartStop.R
+deb195398ea10a1bb5a4f8c560e4ae29 *R/writeStartStopAscii.R
+870f4a77a6837f1a7ba04e3e19d33fd8 *R/writeStartStopGDAL.R
+73ffb9d479226e1898f4a8edfcb899c4 *R/writeStartStopRaster.R
+6e8dcdcf682146216cc32ce779eae452 *R/writeValues.R
+a5f3ef72cb8b73048aeb92e4bbe88b97 *R/xyCell.R
+580bbbdb3a168b22b9f97c3d69248e13 *R/xyMinMax.R
+1c3c43b947e39470d3411ea01e234fae *R/xyResolution.R
+285bd583889604ea933d694b7c46b41c *R/xyValuesBuffer.R
+8ca7be28daeedbbb34456483f66ed452 *R/zApply.R
+d0b3104768d09ac06a6b7e81bc30d95a *R/zonal.R
+6f89f7072d3bad6c1ce3d4ed55b413bb *R/zoom.R
+0223205485f6614e3e363458a948a312 *R/zzz.R
+4edc5aa9e85b444b4d05e42d8bcb7b0c *build/vignette.rds
+3be3d2c26ecebd5c98af396455417f24 *inst/doc/Raster.R
+93752cf272da8e10d461f2f62a06f048 *inst/doc/Raster.Rnw
+3bccc9052534235dcd39ef4c89752cde *inst/doc/Raster.pdf
+8513b7865ba30fef7caa5ea4dc9f3ee2 *inst/doc/functions.R
+b6b8b6c45360d7509cc8e05fe48414c4 *inst/doc/functions.Rnw
+1b3151ffe36e665dd7fe26e315ccbdc3 *inst/doc/functions.pdf
+420023a741c8ac112f7b995bdd8f5eed *inst/doc/rasterfile.Rnw
+4fafb647c70e52930fff070f3a2470e2 *inst/doc/rasterfile.pdf
+be20f960310c33adbcc4e98294a61d42 *inst/external/countries.csv
+2ba9fc7610d96e7a00b0678f328be75c *inst/external/countries.rds
+833b7982adb38dd5d7999f12ae42c8ed *inst/external/lux.dbf
+e729936bf5360b37a15365fc295a1901 *inst/external/lux.prj
+4ae2847099f7574e36516738dc411a0f *inst/external/lux.shp
+5d6304a3bc11ffe01ffdda30514d15df *inst/external/lux.shx
+bed3f7fe573de483736ba2ba73c26341 *inst/external/rlogo.grd
+b3ed7227bb04142c4a36cbe25067d5ac *inst/external/rlogo.gri
+41312e42498e3b1a2dc36ecba563f3cc *inst/external/test.grd
+ecb70c5878c5aa24c4079d0c23867673 *inst/external/test.gri
+e995e30fd4941a13a7fdabaedb2a79d1 *man/Arith-methods.Rd
+7cdbf852e9e7ef0606a31f0f19abfd59 *man/Compare-methods.Rd
+6047dd6990d8ca1867fcb7ebf2fe05b0 *man/Extent-class.Rd
+ec18beb5b959eea05b65f727b24eed40 *man/KML.Rd
+e1504a16e27e1571761ffc1d4574fb4f *man/Logic-methods.Rd
+6f46b53f43e08da585711004cda69270 *man/Math-methods.Rd
+470cbb508192734f425651d2cc3fcb07 *man/NAvalue.Rd
+e7a685ff828e6383a600432dd20a9cf5 *man/RGB.Rd
+24934375376bdd9010bf5c71617c681b *man/Raster-classes.Rd
+e58f9a4a85f9e4cf6f43294908656035 *man/Summary-methods.Rd
+b3be0c099cc587770e2a16ff5b970f68 *man/addLayer.Rd
+c85a10566c18d2dc500599ae924cf0a2 *man/adjacent.Rd
+ceceab891c63ca2eac73e671c0ce2e4d *man/aggregate.Rd
+1b49ae5146bdd428bf04bee70402c4d0 *man/alignExtent.Rd
+19a6a6770b9fae0971db7dc799539ff4 *man/animate.Rd
+c708716bd7f41b1a6a4ecc1b8c54c92a *man/approxNA.Rd
+9d685916c585cabde5c3e47a8f250bb5 *man/area.Rd
+07a2c7c35155fb437779b2434afef80d *man/as.data.frame.Rd
+35688fa1d7187c681000bf420e834aa5 *man/as.list.Rd
+1510189b1cd5a503dfd5e74252434d19 *man/as.logical-methods.Rd
+a0f5d2596b270d051352a7d0cd7bcd62 *man/as.matrix.Rd
+90bf584faeaa9215c23be94c1d73cea8 *man/as.raster.Rd
+f3ad0bcbc89e994e1984cfe2bfa87674 *man/atan2.Rd
+00686250a7529660362535dceae60c91 *man/autocor.Rd
+7177a45476a606bd173fea369423efda *man/bands.Rd
+831f328f9e60041530a9497cfdab8e79 *man/barplot.Rd
+68f599d32eb29fe53685d42e36003f27 *man/bind.Rd
+466aa200d0693ae98314b11a6b1a963d *man/blockSize.Rd
+522c9c8a38d7757b84087dd20d5b12ef *man/boundaries.Rd
+351e6f38d111f9fb2f2266aec861f24e *man/boxplot.Rd
+604a15d6a74e3e37a4a380608e334fd8 *man/brick.Rd
+c6ef476f662e831cadeb0e6e33383177 *man/buffer.Rd
+b113381e97956ea65f243a7e6aed2aa4 *man/calc.Rd
+1884beece5dd71ab42eedac88bf56d0f *man/cellFrom.Rd
+d5bb019e5784df00e69ec6db835168cc *man/cellStats.Rd
+2f047ff2ac6549518e45f465e8ee0d54 *man/cellsFromExtent.Rd
+575399ab5a8431119d8d6c910e9ffb76 *man/clamp.Rd
+2c3e9bc20d462f29decb08abf0a428e3 *man/clearValues.Rd
+15ed8c5363675b531eb96e0a8a8a0f80 *man/click.Rd
+f9103ed064fbbc6fe5c4121094c1feb8 *man/clump.Rd
+bf20431f4714e63a898a6a5d6a2cb51f *man/cluster.Rd
+b7c052ff1e9353ca37b841311a9bf80c *man/colortable.Rd
+661c53c5061d2afad75a184c93a747ee *man/compare.Rd
+80fda2c5c3b9e22a89a857fe2f439acc *man/compareCRS.Rd
+78e4f54301f3326efbe16948df9e8044 *man/contour.Rd
+8ec556bf5dc81b6ddd388eef90a82087 *man/coordinates.Rd
+cd960262c5ebbc98b5a5c4b8d5f79d20 *man/corLocal.Rd
+d5f55396acea2a10854d202cbbd31470 *man/cover.Rd
+bc6c1de19f3b794be3db72b9461d55b7 *man/crop.Rd
+78353ddc16f4fdf430e653d5fcf4f646 *man/crosstab.Rd
+f21e3d4365fd7eaad4daaa9dc902ae34 *man/cut.Rd
+dc99e1ef680f7b9049951d10bcefcdd4 *man/cv.Rd
+6b7f4102f854349a90def9e755a31da7 *man/dataType.Rd
+2ffd0579f62d91d0aae88a149958670e *man/datasource.Rd
+6be3c21af186f0949286667bd191ef79 *man/density.Rd
+91adc79fc209ceb2c458617e8b05d891 *man/dimensions.Rd
+f164520da21c8df7a69012fc6d0485c9 *man/direction.Rd
+d9be17b111ef43f233973bd07ea0332e *man/disaggregate.Rd
+19b6c52f07df95979dedee9cebc2ca57 *man/distance.Rd
+17aa049f29810b4363950d3d833f212b *man/distanceFromPoints.Rd
+1e848e176b8ee174e029949f6ad0d4c7 *man/draw.Rd
+05f5019179b51ed02d0cb4ac9444faf9 *man/drawExtent.Rd
+b9778598e3fd4ab6e84b801768f82e1d *man/erase.Rd
+1903467033fccc6e2b5bef76561834d4 *man/extend.Rd
+07c974ef67d5a7c1cba408243cd153d7 *man/extension.Rd
+2058d68fe8bbacece5fd33ea84128ffd *man/extent.Rd
+62720f6ff2d10ca1476164d57c13f05a *man/extract.Rd
+1da175d1d69c42c9a283db7604deff96 *man/extractIndex.Rd
+fa36a1f1da83b141883bd7e1acf4e0a7 *man/extremeValues.Rd
+71f868ebd0867d57313d3a3d6780cdad *man/factor.Rd
+090cc4bc07e3b292ec6cf0fcce488a5d *man/filename.Rd
+2ec80f9c27b436691f588884a12a7185 *man/filledContour.Rd
+e1abf5cdb534db9044a5ebc509a7e946 *man/flip.Rd
+389530adab12a45a79e069577385a7e8 *man/flowpath.Rd
+78605cd20d88aeb9699006d01c46d6f2 *man/focal.Rd
+d85d9850110b2d8428428815054c8e85 *man/focalWeight.Rd
+7862a513c1a0c807feb55209fb2ac020 *man/freq.Rd
+5461bd4b1168c90c87114c034ba7c007 *man/gainoffset.Rd
+174fc6a767ffda62b7df53c9f6b85a47 *man/geom.Rd
+2d38088a39aee3219a21b40f2ed98bdf *man/getData.Rd
+8d6dfd69943b8248285a3c12ccc75155 *man/getValues.Rd
+3728e566a5e451fd4c9d855905099b55 *man/getValuesBlock.Rd
+ef33e7cb09e69e1e1f3ea7b267224989 *man/getValuesFocal.Rd
+f02b54303a9689025f30a64e5396c801 *man/gridDistance.Rd
+1b41ce450e76b7aa426bda51b1df3f1a *man/hdrFiles.Rd
+744f64acb9a3f97c8884b75420b548d1 *man/headtail.Rd
+10c4a5a9e4143636fff74b44f52342ca *man/hillShade.Rd
+68880b38ba1eb97ad9dfbc8ea1f66e38 *man/hist.Rd
+9b1252c3f6ed4e29b17c946c05403756 *man/image.Rd
+fc4e9785a37e59954bea419acc632bde *man/iniFile.Rd
+c26e5da45d41d3fa00fa3942b82949c4 *man/init.Rd
+19b4b19c7a5a794ed350dd1358bbcc1f *man/interpolate.Rd
+fdc67414615372122ce08f84ff63372c *man/intersect.Rd
+f5f8145a06894a929bc3877b3bd9e503 *man/isLonLat.Rd
+e8530a3ad8334ff8e7fc661d1f310279 *man/layerStats.Rd
+cb011fd1bd0c2a8f3a7a666d86330b04 *man/layerize.Rd
+d7302146d92f94c726a0401c2984edde *man/localFun.Rd
+9de93a22541e704c0f122e1dc4648aeb *man/mask.Rd
+c06b8d508d062798c301876f01970c74 *man/match.Rd
+5a47bc5fdd658f27c7da5d1a1802364c *man/merge.Rd
+d2a3e386898adfcf1836ec9e67421498 *man/metadata.Rd
+44f5b456ad02bc79beee393cffafa928 *man/modal.Rd
+65c9ee70b38e17934cb9bc896112e9fd *man/mosaic.Rd
+e2843923291909994b044b5b5df8921d *man/movingFun.Rd
+e59d77d198dc9ab7cea89538483c7305 *man/names.Rd
+c851fb14df1c7c3f8a573b0f4d60ffa4 *man/ncell.Rd
+b49e7d548d1c00ef9e9e87640b2fb5ea *man/nlayers.Rd
+e78b7afb287446f292a8415c494cf267 *man/origin.Rd
+27f84447dc1d6dbfb0e914a5a1e402ab *man/overlay.Rd
+96379250813832bfe1652669def0239e *man/pairs.Rd
+c8893194fef055144524639ec82182db *man/persp.Rd
+b2e9df2e0ac27bd21e0a4dd677cd5b75 *man/plot.Rd
+13c0949cde91923c5abd05a6cbbabe2e *man/plotRGB.Rd
+12cd4acddba25e73a5931bd5d391c124 *man/pointdistance.Rd
+c9885505a3077d6de474e8a1696a36a6 *man/predict.Rd
+7003f2539896b6b7cb35a40f604f7ddb *man/programming.Rd
+54e95741055688ef5977208e14e9b7e7 *man/projectRaster.Rd
+4187ff1c97c2d42e3fd85d49d298a22b *man/projection.Rd
+a8845dcadffe786cde4381e41248508f *man/properties.Rd
+db4f3407ef3bdae1ce027959b486d988 *man/quantile.Rd
+ab3c2a4de000422349a064183f19922b *man/raster-package.Rd
+d25721885a563924770a7427cbd928b2 *man/raster.Rd
+a6aa5de8355b28dfa53ca2235d47c658 *man/rasterFromCells.Rd
+bb6124ba0907af6d951ae311c3d72ac3 *man/rasterFromXYZ.Rd
+c288e3cbcc6f256f4b64d82f4778f7de *man/rasterOptions.Rd
+e48c73d3ff8e9269d17aa0baa13264bc *man/rasterTmpFile.Rd
+1b73ddcea853fc367fb6366cf792b9b3 *man/rasterToContour.Rd
+81dd12db3fb209fdbe5ba88996ac1ff0 *man/rasterToPoints.Rd
+ad306e68d9f9f34bffda158983ca1cc4 *man/rasterToPolygons.Rd
+9eaca005021c8fd5a1897ec2c2d04847 *man/rasterize.Rd
+c4ea12aba9e9c6bcdfc6b7566b67648b *man/readAll.Rd
+0647a414d47089ff8cfe03156184488f *man/reclassify.Rd
+797c9b0acd7148017b67679c1d8875fe *man/rectify.Rd
+6eab8025d24f3abfa37a0dd988d49806 *man/replacement.Rd
+61d4aed619895e0b6ec2b234dbb8c595 *man/resample.Rd
+f00c18591e1d499969979b7dd1225808 *man/resolution.Rd
+177b8b0393de68d6e10adf589373e319 *man/rotate.Rd
+ed9fbb6a3897e879db3a3a69e52f9cd4 *man/rotated.Rd
+c00b51e73aa483d52c8a4ab8fb979173 *man/round.Rd
+8630daa11802d3345b6bf84af630534d *man/roundExtent.Rd
+ba1699903aeb647c855163838412f27f *man/rowFromCell.Rd
+e8f314b24a086c2488423d4f508261aa *man/rowSums.Rd
+e45578499872a35f1eca04a4dab96519 *man/sampleInt.Rd
+312503eb3f0dd257b4af2d67f610e8c9 *man/sampleRandom.Rd
+32c2c4d15d680e60eed4e9234348ae4f *man/sampleRegular.Rd
+35e6f76e6ccb62b4baf71f2be7cd374a *man/sampleStratified.Rd
+903d03677c31e788b960436c74d8aeb3 *man/saveStack.Rd
+bcd299674cde2c613bacbcc3d2079d2a *man/scale.Rd
+8354efe9ed5c8a961cae776def53e90a *man/scalebar.Rd
+f61a7c6dd9f944b574b862b1dfb69324 *man/select.Rd
+dd97555856192ee24fddd9f2ce408b65 *man/setExtent.Rd
+f5e657261f8a07449125d54ef9d23847 *man/setMinMax.Rd
+862bca0ecf97ee6fecdf860dc464cf96 *man/setValues.Rd
+91945809bbf6289c63df7080f1d42810 *man/shapefile.Rd
+0b82235fec95c4e60c113f2740c29116 *man/shift.Rd
+756cb45c56c2b044be436bdbe27937a9 *man/slopeAspect.Rd
+9c129a0b769272c7510f59a0e7fbaec3 *man/spEasy.Rd
+46b0d1c94fdd6d7135b8b4ae0f415e8f *man/spplot.Rd
+bb1e2dfd408074f0d54eb4bc1cc7efc1 *man/stack.Rd
+a26df2ae3958d50bc00f643e56b2c63b *man/stackApply.Rd
+efd6ea98ec0715752709c7b3221ce752 *man/stackSelect.Rd
+45d6e2cdb3591122fc44a934f5c41c4e *man/strech.Rd
+9db7f5feefbe828e55f251bf8e458e3b *man/subset.Rd
+9207a5215468ab12320a41cd8975c38b *man/substitute.Rd
+7cb3657af929fc13de7bf2c88294947b *man/summary.Rd
+86534003ae4152a389b08dc474fbfd8e *man/symdif.Rd
+28bbe261ba6d1a75173d88dcd963dfca *man/terrain.Rd
+fd3e870528c1748d5efe2f034fc644de *man/text.Rd
+f686e4eb8876d491d266ebe295dd9572 *man/transpose.Rd
+3d19fd286a3deabbe00b03cba501f774 *man/trim.Rd
+e9cd8cc09076476157a8b94fc13713d8 *man/union.Rd
+f10421859968d4472ffbe46b4345648f *man/unique.Rd
+3ca50b5aa6d04c407036b227814737ae *man/unstack.Rd
+2f04c81b5db588c26f2a40b15eb0a238 *man/update.Rd
+61b8d8151baf66597a478c8da372bce4 *man/validCell.Rd
+403e7d3d2a3f90f5216467c3d22194dd *man/validNames.Rd
+21d1b013abe7cb0ca54ee44b112c4662 *man/weighted.mean.Rd
+df14161e586a9c12a9a49ec58973dab7 *man/which.Rd
+9d3336603f6cf63ca2cd845c7f89d6ad *man/which.minmax.Rd
+164657c9c168e7cbe3fc4b256e9f01ca *man/writeFormats.Rd
+4b351df8238d4585cf6b00b01bf25c50 *man/writeRaster.Rd
+365ea35a60ae5e9acad629144b48513d *man/writeValues.Rd
+8c90ec4ebd5fae3986564b3f797689c8 *man/xyFromCell.Rd
+c939d846d9caccdc1296ab0cbc572d4d *man/zApply.Rd
+5405ee0f20a4dd9e2073fff5665b0a0e *man/zonal.Rd
+50638f02eb5168db857b9571ee7e5af6 *man/zoom.Rd
+7f2a34ddf86c7e4cf7055cfb6f6fdf6b *man/zvalues.Rd
+f96bb7016c8fb756991df63778362bfd *src/RcppExports.cpp
+f5319c0717415be2497e00091d30ca42 *src/aggregate.c
+6262a5370d0fa163d09d6c313e5cfb87 *src/aggregate_get.c
+92d4a9534bf40bd0ca6a0c73adc989a7 *src/bilinear.cpp
+360a1b607c7994fce78281b1a1d04598 *src/broom.c
+374a0ab9f7be016993bb20c602f0ab16 *src/cellRowCol.cpp
+504ed546b3ca757e906b6bec93278809 *src/clamp.c
+821c4e32565ef438a5fedde74a14bcd5 *src/direction.c
+fcb176408026e5555496994528ee3459 *src/dist_util.c
+87ed7a8354e97bbbe097c6da6e3c3206 *src/dist_util.h
+4fb63d562f9561777582f34684236b97 *src/distance.c
+99268ac25c49c79f6d1c614bddbab65b *src/edge.c
+fc5a17394eec3382058d6b63744b6336 *src/focal_fun.c
+2bab2e696d813480636dfbc87c31e636 *src/focal_get.c
+1bcbe3c0775f4f30a94fb36bcec9289b *src/focal_sum.c
+de722fd0f8f6aa154e53ae6fbb02f10a *src/geodesic.c
+931f9f1e049b10f6de797a8e96952251 *src/geodesic.h
+bd031627de38d4f18ee6b3395f1663af *src/geolib.c
+ddef60d0af91cb1fd0e994c69f2c7f82 *src/getPolygons.cpp
+83e226171e15981602efdace2799403a *src/intersect.c
+198e8afb13c8ceb774da9542a68c87ad *src/intersect.h
+6d94188e287c5291c4dfc6a60e1eabcd *src/layerize.c
+074a9362891f69c8b0ccb85a95353afb *src/modal.cpp
+8568053852475e4e5a5e9517422cfe2d *src/pointinpoly.c
+15d16970a4635bac1e9bf7a09393ef0f *src/ppmin.cpp
+d27e50ee4a34e92104e19922b9283db8 *src/reclass.c
+f22fe49f7899653d52ced2e36cbba829 *src/solar.c
+73c02a7d368eaf35052564b34f7104f8 *src/terrain.c
+54032d7b305b087eb3a5749dc3b1d2e2 *src/util.c
+02b3ab8677d52f791681845435a5252a *src/util.h
+cf0b4e04793e99e7c8e38469f6efc97a *src/wirth.c
+edc7f688101836fae4bcce148a030aa8 *src/xyCell.cpp
+93752cf272da8e10d461f2f62a06f048 *vignettes/Raster.Rnw
+b6b8b6c45360d7509cc8e05fe48414c4 *vignettes/functions.Rnw
+420023a741c8ac112f7b995bdd8f5eed *vignettes/rasterfile.Rnw
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..3beb09e
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,11 @@
+import(sp)
+import(Rcpp)
+importFrom("methods", "Ops", "Math", "as", ".hasSlot")
+importFrom("stats", as.formula, aggregate, predict, density, quantile, update, approx, reshape)
+importFrom("utils", stack, unstack, head, tail, download.file)
+importFrom("graphics", "hist", "lines", "image", "rect", "filled.contour", "contour", "persp", "pairs", "text", "boxplot", "points", "abline", "legend", "title", "strheight", "strwidth")
+importFrom("grDevices", "as.raster", "terrain.colors", "heat.colors", "col2rgb", "rainbow", "dev.flush", "dev.off", "dev.new", "xy.coords", "png")
+exportClasses(Extent, BasicRaster, Raster, RasterLayer, RasterBrick, RasterStack, RasterStackBrick)
+exportMethods("[", "==", '!=', '!', approxNA, as.array, as.character, as.vector, as.matrix, area, bandnr, barplot, brick, calc, clump, crop, disaggregate, distance, extent, extract, extend, flip, head, intersect, is.factor, merge, mosaic, ncell, nlayers, overlay, plot, plotRGB, raster, reclassify, resample, rotate, sampleRandom, stackSelect, shift, subs, t, tail, trim, unique, unstack, union, xmin, xmax, ymin, ymax, zonal)
+useDynLib(raster)
+exportPattern("^[^\\.]")
diff --git a/R/AAAClasses.R b/R/AAAClasses.R
new file mode 100644
index 0000000..3275f23
--- /dev/null
+++ b/R/AAAClasses.R
@@ -0,0 +1,319 @@
+# 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 at xmin <= object at xmax)
+ if (!c1) { stop('invalid extent: xmin >= xmax') }
+ c2 <- (object at ymin <= object at ymax)
+ if (!c2) { stop('invalid extent: ymin >= ymax') }
+ v <- c(object at xmin, object at xmax, object at ymin, object at 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',
+ history = 'list',
+ #meta = 'list',
+ z = 'list'
+ ),
+ prototype (
+ rotated = FALSE,
+ ncols= as.integer(1),
+ nrows= as.integer(1),
+ crs = CRS(),
+ history = list(),
+ #meta = list(),
+ z = list()
+ ),
+ validity = function(object) {
+ methods::validObject(extent(object))
+ c1 <- (object at ncols > 0)
+ if (!c1) { stop('ncols < 1') }
+ c2 <- (object at 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 <- 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 at layers) > 1) {
+ cond <- compareRaster(object at layers, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE)
+ } else {
+ cond <- TRUE
+ }
+ return(cond)
+ }
+)
+
+
+
+setClassUnion("RasterStackBrick", c("RasterStack", "RasterBrick"))
+
+
+setClass ('RasterLayerSparse',
+ contains = 'RasterLayer',
+ representation (
+ index = 'vector'
+ ),
+ prototype (
+ index = vector(mode='numeric')
+ )
+)
+
+setClass ('.RasterBrickSparse',
+ contains = 'RasterBrick',
+ representation (
+ index = 'vector'
+ ),
+ prototype (
+ index = vector(mode='numeric')
+ )
+)
+
+
+setClass ('.RasterQuad',
+ contains = 'Raster',
+ representation (
+ filename ='character',
+ bricks ='list'
+ ),
+ prototype (
+ filename='',
+ bricks = list()
+ ),
+ validity = function(object) {
+ if (length(object at bricks) > 1) {
+ test <- compareRaster(object at bricks, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE)
+ } else {
+ test <- TRUE
+ }
+ return(test)
+ }
+)
+
+
+#setClassUnion("RasterStackBrickList", c("RasterStack", "RasterBrick", "RasterList"))
+
+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))
+ }
+)
+
+
+
diff --git a/R/GDALtransient.R b/R/GDALtransient.R
new file mode 100644
index 0000000..3656ee3
--- /dev/null
+++ b/R/GDALtransient.R
@@ -0,0 +1,123 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+# based on create2GDAL and rgdal::saveDataset from the rgdal package
+# authors: Timothy H. Keitt, Roger Bivand, Edzer Pebesma, Barry Rowlingson
+
+.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 at nrows, cols=r at ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL), silent=TRUE)
+ if (class(transient) == 'try-error') {
+ if (dataformat == "Float64") {
+ dataformat <- "Float32"
+ }
+ transient <- methods::new("GDALTransientDataset", driver=driver, rows=r at nrows, cols=r at 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 at 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)
+ # as.character to ensure NA is character
+ rgdal::GDALcall(transient, "SetProject", as.character(projection(r)))
+ if (is.null(options)) {
+ options <- ''
+ }
+ return(list(transient, NAflag, options, dataformat))
+}
diff --git a/R/Geary.R b/R/Geary.R
new file mode 100644
index 0000000..d696adc
--- /dev/null
+++ b/R/Geary.R
@@ -0,0 +1,73 @@
+# 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) {
+ x <- calc(x, fun=function(x) ifelse(is.na(x), NA ,1))
+ W <- focal(x, 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
+}
+
diff --git a/R/RGB.R b/R/RGB.R
new file mode 100644
index 0000000..f941c96
--- /dev/null
+++ b/R/RGB.R
@@ -0,0 +1,131 @@
+# Author: Robert J. Hijmans
+# Date : February 2014
+# Version 1.0
+# Licence GPL v3
+
+# partly based on functions in the pixmap package by Friedrich Leisch
+
+if (!isGeneric("RGB")) {
+ setGeneric("RGB", function(x, ...)
+ standardGeneric("RGB"))
+}
+
+
+
+
+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)
+#x[] = 1:100
+#y = RGB(x)
+#plotRGB(y)
+
+
+
diff --git a/R/RcppExports.R b/R/RcppExports.R
new file mode 100644
index 0000000..3a20f38
--- /dev/null
+++ b/R/RcppExports.R
@@ -0,0 +1,55 @@
+# This file was generated by Rcpp::compileAttributes
+# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+.doBilinear <- function(xy, x, y, v) {
+ .Call('raster_doBilinear', PACKAGE = 'raster', xy, x, y, v)
+}
+
+.doCellFromRowCol <- function(nrow, ncol, rownr, colnr) {
+ .Call('raster_doCellFromRowCol', PACKAGE = 'raster', nrow, ncol, rownr, colnr)
+}
+
+.getPolygons <- function(xyv, res, nodes) {
+ .Call('raster_getPolygons', PACKAGE = 'raster', xyv, res, nodes)
+}
+
+.getMode <- function(values, ties) {
+ .Call('raster_getMode', PACKAGE = 'raster', values, ties)
+}
+
+.doSpmin <- function(x, y) {
+ .Call('raster_doSpmin', PACKAGE = 'raster', x, y)
+}
+
+.doSpmax <- function(x, y) {
+ .Call('raster_doSpmax', PACKAGE = 'raster', x, y)
+}
+
+.ppmin <- function(x, y, narm) {
+ .Call('raster_ppmin', PACKAGE = 'raster', x, y, narm)
+}
+
+.ppmax <- function(x, y, narm) {
+ .Call('raster_ppmax', PACKAGE = 'raster', x, y, narm)
+}
+
+.doRowMin <- function(x, narm) {
+ .Call('raster_doRowMin', PACKAGE = 'raster', x, narm)
+}
+
+.doRowMax <- function(x, narm) {
+ .Call('raster_doRowMax', PACKAGE = 'raster', x, narm)
+}
+
+.doCellFromXY <- function(ncols, nrows, xmin, xmax, ymin, ymax, x, y) {
+ .Call('raster_doCellFromXY', PACKAGE = 'raster', ncols, nrows, xmin, xmax, ymin, ymax, x, y)
+}
+
+.doXYFromCell <- function(ncols, nrows, xmin, xmax, ymin, ymax, cell) {
+ .Call('raster_doXYFromCell', PACKAGE = 'raster', ncols, nrows, xmin, xmax, ymin, ymax, cell)
+}
+
+.doFourCellsFromXY <- function(ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat) {
+ .Call('raster_doFourCellsFromXY', PACKAGE = 'raster', ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat)
+}
+
diff --git a/R/addFiles.R b/R/addFiles.R
new file mode 100644
index 0000000..f4fd06b
--- /dev/null
+++ b/R/addFiles.R
@@ -0,0 +1,31 @@
+# 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)
+}
+
+
diff --git a/R/addLayer.R b/R/addLayer.R
new file mode 100644
index 0000000..ef993d6
--- /dev/null
+++ b/R/addLayer.R
@@ -0,0 +1,65 @@
+# 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 at nrows <- r at nrows
+ x at ncols <- r at ncols
+ x at extent <- r at extent
+ x at crs <- r at crs
+ if (rotated(r)) {
+ x at rotated = r at rotated
+ x at rotation = r at rotation
+ }
+
+ nl <- 1
+ x at layers[[nl]] <- r
+ rasters <- rasters[-1]
+ if (length(rasters)==0) { return(x) }
+ }
+
+ x at layers <- c(x at layers, rasters)
+ names(x) <- sapply(x at layers, names)
+
+ return(x)
+}
+)
+
+
+
diff --git a/R/adjacency.R b/R/adjacency.R
new file mode 100644
index 0000000..38cdb80
--- /dev/null
+++ b/R/adjacency.R
@@ -0,0 +1,303 @@
+# Author: Jacob van Etten jacobvanetten at 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, upperrightU [...]
+ 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, upperrightFr [...]
+ }
+
+ 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)
+}
+
diff --git a/R/adjacent.R b/R/adjacent.R
new file mode 100644
index 0000000..c498b69
--- /dev/null
+++ b/R/adjacent.R
@@ -0,0 +1,157 @@
+# 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))
+}
+
+
+adjacent <- 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
+}
+
diff --git a/R/aggregate_3d.R b/R/aggregate_3d.R
new file mode 100644
index 0000000..cde61bd
--- /dev/null
+++ b/R/aggregate_3d.R
@@ -0,0 +1,467 @@
+# 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=2, fun='mean', expand=TRUE, na.rm=TRUE, filename="", ...) {
+
+ doC <- list(...)$doC
+ if (is.null(doC)) {
+ doC <- TRUE
+ }
+ nl <- nlayers(x)
+
+ 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 (nl < 2) {
+ fact[3] <- 1
+ }
+ if (any(fact < 1)) {
+ stop('fact should be > 0')
+ }
+ if (! any(fact > 1)) {
+ stop('fact should be > 1')
+ }
+ xfact <- fact[1]
+ yfact <- fact[2]
+ zfact <- fact[3]
+
+ ncx <- ncol(x)
+ nrx <- nrow(x)
+ if (xfact > ncx) {
+ warning('aggregation factor is larger than the number of columns')
+ xfact <- ncx
+ }
+ if (yfact > nrx) {
+ warning('aggregation factor is larger than the number of rows')
+ yfact <- nrx
+ }
+ if (zfact > nl) {
+ warning('aggregation factor is larger than the number of layers')
+ zfact <- nl
+ }
+
+ addlyrs <- 0
+ if (expand) {
+ rsteps <- as.integer(ceiling(nrx/yfact))
+ csteps <- as.integer(ceiling(ncx/xfact))
+ lsteps <- as.integer(ceiling(nl/zfact))
+
+ lastcol <- ncx
+ lastrow <- nrx
+ lastlyr <- lsteps * zfact
+ if (lastlyr > nl ) {
+ addlyrs <- lastlyr - nl
+ }
+ lyrs <- 1:nl
+
+ #addcols <- csteps * xfact - ncx
+ #addrows <- rsteps * yfact - nrx
+
+ } else {
+ rsteps <- as.integer(floor(nrx/yfact))
+ csteps <- as.integer(floor(ncx/xfact))
+ lsteps <- as.integer(floor(nl/zfact))
+
+ lastcol <- min(csteps * xfact, ncx)
+ lastrow <- min(rsteps * yfact, nrx)
+ lastlyr <- min(lsteps * zfact, nl)
+
+ 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)
+ if (zfact == 1) {
+ names(out) <- names(x)
+ }
+
+
+ if (! hasValues(x) ) {
+ return(out)
+ }
+
+ fun <- .makeTextFun(fun)
+ if (class(fun) == 'character') {
+ op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1)
+ } else {
+ op <- NA
+ }
+
+ if (zfact > 1) {
+ xyzfact <- xfact*yfact*zfact
+ dims <- as.integer(c(lastrow, lastcol, nl+addlyrs, xfact, yfact, zfact))
+
+ if ( canProcessInMemory(x)) {
+ v <- getValuesBlock(x, 1, lastrow, 1, lastcol, lyrs)
+ if (addlyrs > 0) {
+ add <- matrix(NA, nrow=nrow(v), ncol=addlyrs)
+ v <- cbind(v, add)
+ }
+ v <- .Call("aggregate_get", as.double(v), as.integer(dims), PACKAGE='raster')
+ v <- matrix(v, nrow=xyzfact)
+ v <- apply(v, 2, 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, 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)
+ if (addlyrs > 0) {
+ add <- rep(NA, nrow(vals)*addlyrs)
+ vals <- c(vals, add)
+ }
+ vals <- .Call("aggregate_get", as.double(vals), as.integer(dims), PACKAGE='raster')
+ vals <- matrix(vals, nrow=xyzfact)
+ vals <- apply(vals, 2, fun, na.rm=na.rm)
+ out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i])
+ pbStep(pb, i)
+ }
+ pbClose(pb)
+ out <- writeStop(out)
+ x <- readStop(x)
+
+ return(out)
+
+ }
+ }
+
+ if (!is.na(op) & doC) {
+
+ if ( canProcessInMemory(x)) {
+
+ dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact))
+ x <- getValuesBlock(x, 1, lastrow, 1, lastcol)
+ out <- setValues(out, .Call("aggregate", as.double(x), op, as.integer(na.rm), dims, 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, ...)
+
+ dims <- as.integer(c(lastrow, lastcol, nl, dim(out)[1:2], xfact, yfact))
+ out <- writeStart(out, filename=filename, ...)
+
+ if (inherits(out, 'RasterBrick')) {
+ for (i in 1:tr$n) {
+ dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i]))
+ vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
+ vals <- .Call("aggregate", as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster')
+ out <- writeValues(out, matrix(vals, ncol=nl), tr$write[i])
+ pbStep(pb, i)
+ }
+ } else {
+ for (i in 1:tr$n) {
+ dims[c(1, 4)] = as.integer(c(tr$nrows[i], tr$outrows[i]))
+ vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
+ vals <- .Call("aggregate", as.double(vals), op, as.integer(na.rm), dims, PACKAGE='raster')
+ out <- writeValues(out, vals, tr$write[i])
+ pbStep(pb, i)
+ }
+ }
+ pbClose(pb)
+ out <- writeStop(out)
+ x <- readStop(x)
+
+ return(out)
+ }
+ }
+
+ # else not implemented in C
+
+ if (nl < 2) {
+
+ if (class(fun) == 'character') {
+ rowcalc <- TRUE
+ fun <- .getColFun(fun)
+ } else {
+ rowcalc <- FALSE
+ }
+
+ if ( canProcessInMemory(x)) {
+ if (expand) {
+ m <- ceiling(nrx / yfact)
+ } else {
+ m <- floor(nrx / yfact)
+ }
+
+ vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
+ vend <- 0
+ vvstart <- 1
+
+ if (expand) {
+ vals <- getValues(x)
+ yf <- nrx %% yfact
+ } else {
+ vals <- getValuesBlock(x, 1, lastrow, 1, lastcol)
+ yf <- 0
+ }
+ for (j in 1:m) {
+ if (j == m & yf > 0) {
+ vstart <- vend + 1
+ vend <- vend + (lastcol * yf)
+ mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE )
+ temp <- matrix(nrow=yf*xfact, ncol=csteps)
+ temp[1:length(mv)] <- mv
+ cols <- 1:(csteps) + (m-1) * csteps
+ vv[1:nrow(temp), cols] <- temp
+
+ } else {
+ vstart <- vend + 1
+ vend <- vend + (lastcol * yfact)
+ mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )
+
+ vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
+ vvstart <- vvstart + ncout*nrow(vv)
+ }
+ }
+ if (rowcalc) {
+ vals <- fun(vv, na.rm=na.rm )
+ } else {
+ vals <- apply(vv, 2, fun, na.rm=na.rm )
+ }
+ out <- setValues(out, as.vector(vals))
+ if (filename != '') {
+ out <- writeRaster(out, filename, ...)
+ }
+ return(out)
+
+ } else {
+
+ out <- writeStart(out, filename=filename, ...)
+
+
+ tr <- blockSize(x, 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)))
+ dif <- sum(tr$nrows) - nrow(x)
+ if (dif > 0) {
+ if (expand) {
+ tr$nrows[tr$n] <- tr$nrows[tr$n] - dif
+ } else {
+ dif <- dif %/% xfact
+ if (dif > 0) {
+ tr$nrows[tr$n] <- dif * xfact
+ } else {
+ tr$n <- tr$n - 1
+ }
+ }
+ }
+
+ pb <- pbCreate(tr$n, label='aggregate', ...)
+ x <- readStart(x, ...)
+ m <- tr$nrows[1] / yfact
+ vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
+
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+
+ for (i in 1:(tr$n-1)) {
+ vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
+ vend <- 0
+ vvstart <- 1
+ for (j in 1:m) {
+ vstart <- vend + 1
+ vend <- vend + (lastcol * yfact)
+ mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )
+
+ vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
+ vvstart <- vvstart + ncout*nrow(vv)
+ }
+ if (rowcalc) {
+ vals <- fun(vv, na.rm=na.rm )
+ } else {
+ vals <- apply(vv, 2, fun, na.rm=na.rm )
+ }
+ out <- writeValues(out, vals, tr$write[i])
+ pbStep(pb, i)
+ }
+
+ # if (i==tr$n) {
+ i <- tr$n
+ vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol)
+ m <- ceiling(tr$nrows[i] / yfact)
+ vv <- matrix(NA, nrow= yfact*xfact, ncol=csteps * m)
+ vend <- 0
+ vvstart <- 1
+ yf <- tr$nrows[i] %% yfact
+ for (j in 1:m) {
+ if (j == m & yf > 0) {
+ vstart <- vend + 1
+ vend <- vend + (lastcol * yf)
+ mv <- matrix(vals[vstart:vend], nrow=yf, byrow=TRUE )
+ temp <- matrix(nrow=yf*xfact, ncol=csteps)
+ temp[1:length(mv)] <- mv
+ cols <- 1:(csteps) + (m-1) * csteps
+ vv[1:nrow(temp), cols] <- temp
+
+ } else {
+ vstart <- vend + 1
+ vend <- vend + (lastcol * yfact)
+ mv <- matrix(vals[vstart:vend], nrow=yfact, byrow=TRUE )
+
+ vv[vvstart:(vvstart+length(mv)-1)] <- as.vector(mv)
+ vvstart <- vvstart + ncout*nrow(vv)
+ }
+ }
+ if (rowcalc) {
+ vals <- fun(vv, na.rm=na.rm )
+ } else {
+ vals <- apply(vv, 2, fun, na.rm=na.rm )
+ }
+ pbStep(pb, i)
+ out <- writeValues(out, vals, tr$write[i])
+ pbClose(pb)
+ x <- readStop(x)
+ out <- writeStop(out)
+ return(out)
+ }
+
+ } else { # nlayers > 1
+
+ if (canProcessInMemory(x, nlayers(x)+2)) {
+
+ if (class(fun) == 'character') {
+ op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1)
+ }
+ if (!is.na(op) & doC) {
+ dim <- c(dim(x), dim(out)[1:2], xfact, yfact)
+ v <- .Call("aggregate",
+ as.double(getValues(x)), op, as.integer(na.rm),
+ as.integer(dim), PACKAGE='raster')
+
+ out <- setValues(out, matrix(v, ncol=dim[3]))
+ return(out)
+ }
+
+
+ xx <- raster(x)
+ x <- getValues(x)
+ cols <- rep(rep(1:csteps, each=xfact)[1:ncol(xx)], times=nrow(xx))
+ rows <- rep(1:rsteps, each=ncol(xx) * yfact)[1:ncell(xx)]
+ cells <- cellFromRowCol(xx, rows, cols)
+
+ x <- as.matrix( aggregate(x, list(cells), fun, na.rm=na.rm ))[,-1]
+ rm(cells)
+
+ x <- setValues(out, x)
+ if (filename != "") {
+ x <- writeRaster(x, filename=filename, ...)
+ }
+ return(x)
+
+ } else {
+
+ cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact)
+ rows <- rep(1, each=(ncol(x) * yfact))
+
+ out <- writeStart(out, filename=filename, ...)
+ x <- readStart(x, ...)
+
+
+ cells <- cellFromRowCol(x, rows, cols)
+ nrows <- yfact
+
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+
+ pb <- pbCreate(rsteps, label='aggregate', ...)
+ for (r in 1:rsteps) {
+ startrow <- 1 + (r - 1) * yfact
+ if ( r==rsteps) {
+ endrow <- min(nrow(x), startrow + yfact - 1)
+ nrows <- endrow - startrow + 1
+ theserows <- (startrow * rows)[1:(ncol(x)*nrows)]
+ cols <- cols[1:(ncol(x)*nrows)]
+ cells <- cellFromRowCol(x, theserows, cols)
+ }
+ vals <- getValues(x, startrow, nrows)
+ vals <- as.matrix( aggregate(vals, list(cells), fun, na.rm=na.rm ))[,-1]
+
+ out <- writeValues(out, vals, r)
+ pbStep(pb, r)
+ }
+ pbClose(pb)
+ out <- writeStop(out)
+ x <- readStop(x)
+ return(out)
+ }
+ }
+}
+)
+
+
+
+#library(raster)
+#r <- raster(nc=9, nr=9)
+#r <- raster()
+#r[] = 1:ncell(r)
+#.aggtest(r, 5, 'min', doC=T)
+#aggregate(s, c(2,1,3), 'min', expand=F)
diff --git a/R/aggregate_sp.R b/R/aggregate_sp.R
new file mode 100644
index 0000000..2346bce
--- /dev/null
+++ b/R/aggregate_sp.R
@@ -0,0 +1,249 @@
+# 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 at data))
+ ag <- aggregate(x at 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 at polygons)) {
+ x <- 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) {
+ 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 at polygons[[i]]@Polygons)
+ p <- c(p, lapply(1:nsubobs, function(j) x at polygons[[i]]@Polygons[[j]]))
+ }
+ x <- SpatialPolygons(list(Polygons(p, '1')), proj4string=x at proj4string)
+ }
+ #if (hd) {
+ # x <- SpatialPolygonsDataFrame(x, data=data.frame(ID=1))
+ #}
+ return(x)
+
+ } else {
+
+ dat <- x at data
+ cn <- colnames(dat)
+ v <- .getVars(by, cn)
+
+ dat <- dat[,v, drop=FALSE]
+ crs <- x at 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 at 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) 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], ]
+ try( z <- rgeos::gUnaryUnion(z), silent=TRUE )
+ 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 <- do.call(rbind, x)
+ x at proj4string <- crs
+ rownames(dat) <- NULL
+ 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 at lines)) {
+ x <- 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 at lines[[i]]@Lines)
+ p <- c(p, lapply(1:nsubobs, function(j) x at lines[[i]]@Lines[[j]]))
+ }
+ x <- SpatialLines(list(Lines(p, '1')), proj4string=x at proj4string)
+ return(x)
+
+ } else {
+
+ dat <- x at data
+ cn <- colnames(dat)
+ v <- .getVars(by, cn)
+
+ dat <- dat[,v, drop=FALSE]
+ crs <- x at 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 at 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) spChFIDs(aggregate(x[dc[dc$v==y,1],]), as.character(y)))
+
+ x <- do.call(rbind, x)
+ x at proj4string <- crs
+ rownames(dat) <- NULL
+ SpatialLinesDataFrame(x, dat, FALSE)
+ }
+}
+)
+
+
diff --git a/R/alignExtent.R b/R/alignExtent.R
new file mode 100644
index 0000000..95d8b64
--- /dev/null
+++ b/R/alignExtent.R
@@ -0,0 +1,118 @@
+# 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 at xmin-orig[1]) / res[1]) * res[1] + orig[1]
+ xmx <- round((extent at xmax-orig[1]) / res[1]) * res[1] + orig[1]
+ ymn <- round((extent at ymin-orig[2]) / res[2]) * res[2] + orig[2]
+ ymx <- round((extent at ymax-orig[2]) / res[2]) * res[2] + orig[2]
+ } else if (snap == 'out') {
+ xmn <- floor((extent at xmin-orig[1]) / res[1]) * res[1] + orig[1]
+ xmx <- ceiling((extent at xmax-orig[1]) / res[1]) * res[1] + orig[1]
+ ymn <- floor((extent at ymin-orig[2]) / res[2]) * res[2] + orig[2]
+ ymx <- ceiling((extent at ymax-orig[2]) / res[2]) * res[2] + orig[2]
+ } else if (snap == 'in') {
+ xmn <- ceiling((extent at xmin-orig[1]) / res[1]) * res[1] + orig[1]
+ xmx <- floor((extent at xmax-orig[1]) / res[1]) * res[1] + orig[1]
+ ymn <- ceiling((extent at ymin-orig[2]) / res[2]) * res[2] + orig[2]
+ ymx <- floor((extent at ymax-orig[2]) / res[2]) * res[2] + orig[2]
+ }
+
+ if (xmn == xmx) {
+ if (xmn < extent at xmin) {
+ xmx <- xmx + res[1]
+ } else {
+ xmn <- xmn - res[1]
+ }
+ }
+ if (ymn == ymx) {
+ if (ymn < extent at ymin) {
+ ymx <- ymx + res[2]
+ } else {
+ ymn <- ymn - res[2]
+ }
+ }
+ extent(xmn, xmx, ymn, ymx)
+}
+
+
+.Old.alignExtent <- function(extent, object) {
+ object <- raster(object)
+ oldext <- extent(object)
+ e <- extent(extent)
+ e at xmin <- min(e at xmin, oldext at xmin)
+ e at xmax <- max(e at xmax, oldext at xmax)
+ e at ymin <- min(e at ymin, oldext at ymin)
+ e at ymax <- max(e at ymax, oldext at ymax)
+
+
+ col <- colFromX(object, e at xmin)
+ mn <- xFromCol(object, col) - 0.5 * xres(object)
+ mx <- xFromCol(object, col) + 0.5 * xres(object)
+ if (abs(e at xmin - mn) > abs(e at xmin - mx)) {
+ e at xmin <- mx
+ } else {
+ e at xmin <- mn
+ }
+ col <- colFromX(object, e at xmax)
+ if (is.na(col))
+ mn <- xFromCol(object, col) - 0.5 * xres(object)
+ mx <- xFromCol(object, col) + 0.5 * xres(object)
+ if (abs(e at xmax - mn) > abs(e at xmax - mx)) {
+ e at xmax <- mx
+ } else {
+ e at xmax <- mn
+ }
+
+ row <- rowFromY(object, e at ymin)
+ mn <- yFromRow(object, row) - 0.5 * yres(object)
+ mx <- yFromRow(object, row) + 0.5 * yres(object)
+ if (abs(e at ymin - mn) > abs(e at ymin - mx)) {
+ e at ymin <- mx
+ } else {
+ e at ymin <- mn
+ }
+ row <- rowFromY(object, e at ymax)
+ mn <- yFromRow(object, row) - 0.5 * yres(object)
+ mx <- yFromRow(object, row) + 0.5 * yres(object)
+ if (abs(e at ymax - mn) > abs(e at ymax - mx)) {
+ e at ymax <- mx
+ } else {
+ e at ymax <- mn
+ }
+
+ if ( e at ymin == e at ymax ) {
+ if (oldext at ymax > e at ymax) {
+ e at ymax = e at ymax + yres(object)
+ }
+ if (oldext at ymin < e at ymin) {
+ e at ymin = e at ymin - yres(object)
+ }
+ }
+ if ( e at xmin == e at xmax ) {
+ if (oldext at xmax > e at xmax) {
+ e at xmax = e at xmax + xres(object)
+ }
+ if (oldext at xmin < e at xmin) {
+ e at xmin = e at xmin - xres(object)
+ }
+ }
+ return(e)
+}
+
+
diff --git a/R/animate.R b/R/animate.R
new file mode 100644
index 0000000..a7eb200
--- /dev/null
+++ b/R/animate.R
@@ -0,0 +1,38 @@
+
+if (!isGeneric("animate")) {
+ setGeneric("animate", function(x, ...)
+ standardGeneric("animate"))
+}
+
+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, ...)
+ dev.flush()
+ Sys.sleep(pause)
+ i <- i + 1
+ if (i > nl) {
+ i <- 1
+ reps <- reps+1
+ }
+ }
+}
+)
+
+#anim(st, tvals)
diff --git a/R/approxNA.R b/R/approxNA.R
new file mode 100644
index 0000000..89cab66
--- /dev/null
+++ b/R/approxNA.R
@@ -0,0 +1,104 @@
+# Author: Robert J. Hijmans
+# Date : February 2012
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("approxNA")) {
+ setGeneric("approxNA", function(x, ...)
+ standardGeneric("approxNA"))
+}
+
+
+
+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)) {
+ j <- s == (nl-1) # one non-NA only
+ if (length(j) > 0 ) {
+ x[j, ] <- apply(x[j, ], 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,], 1, function(x) 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,], 1, function(x) 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,], 1, function(x) 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,], 1, function(x) 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),tr$nrows[j], nc)
+ if (isTRUE(NArule)) {
+ j <- s == (nl-1) # one non-NA only
+ if (length(j) > 0 ) {
+ v[j, ] <- apply(v[j, ], 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,], 1, function(x) 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,], 1, function(x) 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,], 1, function(x) 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,], 1, function(x) 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)
+}
+)
+
diff --git a/R/area.R b/R/area.R
new file mode 100644
index 0000000..6b92e9e
--- /dev/null
+++ b/R/area.R
@@ -0,0 +1,279 @@
+# 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
+}
+
+
+if (!isGeneric("area")) {
+ setGeneric("area", function(x, ...)
+ standardGeneric("area"))
+}
+
+setMethod('area', signature(x='SpatialPolygons'),
+ function(x, ...) {
+ if (couldBeLonLat(x)) {
+ if (!isLonLat(x)) {
+ warning('assuming that the CRS is longitude/latitude!')
+ }
+
+ a <- 6378137
+ f <- 1/298.257223563
+ x <- x at polygons
+ n <- length(x)
+ res <- vector(length=n)
+ for (i in 1:n) {
+ parts <- length(x[[i]]@Polygons )
+ sumarea <- 0
+ for (j in 1:parts) {
+ crd <- x[[i]]@Polygons[[j]]@coords
+ ar <- .Call("polygonarea", as.double(crd[,1]), as.double(crd[,2]), as.double(a), as.double(f), PACKAGE='raster')
+ if (x[[i]]@Polygons[[j]]@hole) {
+ sumarea <- sumarea - ar
+ } else {
+ sumarea <- sumarea + ar
+ }
+ }
+ res[i] <- sumarea
+ }
+ res <- abs(res)
+ return(res)
+ }
+ if (requireNamespace("rgeos")) {
+ as.vector(rgeos::gArea(x, byid=TRUE))
+ } else {
+ warning('install rgeos for better area estimation')
+ sapply(x at polygons, function(i) methods::slot(i, 'area'))
+ }
+ }
+)
+
+
+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 at 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 at 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 at 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)
+ }
+)
+
+
diff --git a/R/arith_sp.R b/R/arith_sp.R
new file mode 100644
index 0000000..dd13707
--- /dev/null
+++ b/R/arith_sp.R
@@ -0,0 +1,40 @@
+# 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)
+ }
+)
diff --git a/R/artith.R b/R/artith.R
new file mode 100644
index 0000000..aa3e0f0
--- /dev/null
+++ b/R/artith.R
@@ -0,0 +1,375 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 1.0
+# Licence GPL v3
+
+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 <- projection(e1)
+ proj2 <- projection(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)) {
+ 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='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 at 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 at data@values), e1) )
+ }
+)
+
+
+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, 3)) {
+ 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, 3)) {
+ 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, 3)) {
+ 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, 3)) {
+ 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)
+ }
+)
+
+
+setMethod("Arith", signature(e1='Extent', e2='numeric'),
+ function(e1, e2){
+
+ if (length(e2) == 1) {
+ x1 = e2
+ x2 = e2
+ } else if (length(e2) == 2) {
+ x1 = e2[1]
+ x2 = e2[2]
+ } else if (length(e2) == 4) {
+ return(extent(methods::callGeneric(as.vector(e1), e2)))
+ } else {
+ stop('On an Extent object, you can only use Arith with a single number or with two numbers')
+ }
+
+ r <- e1 at xmax - e1 at xmin
+ d <- methods::callGeneric(r, x1)
+ d <- (d - r) / 2
+ e1 at xmax <- e1 at xmax + d
+ e1 at xmin <- e1 at xmin - d
+
+ r <- e1 at ymax - e1 at ymin
+ d <- methods::callGeneric(r, x2)
+ d <- (d - r) / 2
+ e1 at ymax <- e1 at ymax + d
+ e1 at ymin <- e1 at ymin - d
+ return(e1)
+ }
+)
+
+setMethod("Arith", signature(e1='numeric', e2='Extent'),
+ function(e1, e2){
+ methods::callGeneric(e2,e1)
+ }
+)
+
diff --git a/R/as.array.R b/R/as.array.R
new file mode 100644
index 0000000..3d92724
--- /dev/null
+++ b/R/as.array.R
@@ -0,0 +1,38 @@
+# 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
+} )
+
diff --git a/R/as.data.frame.R b/R/as.data.frame.R
new file mode 100644
index 0000000..a5b42eb
--- /dev/null
+++ b/R/as.data.frame.R
@@ -0,0 +1,119 @@
+# Author: Robert J. Hijmans
+# Date : July 2011
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("as.data.frame")) {
+ setGeneric("as.data.frame", function(x, row.names = NULL, optional = FALSE, ...)
+ standardGeneric("as.data.frame"))
+}
+
+
+.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) {
+ XY <- data.frame(xyFromCell(r, start:end))
+ vv <- stats::na.omit(vv, XY)
+ }
+ 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 <- 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
+ }
+)
+
+
diff --git a/R/as.logical.R b/R/as.logical.R
new file mode 100644
index 0000000..8bfa3b5
--- /dev/null
+++ b/R/as.logical.R
@@ -0,0 +1,108 @@
+# 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)
+ }
+}
+)
diff --git a/R/as.matrix.R b/R/as.matrix.R
new file mode 100644
index 0000000..ead6d87
--- /dev/null
+++ b/R/as.matrix.R
@@ -0,0 +1,46 @@
+# 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 at xmin, x at xmax, x at ymin, x at ymax))
+})
+
+
+setMethod('as.vector', signature(x='Raster'),
+function(x, mode='any') {
+ as.vector(getValues(x))
+})
+
diff --git a/R/as.raster.R b/R/as.raster.R
new file mode 100644
index 0000000..a397265
--- /dev/null
+++ b/R/as.raster.R
@@ -0,0 +1,33 @@
+# 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
+
+
+if (!isGeneric("as.raster")) {
+ setGeneric("as.raster", function(x, ...)
+ standardGeneric("as.raster"))
+}
+
+
+
+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])
+
diff --git a/R/as.spatial.R b/R/as.spatial.R
new file mode 100644
index 0000000..ac57d54
--- /dev/null
+++ b/R/as.spatial.R
@@ -0,0 +1,78 @@
+
+
+setAs('data.frame', 'SpatialPolygons',
+ function(from) {
+ 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 <- Polygon( as.matrix(ss[,c('x', 'y')] ))
+ if (ss$hole[1]) {
+ pol at hole <- TRUE
+ }
+ pp[[j]] <- pol
+ }
+ sp[[i]] <- Polygons(pp, as.character(i))
+ }
+
+ 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]
+ SpatialPolygonsDataFrame(x, d)
+ } else {
+ x
+ }
+ }
+)
+
+
+
+
+setAs('data.frame', 'SpatialLines',
+ function(from) {
+ 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 <- Line(as.matrix(ss[,c('x', 'y')]))
+ pp[[j]] <- ln
+ }
+ sp[[i]] <- Lines(pp, as.character(i))
+ }
+ 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]
+ SpatialLinesDataFrame(x, d)
+ } else {
+ x
+ }
+ }
+)
+
+
diff --git a/R/atan2.R b/R/atan2.R
new file mode 100644
index 0000000..801e077
--- /dev/null
+++ b/R/atan2.R
@@ -0,0 +1,43 @@
+# Author: Robert J. Hijmans
+# Date : March 2011
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("atan2")) {
+ setGeneric("atan2", function(y, x)
+ standardGeneric("atan2"))
+}
+
+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)
+ }
+)
+
diff --git a/R/bands.R b/R/bands.R
new file mode 100644
index 0000000..90b5de0
--- /dev/null
+++ b/R/bands.R
@@ -0,0 +1,38 @@
+# 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 at data@band)
+}
+)
+
+
+nbands <- function(x) {
+ cx = class(x)
+ if (inherits(x, "RasterLayer") | inherits(x, "RasterBrick")) {
+ return(x at 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 at file@bandorder))
+ }
+}
+
diff --git a/R/barplot.R b/R/barplot.R
new file mode 100644
index 0000000..e1d9824
--- /dev/null
+++ b/R/barplot.R
@@ -0,0 +1,34 @@
+# Author: Robert J. Hijmans
+# Date : September 2012
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("barplot")) {
+ setGeneric("barplot", function(height,...)
+ standardGeneric("barplot"))
+}
+
+
+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, ...)
+ }
+)
diff --git a/R/bbox.R b/R/bbox.R
new file mode 100644
index 0000000..3379e8d
--- /dev/null
+++ b/R/bbox.R
@@ -0,0 +1,27 @@
+# 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 at xmin
+ bb[1,2] <- obj at xmax
+ bb[2,1] <- obj at ymin
+ bb[2,2] <- obj at ymax
+ return(bb)
+ }
+)
+
+setMethod('bbox', signature(obj='Raster'),
+ function(obj) {
+ obj <- extent(obj)
+ return( bbox(obj) )
+ }
+)
+
diff --git a/R/bilinearValue.R b/R/bilinearValue.R
new file mode 100644
index 0000000..483a214
--- /dev/null
+++ b/R/bilinearValue.R
@@ -0,0 +1,117 @@
+# 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)
+
+ w <- getOption('warn')
+ options('warn'=-1)
+ row1 <- rowFromCell(r, min(cells, na.rm=TRUE))
+ options('warn' = w)
+ 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
+ }
+}
+
diff --git a/R/bind.R b/R/bind.R
new file mode 100644
index 0000000..2054c32
--- /dev/null
+++ b/R/bind.R
@@ -0,0 +1,369 @@
+# Author: Robert J. Hijmans
+# Date : November 2011
+# Version 1.0
+# Licence GPL v3
+
+
+
+.uniqueNames <- function(x, sep='.') {
+ y <- as.matrix(table(x))
+ y <- y[y[,1] > 1, ,drop=F]
+ if (nrow(y) > 0) {
+ y <- rownames(y)
+ for (i in 1:length(y)) {
+ j <- which(x==y[i])
+ x[j] <- paste(x[j], sep, 1:length(j), sep='')
+ }
+ }
+ x
+}
+
+
+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) {
+
+ x <- list(x, y, ...)
+
+ #p <- sapply(x, proj4string)
+ #if (!isTRUE(all(p==p[1]))) { }
+ haswarned <- FALSE
+ projx <- proj4string(x[[1]])
+ for (i in 2:length(x)) {
+ if (is.na(proj4string(x[[i]]))) {
+ x[[i]]@proj4string <- x[[1]]@proj4string
+ } else if (! identical(projx, proj4string(x[[i]])) ) {
+ if (!haswarned) {
+ warning('non identical CRS')
+ haswarned <- TRUE
+ }
+ x[[i]]@proj4string <- x[[1]]@proj4string
+ }
+ }
+
+ 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')) {
+ return( do.call( rbind, 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)
+ return( SpatialPolygonsDataFrame(x, dat) )
+ }
+
+
+ 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)
+ SpatialPolygonsDataFrame(x, dat, match.ID=FALSE)
+}
+)
+
+
+
+
+setMethod('bind', signature(x='SpatialLines', y='SpatialLines'),
+ function(x, y, ..., keepnames=FALSE) {
+
+ x <- list(x, y, ...)
+
+ haswarned <- FALSE
+ projx <- proj4string(x[[1]])
+ for (i in 2:length(x)) {
+ if (is.na(proj4string(x[[i]]))) {
+ x[[i]]@proj4string <- x[[1]]@proj4string
+ } else if (! identical(projx, proj4string(x[[i]])) ) {
+ if (!haswarned) {
+ warning('non identical CRS')
+ haswarned <- TRUE
+ }
+ x[[i]]@proj4string <- x[[1]]@proj4string
+ }
+ }
+
+
+ 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')) {
+ return( do.call( rbind, 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)
+ return( SpatialLinesDataFrame(x, dat) )
+ }
+
+
+ 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)
+ SpatialLinesDataFrame(x, dat, match.ID=FALSE)
+}
+)
+
+
+
+
+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)
+ SpatialPointsDataFrame(x, dat)
+}
+)
+
+
diff --git a/R/blend.R b/R/blend.R
new file mode 100644
index 0000000..9d9b2d2
--- /dev/null
+++ b/R/blend.R
@@ -0,0 +1,131 @@
+# Authors: Rafael Wueest, WSL Birmensdorf, Switzerland, rafael.wueest at 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
+}
+
diff --git a/R/blockSize.R b/R/blockSize.R
new file mode 100644
index 0000000..7eb3bdd
--- /dev/null
+++ b/R/blockSize.R
@@ -0,0 +1,42 @@
+# 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 <- .chunksize() / n
+ } else {
+ bs <- chunksize
+ }
+
+ blockrows <- try(methods::slot(x at file, 'blockrows'), silent=TRUE)
+ if (class(blockrows) == 'try-error') {
+ blockrows <- 1
+ }
+ blockrows <- max(blockrows, 1)
+
+
+ nr <- nrow(x)
+ size <- min(nr, max(1, floor(bs / ncol(x))))
+ # 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))
+}
+
diff --git a/R/boundaries.R b/R/boundaries.R
new file mode 100644
index 0000000..c88b8ba
--- /dev/null
+++ b/R/boundaries.R
@@ -0,0 +1,136 @@
+# Author: Robert J. Hijmans
+# Date : November 2011
+# Version 1.0
+# Licence GPL v3
+
+
+# name overlap with igraph
+..edge <- function(x, ...) {
+ warning('"edge" is obsolete and will be removed from this package. Use the "boundaries" function instead')
+ boundaries(x, ...)
+ warning('"edge" is obsolete and will be removed from this package. Use the "boundaries" function instead')
+}
+
+
+
+if (!isGeneric("boundaries")) {
+ setGeneric("boundaries", function(x, ...)
+ standardGeneric("boundaries"))
+}
+
+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 <- as.integer(0)
+ } else {
+ type <- as.integer(1)
+ }
+ classes <- as.integer(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 <- .Call('edge', as.integer(t(x)), paddim, classes, type, directions, NAOK=TRUE, PACKAGE='raster')
+ 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 <- as.integer(cbind(v[,1], v))
+
+ v <- .Call('edge', v, as.integer(c(tr$nrows[1]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster')
+ 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)
+ 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 <- .Call('edge', as.integer(v), as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster')
+ 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 <- as.integer(cbind(v, v[,ncol(v)]))
+ v <- .Call('edge', v, as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions, NAOK=TRUE, PACKAGE='raster')
+ 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)
+}
+)
+
+
diff --git a/R/boxplot.R b/R/boxplot.R
new file mode 100644
index 0000000..aeab396
--- /dev/null
+++ b/R/boxplot.R
@@ -0,0 +1,59 @@
+# Author: Robert J. Hijmans
+# Date : November 2010
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("boxplot")) {
+ setGeneric("boxplot", function(x, ...)
+ standardGeneric("boxplot"))
+}
+
+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 <- as.formula(paste(cn[1], '~', cn[2]))
+ boxplot(f, data=s, ...)
+ }
+ }
+)
+
diff --git a/R/brick.R b/R/brick.R
new file mode 100644
index 0000000..277f0de
--- /dev/null
+++ b/R/brick.R
@@ -0,0 +1,300 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("brick")) {
+ setGeneric("brick", function(x, ...)
+ standardGeneric("brick"))
+}
+
+
+
+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 at xmin > -400 & e at xmax < 400 & e at ymin > -90.1 & e at ymax < 90.1) {
+ crs ="+proj=longlat +datum=WGS84"
+ } else {
+ crs=NA
+ }
+ }
+ 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 at extent, nrows=nrow(x), ncols=ncol(x), crs=projection(x), nl=nl)
+ if (rotated(x)) {
+ b at rotated <- TRUE
+ b at rotation <- x at 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 at extent
+ b <- brick(xmn=e at xmin, xmx=e at xmax, ymn=e at ymin, ymx=e at ymax, nrows=x at nrows, ncols=x at ncols, crs=projection(x))
+ if (rotated(x)) {
+ b at rotated <- TRUE
+ b at rotation <- x at rotation
+ }
+
+ if (missing(nl)) {
+ nl <- nlayers(x)
+ if (nl < 1) {
+ values <- FALSE
+ }
+ } else {
+ nl <- max(round(nl), 0)
+ values <- FALSE
+ }
+
+ b at data@nlayers <- as.integer(nl)
+
+ filename <- trim(filename)
+
+ if (values) {
+
+ b at data@names <- names(x)[1:nl]
+ if (canProcessInMemory(b, nl*2)) {
+ b <- setValues( b, getValues(x)[,1:nl])
+ if (any(is.factor(x))) {
+ b at data@isfactor <- is.factor(x)
+ b at 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 at data@min <- rep(Inf, b at data@nlayers)
+ b at data@max <- rep(-Inf, b at data@nlayers)
+ return(b)
+ }
+ }
+)
+
+setMethod('brick', signature(x='RasterBrick'),
+ function(x, nl, ...){
+ if (missing(nl)) {
+ nl <- nlayers(x)
+ }
+ e <- x at extent
+ b <- brick(xmn=e at xmin, xmx=e at xmax, ymn=e at ymin, ymx=e at ymax, nrows=x at nrows, ncols=x at ncols, crs=projection(x))
+ b at data@nlayers <- as.integer(nl)
+ b at data@min <- rep(Inf, nl)
+ b at data@max <- rep(-Inf, nl)
+ if (rotated(x)) {
+ b at rotated <- TRUE
+ b at rotation <- x at rotation
+ }
+ return(b)
+ }
+)
+
+
+
+setMethod('brick', signature(x='Extent'),
+ function(x, nrows=10, ncols=10, crs=NA, nl=1) {
+ 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("RasterBrick", extent=bb, ncols=nc, nrows=nr)
+ projection(b) <- crs
+ nl <- max(round(nl), 0)
+ b at data@nlayers <- as.integer(nl)
+ b at data@isfactor <- rep(FALSE, nl)
+ return(b)
+ }
+)
+
+
+setMethod('brick', signature(x='SpatialGrid'),
+ function(x){
+ b <- brick()
+ extent(b) <- extent(x)
+ projection(b) <- x at proj4string
+ dim(b) <- c(x at grid@cells.dim[2], x at grid@cells.dim[1])
+
+ if (class(x) == 'SpatialGridDataFrame') {
+
+ x <- x at data
+
+ b at data@isfactor <- rep(FALSE, ncol(x))
+
+ isfact <- sapply(x, function(i) is.factor(i) | is.character(i))
+ b at 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 at data@attributes[[i]] <- rat
+ x[,i] <- as.integer(x[,i])
+ }
+ }
+
+ b <- setValues(b, as.matrix(x))
+ b at 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=NA, 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)
+ }
+)
+
diff --git a/R/buffer.R b/R/buffer.R
new file mode 100644
index 0000000..e346c5d
--- /dev/null
+++ b/R/buffer.R
@@ -0,0 +1,96 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric('buffer')) {
+ setGeneric('buffer', function(x, ...)
+ standardGeneric('buffer'))
+}
+
+setMethod('buffer', signature(x='Spatial'),
+function(x, width=1, dissolve=TRUE, ...) {
+ stopifnot(requireNamespace("rgeos"))
+ rgeos::gBuffer(x, byid=!dissolve, width=width, ...)
+}
+)
+
+
+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) == "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(4, label='buffer', ...)
+ 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("distanceToNearestPoint", xy, pts, as.integer(longlat), PACKAGE='raster')
+ pbStep(pb)
+ x[x > width] <- NA
+ x[!is.na(x)] <- 1
+ 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='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("distanceToNearestPoint", xy[j,,drop=FALSE], pts, as.integer(longlat), 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)
+}
+)
+
diff --git a/R/calc.R b/R/calc.R
new file mode 100644
index 0000000..6eb9aa6
--- /dev/null
+++ b/R/calc.R
@@ -0,0 +1,274 @@
+# Author: Robert J. Hijmans & Matteo Mattiuzzi
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("calc")) {
+ setGeneric("calc", function(x, fun, ...)
+ standardGeneric("calc"))
+}
+
+
+.makeTextFun <- function(fun) {
+ if (class(fun) != '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 at 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) | class(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 (class(test) == 'try-error') {
+ test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE)
+ doapply <- TRUE
+ if (class(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) | class(test) == 'try-error') {
+ doapply <- TRUE
+ makemat <- TRUE
+ tstdat <- matrix(tstdat, ncol=1)
+ test <- try( apply(tstdat, 1, fun), silent=TRUE)
+ if (class(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 (class(test) == 'try-error') {
+ doapply <- FALSE
+ test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE)
+ if (class(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 (class(test) == 'try-error') {
+ doapply <- FALSE
+ test <- try(fun(tstdat), silent=TRUE)
+ if (class(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
+
+ if (test$nlout == 1) {
+ out <- raster(x)
+ } else {
+ out <- brick(x, values=FALSE)
+ out at data@nlayers <- test$nlout
+ }
+
+ fun <- .makeTextFun(fun)
+ if (class(fun) == 'character') {
+ doapply <- FALSE
+ fun <- .getRowFun(fun)
+ }
+
+ filename <- trim(filename)
+
+ if (canProcessInMemory(x, max(nlayers(x), nlayers(out)) * 2)) {
+ 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)
+ 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)
+ } 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)
+ } 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)
+}
+)
+
+
diff --git a/R/canProcessInMemory.R b/R/canProcessInMemory.R
new file mode 100644
index 0000000..49c4f62
--- /dev/null
+++ b/R/canProcessInMemory.R
@@ -0,0 +1,70 @@
+# Authors: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+canProcessInMemory <- function(x, n=4) {
+
+
+# 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)
+ }
+
+ n <- n + nlayers(x) - 1
+ cells <- round( 1.1 * ncell(x) ) * n
+
+ if ( cells > .maxmemory() ) {
+ return(FALSE)
+ } else {
+ return(TRUE)
+ }
+}
+
+# if (cells > .maxmemory()) {
+# return(FALSE)
+# } else if ( cells < 1000000 ) {
+# return(TRUE)
+# } else {
+# return(TRUE)
+# }
+
+
+# if (substr( R.Version()$platform, 1, 7) == "i386-pc" ) {
+# # windows, function memory.size available
+# memneed <- cells * 8 * n / (1024 * 1024)
+# memavail <- 0.5 * (memory.size(NA)-memory.size(FALSE))
+# if (memneed > memavail) {
+# return(FALSE)
+# } else {
+# return(TRUE)
+# }
+# } else {
+
+# g <- gc()
+
+
+# if (.Platform$OS.type == "unix"){
+## Memory in KB, from: http://stackoverflow.com/questions/2441046/how-to-get-physical-memory-in-bash
+# mem <- as.numeric(system("grep MemTotal /proc/meminfo | awk '{print $2}'",intern=TRUE))
+
+# w <- getOption('warn')
+# on.exit(options('warn'= w))
+# options('warn'=-1)
+# r <- try( matrix(0.1, ncol=n, nrow=cells), silent=TRUE )
+
+# if (class(r) == "try-error") {
+# return( FALSE )
+# g <- gc()
+# return( TRUE )
+# }
diff --git a/R/cellFromLine.R b/R/cellFromLine.R
new file mode 100644
index 0000000..aa16dc5
--- /dev/null
+++ b/R/cellFromLine.R
@@ -0,0 +1,35 @@
+# Author: Robert J. Hijmans
+# Date : December 2009
+# Version 0.9
+# Licence GPL v3
+
+cellFromLine <- function(object, lns) {
+ spbb <- bbox(lns)
+ rsbb <- bbox(object)
+ addres <- 2 * max(res(object))
+ nlns <- length( lns at 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 <- 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] )
+}
+
diff --git a/R/cellFromPolygon.R b/R/cellFromPolygon.R
new file mode 100644
index 0000000..69910f7
--- /dev/null
+++ b/R/cellFromPolygon.R
@@ -0,0 +1,54 @@
+# Author: Robert J. Hijmans
+# Date : January 2011
+# Version 1.0
+# Licence GPL v3
+
+
+cellFromPolygon <- function(object, p, weights=FALSE) {
+
+ spbb <- bbox(p)
+ rsbb <- bbox(object)
+ addres <- max(res(object))
+ npol <- length(p at 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 <- 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)
+ 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] )
+}
+
+
+
diff --git a/R/cellRowCol.R b/R/cellRowCol.R
new file mode 100644
index 0000000..259309d
--- /dev/null
+++ b/R/cellRowCol.R
@@ -0,0 +1,92 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+
+
+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 at 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]))
+}
+
+
+cellFromRowColCombine <- function(object, rownr, colnr) {
+ object <- raster(object)
+ rownr[rownr < 1 | rownr > object at nrows] <- NA
+ colnr[colnr < 1 | colnr > object at ncols] <- NA
+ cols <- rep(colnr, times=length(rownr))
+ dim(cols) <- c(length(colnr), length(rownr))
+ cols <- t(cols)
+ rownr <- (rownr-1) * object at ncols
+ cols <- cols + rownr
+ as.vector(t(cols))
+}
+
+
+colFromCell <- function(object, cell) {
+ object <- raster(object)
+ cell <- round(cell)
+ cell[cell < 1 | cell > ncell(object)] <- NA
+ rownr <- trunc((cell-1)/object at ncols) + 1
+ as.integer(cell - ((rownr-1) * object at ncols))
+}
+
+.colFromCell <- function(object, cell) {
+ nc <- object at ncols
+ rownr <- trunc((cell-1)/nc) + 1
+ cell - ((rownr-1) * nc)
+}
+
+rowColFromCell <- function(object, cell) {
+ object <- raster(object)
+ cell <- round(cell)
+ cell[cell < 1 | cell > ncell(object)] <- NA
+ row <- as.integer(trunc((cell-1)/object at ncols) + 1)
+ col <- as.integer(cell - ((row-1) * object at ncols))
+ return(cbind(row, col))
+}
+
+cellFromRowCol <- function(object, rownr, colnr) {
+ rows <- object at nrows
+ cols <- object at ncols
+ .doCellFromRowCol(rows, cols, rownr, colnr)
+}
+
+
+
+
diff --git a/R/cellStats.R b/R/cellStats.R
new file mode 100644
index 0000000..3081906
--- /dev/null
+++ b/R/cellStats.R
@@ -0,0 +1,456 @@
+# Author: Robert J. Hijmans
+# Date : March 2009 / April 2012
+# Version 1.0
+# Licence GPL v3
+
+
+
+.csTextFun <- function(fun) {
+ if (class(fun) != '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/(n-1)))
+ }
+ 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)))
+ }
+ } 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)))
+ }
+ 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)))
+ }
+ } 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)
+ }
+)
+
diff --git a/R/cellValues.R b/R/cellValues.R
new file mode 100644
index 0000000..f371da5
--- /dev/null
+++ b/R/cellValues.R
@@ -0,0 +1,77 @@
+# Author: Robert J. Hijmans
+# Date : November 2008
+# Version 1.0
+# Licence GPL v3
+
+
+.cellValues <- function(x, cells, layer, nl, df=FALSE, factors=FALSE) {
+
+ if (inherits(x, 'RasterLayer')) {
+ result <- .readCells(x, cells, 1)
+ lyrs <- layer <- 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]
+ for (i in 1:length(lyrs)) {
+ result[,i] <- .readCells( x at layers[[lyrs[i]]], cells, 1)
+ }
+
+ } else if (inherits(x, 'RasterBrick')) {
+
+ if (inMemory(x)) {
+ cells[cells < 1 | cells > ncell(x)] <- NA
+ if (length(stats::na.omit(cells)) == 0) {
+ return(cells)
+ }
+ result <- x at data@values[cells, lyrs, drop=FALSE]
+
+ } else if (x at 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
+}
+
+
diff --git a/R/cellsFromExtent.R b/R/cellsFromExtent.R
new file mode 100644
index 0000000..2371d43
--- /dev/null
+++ b/R/cellsFromExtent.R
@@ -0,0 +1,30 @@
+# 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 at ymax - 0.5 * yres(object))
+ erow <- rowFromY(object, innerBox at ymin + 0.5 * yres(object))
+ scol <- colFromX(object, innerBox at xmin + 0.5 * xres(object))
+ ecol <- colFromX(object, innerBox at xmax - 0.5 * xres(object))
+
+ if (expand) {
+ srow <- srow - round((extent at ymax - innerBox at ymax) / yres(object))
+ erow <- erow + round((innerBox at ymin - extent at ymin) / yres(object))
+ scol <- scol - round((innerBox at xmin - extent at xmin) / xres(object))
+ ecol <- ecol + round((extent at xmax - innerBox at xmax) / xres(object))
+ }
+
+ return(cellFromRowColCombine(object, srow:erow, scol:ecol))
+}
+
diff --git a/R/clamp.R b/R/clamp.R
new file mode 100644
index 0000000..7658595
--- /dev/null
+++ b/R/clamp.R
@@ -0,0 +1,60 @@
+# Author: Robert J. Hijmans
+# Date : July 2013
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("clamp")) {
+ setGeneric("clamp", function(x, ...)
+ standardGeneric("clamp"))
+}
+
+
+setMethod('clamp', signature(x='Raster'),
+function(x, lower=-Inf, upper=Inf, useValues=TRUE, filename='', ...) {
+
+ stopifnot(lower <= upper)
+
+ if (!hasValues(x)) return(x)
+ range <- sort(as.numeric(c(lower[1], upper[1])))
+ nl <- nlayers(x)
+ if (nl > 1) {
+ out <- brick(x, values=FALSE)
+ } else {
+ out <- raster(x)
+ }
+ useValues <- as.integer(useValues)
+ if (canProcessInMemory(out)) {
+ out <- setValues(out, .Call('clamp', values(x), range, useValues, NAOK=TRUE, PACKAGE='raster'))
+ } 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 <- .Call('clamp', vals, range, useValues, NAOK=TRUE, PACKAGE='raster')
+ 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)
+}
+)
+
+
diff --git a/R/clearValues.R b/R/clearValues.R
new file mode 100644
index 0000000..207cb3b
--- /dev/null
+++ b/R/clearValues.R
@@ -0,0 +1,53 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+.clearRaster <- function(object) {
+ object at data@inmemory <- FALSE
+
+
+# object at data@indices = vector(mode='numeric')
+ object at data@values <- vector()
+ if ( ! fromDisk(object) ) {
+ object at data@min <- Inf
+ object at data@max <- -Inf
+ object at 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 at layers[[i]])) {
+ x at layers[[i]] <- .clearRaster(x at layers[[i]])
+ }
+ }
+ } else if (inherits(x, 'RasterBrick')) {
+ x at data@values <- matrix(NA,0,0)
+ x at data@inmemory <- FALSE
+
+# x at data@indices = c(0,0)
+ if ( ! fromDisk(x) ) {
+ x at data@min <- rep(Inf, nlayers(x))
+ x at data@max <- rep(-Inf, nlayers(x))
+ x at data@haveminmax <- FALSE
+ }
+ }
+ return(x)
+}
+
+
+.clearFile <- function(x) {
+ x at file@name <- ''
+ x at data@fromdisk <- FALSE
+ x at file@driver <- ""
+ return(x)
+}
diff --git a/R/click.R b/R/click.R
new file mode 100644
index 0000000..d74ac49
--- /dev/null
+++ b/R/click.R
@@ -0,0 +1,226 @@
+# Author: Robert J. Hijmans
+# Date : January 2009 - December 2011
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("click")) {
+ setGeneric("click", function(x, ...)
+ standardGeneric("click"))
+}
+
+
+
+.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 at 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 at 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
+ }
+})
+
+
+
+
+
+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 <- SpatialPoints(xyCoords)
+ xyCoords at proj4string <- x at proj4string
+ i <- which(!is.na(over(x, xyCoords)))
+ if (length(i) > 0) {
+ if (.hasSlot(x, 'data')) {
+ x <- x at 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 at proj4string <- x at proj4string
+ i <- which(!is.na(over(x, e)))
+ if (length(i) > 0) {
+ if (.hasSlot(x, 'data')) {
+ x <- x at data[i,]
+ } else {
+ x <- row.names(x)[i]
+ }
+ } else {
+ x <- NULL
+ }
+ x
+ }
+)
+
+setMethod('click', signature(x='SpatialPoints'),
+ function(x, ...) {
+ e <- as(drawExtent(), 'SpatialPolygons')
+ e at proj4string <- x at proj4string
+ i <- which(!is.na(over(x, e)))
+ if (length(i) > 0) {
+ if (.hasSlot(x, 'data')) {
+ x <- x at data[i,]
+ } else {
+ x <- row.names(x)[i]
+ }
+ } else {
+ x <- NULL
+ }
+ x
+ }
+)
diff --git a/R/clump.R b/R/clump.R
new file mode 100644
index 0000000..7e20985
--- /dev/null
+++ b/R/clump.R
@@ -0,0 +1,136 @@
+# 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
+
+if (!isGeneric("clump")) {
+ setGeneric("clump", function(x, ...)
+ standardGeneric("clump"))
+}
+
+
+.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)
+ }
+}
+)
diff --git a/R/clusterR.R b/R/clusterR.R
new file mode 100644
index 0000000..2429b6f
--- /dev/null
+++ b/R/clusterR.R
@@ -0,0 +1,241 @@
+# 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)
+ }
+}
+
diff --git a/R/coerce.R b/R/coerce.R
new file mode 100644
index 0000000..656248d
--- /dev/null
+++ b/R/coerce.R
@@ -0,0 +1,443 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+
+# To sp pixel/grid objects
+
+
+setAs('Raster', 'GridTopology',
+ function(from) {
+ rs <- res(from)
+ orig <- bbox(from)[,1] + 0.5 * rs
+ GridTopology(orig, rs, dim(from)[2:1] )
+ }
+)
+
+setAs('GridTopology', 'RasterLayer',
+ function(from) {
+ raster(extent(from), nrows=from at cells.dim[2], ncols=from at 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 <- SpatialPoints(sp[,1:2], proj4string= crs(r))
+ grd <- as(r, 'GridTopology')
+ 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 <- SpatialPoints(v[,1:2], proj4string= crs(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]])
+ }
+ }
+ }
+ SpatialPixelsDataFrame(points=sp, data=v, grid=grd)
+ } else {
+ warning('object has no values, returning a "SpatialPixels" object')
+ 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')
+ SpatialGrid(grd, proj4string=crs(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 <- SpatialGridDataFrame(grd, proj4string=crs(r), data=as.data.frame(from))
+ } else {
+ warning('object has no values, returning a "SpatialGrid" object')
+ sp <- SpatialGrid(grd, proj4string=crs)
+ }
+ 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) {
+ SpatialPoints(rasterToPoints(from, spatial=FALSE)[,1:2], proj4string=projection(from, FALSE))
+ }
+)
+
+setAs('Raster', 'SpatialPointsDataFrame',
+ function(from) {
+ rasterToPoints(from, spatial=TRUE)
+ }
+)
+
+
+setAs('Extent', 'SpatialPolygons',
+ function(from){
+ p <- rbind(c(from at xmin, from at ymin), c(from at xmin, from at ymax), c(from at xmax, from at ymax), c(from at xmax, from at ymin), c(from at xmin, from at ymin) )
+ SpatialPolygons(list(Polygons(list(Polygon(p)), '1')))
+ }
+)
+
+setAs('Extent', 'SpatialLines',
+ function(from){
+ p <- rbind(c(from at xmin, from at ymin), c(from at xmin, from at ymax), c(from at xmax, from at ymax), c(from at xmax, from at ymin), c(from at xmin, from at ymin) )
+ SpatialLines(list(Lines(list(Line(p)), '1')))
+ }
+)
+
+
+setAs('Extent', 'SpatialPoints',
+ function(from){
+ p <- cbind( x=c( from at xmin, from at xmin, from at xmax, from at xmax), y=c(from at ymin, from at ymax, from at ymin, from at ymax) )
+ 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 at extent <- extent(from)
+ crs(to) <- from at proj4string
+ dim(to) <- c(from at grid@cells.dim[2], from at grid@cells.dim[1])
+ return(to)
+ }
+)
+
+
+setAs('SpatialPixels', 'BasicRaster',
+ function(from){
+ to <- methods::new('BasicRaster')
+ to at extent <- extent(from)
+ crs(to) <- from at proj4string
+ dim(to) <- c(from at grid@cells.dim[2], from at 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 at time
+ nc <- ncol(from at data)
+ r <- raster(from at 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 at data), each=length(time)), as.character(time), sep='')
+ # need to improve this for character, factor variables
+ m <- as.numeric(as.matrix(from at 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')) }
+)
+
+
+#setAs('RasterLayerSparse', 'RasterLayer', function(from){ raster(from) } )
+
+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])
+ }
+)
+
+
+
+# "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
+ }
+)
+
diff --git a/R/colortable.R b/R/colortable.R
new file mode 100644
index 0000000..a7d3205
--- /dev/null
+++ b/R/colortable.R
@@ -0,0 +1,16 @@
+
+
+colortable <- function(x) {
+ if (.hasSlot(x, 'legend')) {
+ x at legend@colortable
+ } else {
+ logical(0)
+ }
+}
+
+
+'colortable<-' <- function(x, value) {
+ # for now assuming values are between 0 and 255!!
+ x at legend@colortable <- value
+ return(x)
+}
diff --git a/R/commonDataType.R b/R/commonDataType.R
new file mode 100644
index 0000000..de09172
--- /dev/null
+++ b/R/commonDataType.R
@@ -0,0 +1,33 @@
+# 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
+}
+
diff --git a/R/compare.R b/R/compare.R
new file mode 100644
index 0000000..11e8e3f
--- /dev/null
+++ b/R/compare.R
@@ -0,0 +1,148 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("all.equal")) {
+ setGeneric("all.equal", function(target, current, ...)
+ standardGeneric("all.equal"))
+}
+
+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 <- projection(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 <- projection(objects[[i]])
+ if (is.na(proj1)) {
+ proj1 <- thisproj
+ } else {
+ crs <- try (compareCRS(proj1, thisproj, unknown=TRUE), silent=TRUE)
+ if (class(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 at geotrans == objects[[1]]@rotation at 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)
+}
+
diff --git a/R/compareCRS.R b/R/compareCRS.R
new file mode 100644
index 0000000..23670ba
--- /dev/null
+++ b/R/compareCRS.R
@@ -0,0 +1,75 @@
+# author Robert Hijmans
+# June 2010
+# version 1.0
+# license GPL3
+
+.compareCRS <- function(...) {
+ warning('use "compareCRS", not ".compareCRS"')
+ compareCRS(...)
+}
+
+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)
+}
+
+
diff --git a/R/compare_Logical.R b/R/compare_Logical.R
new file mode 100644
index 0000000..253aa9a
--- /dev/null
+++ b/R/compare_Logical.R
@@ -0,0 +1,328 @@
+# 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){
+ methods::callGeneric(e2, e1)
+ }
+)
+
+
+
+
+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){
+ methods::callGeneric(e2, e1)
+ }
+)
+
+
+
+
+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 compare()")
+ }
+
+ 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 compare()")
+ }
+
+ 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 at xmin, e1 at xmin)
+ b <- methods::callGeneric(e1 at xmax, e2 at xmax)
+ c <- methods::callGeneric(e2 at ymin, e1 at ymin)
+ d <- methods::callGeneric(e1 at ymax, e2 at ymax)
+ a & b & c & d
+ }
+)
+
diff --git a/R/connection.R b/R/connection.R
new file mode 100644
index 0000000..b086740
--- /dev/null
+++ b/R/connection.R
@@ -0,0 +1,107 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("readStart")) {
+ setGeneric("readStart", function(x, ...)
+ standardGeneric("readStart"))
+}
+
+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 at layers, fromDisk)
+ ld <- sum(fd)
+ if (isTRUE( ld > 0 & ld <= maxopen)) {
+ d <- which(fd)
+ for (i in d) {
+ x at layers[[i]] <- readStart(x at layers[[i]], con.check=103, ...)
+ }
+ }
+ x
+ }
+)
+
+
+
+
+.openConnection <- function(x, silent=TRUE, con.check=Inf, ...) {
+ fn <- trim(x at file@name)
+ driver <- .driver(x)
+ if (driver == "gdal") {
+ attr(x at file, "con") <- rgdal::GDAL.open(fn, silent=silent)
+ x at 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 at file, "con") <- file(fn, "rb")
+ x at file@open <- TRUE
+ }
+ } else if (driver == 'netcdf') {
+ attr(x at file, 'con') <- ncdf4::nc_open(x at file@name)
+ x at file@open <- TRUE
+# } else if (driver == 'ascii') { # cannot be opened
+ }
+ x
+}
+
+
+
+
+if (!isGeneric("readStop")) {
+ setGeneric("readStop", function(x, ...)
+ standardGeneric("readStop"))
+}
+
+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 at layers, fromDisk))
+ if (length(d) > 0) {
+ for (i in d) {
+ x at layers[[i]] <- readStop(x at layers[[i]], ...)
+ }
+ }
+ x
+ }
+)
+
+
+.closeConnection <- function(x) {
+ driver <- .driver(x)
+ if (driver == "gdal") {
+ try( rgdal::closeDataset(x at file@con), silent = TRUE )
+ } else if (.isNativeDriver(driver)) {
+ try( close(x at file@con), silent = TRUE )
+ } else if (driver == 'netcdf') {
+ try( ncdf4::nc_close(x at file@con), silent=TRUE)
+ } #else if (driver == 'ascii') { }
+
+ x at file@open <- FALSE
+ attr(x at file, 'con') <- NULL
+ x
+# attr(x at file, "con" <- "")
+}
+
diff --git a/R/contour.R b/R/contour.R
new file mode 100644
index 0000000..addd46e
--- /dev/null
+++ b/R/contour.R
@@ -0,0 +1,74 @@
+# Author: Robert J. Hijmans
+# Date : April 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("contour")) {
+ setGeneric("contour", function(x,...)
+ standardGeneric("contour"))
+}
+
+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]] <- 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]] <- Lines(.contourLines2LineList(cL[cLstack[[i]]]), ID = IDs[i])
+ }
+ SL <- SpatialLines(res, proj4string = projection(x, asText=FALSE))
+ 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 at ncols, byrow=TRUE)[nrow(x):1,] )
+
+ lonlat <- .couldBeLonLat(x, warnings=FALSE)
+ asp <- list(...)$asp
+ if (is.null(asp)) {
+ if (lonlat) {
+ ym <- mean(c(x at extent@ymax, x at extent@ymin))
+ asp <- 1/cos((ym * pi)/180)
+ } else {
+ asp <- 1
+ }
+ filled.contour(x=X,y=Y,z=Z,asp=asp,...)
+ } else {
+ filled.contour(x=X,y=Y,z=Z,...)
+ }
+}
diff --git a/R/cor.R b/R/cor.R
new file mode 100644
index 0000000..bfda04f
--- /dev/null
+++ b/R/cor.R
@@ -0,0 +1,38 @@
+
+.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
+ }
+}
+
+
+
+
diff --git a/R/corLocal.R b/R/corLocal.R
new file mode 100644
index 0000000..5e3a529
--- /dev/null
+++ b/R/corLocal.R
@@ -0,0 +1,178 @@
+# Author: Robert J. Hijmans
+# Date : February 2014
+# Version 1.0
+# Licence GPL v3
+
+
+if ( !isGeneric("corLocal") ) {
+ setGeneric("corLocal", function(x, y, ...)
+ standardGeneric("corLocal"))
+}
+
+
+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))
+ }
+ }
+)
+
diff --git a/R/cover.R b/R/cover.R
new file mode 100644
index 0000000..cc5e3b0
--- /dev/null
+++ b/R/cover.R
@@ -0,0 +1,83 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("cover")) {
+ setGeneric("cover", function(x, y, ...)
+ standardGeneric("cover"))
+}
+
+setMethod('cover', signature(x='RasterLayer', y='RasterLayer'),
+ function(x, y, ..., filename=''){
+
+ rasters <- .makeRasterList(x, y, ...)
+ 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)
+ compareRaster(c(outRaster, 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, 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)
+}
+)
+
diff --git a/R/coverBrick.R b/R/coverBrick.R
new file mode 100644
index 0000000..7fa2c82
--- /dev/null
+++ b/R/coverBrick.R
@@ -0,0 +1,93 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("cover")) {
+ setGeneric("cover", function(x, y, ...)
+ standardGeneric("cover"))
+}
+
+setMethod('cover', signature(x='RasterStackBrick', y='Raster'),
+ function(x, y, ..., filename=''){
+
+ rasters <- .makeRasterList(x, y, ..., unstack=FALSE)
+ 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)
+
+
+ filename <- trim(filename)
+ dots <- list(...)
+ if (is.null(dots$format)) {
+ format <- .filetype(format=format, 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)
+}
+)
+
diff --git a/R/coverPolygons.R b/R/coverPolygons.R
new file mode 100644
index 0000000..6a9affe
--- /dev/null
+++ b/R/coverPolygons.R
@@ -0,0 +1,138 @@
+# Author: Robert J. Hijmans
+# Date : December 2011
+# Version 1.0
+# Licence GPL v3
+
+
+
+if (!isGeneric("cover")) {
+ setGeneric("cover", function(x, y, ...)
+ standardGeneric("cover"))
+}
+
+setMethod('cover', signature(x='SpatialPolygons', y='SpatialPolygons'),
+ function(x, y, ..., identity=FALSE){
+
+ stopifnot(requireNamespace("rgeos"))
+
+ 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) {
+ return(.coverIdentity(x, yy))
+ }
+
+ haswarned <- FALSE
+ for (y in yy) {
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ if (!haswarned) {
+ warning('non identical CRS')
+ haswarned <- TRUE
+ }
+ y at proj4string <- x at proj4string
+ }
+ 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
+}
+)
+
+
+
+
+.coverIdentity <- function(x, yy) {
+
+ haswarned <- FALSE
+ for (y in yy) {
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ if (!haswarned) {
+ warning('non identical CRS')
+ haswarned <- TRUE
+ }
+ y at proj4string <- x at proj4string
+ }
+
+ i <- rgeos::gIntersects(x, y)
+ if (!i) {
+ next
+ }
+
+ x <- spChFIDs(x, as.character(1:length(x)))
+ y <- spChFIDs(y, as.character(1:length(y)))
+
+ if (.hasSlot(x, 'data')) {
+ xnames <- colnames(x at data)
+ } else {
+ xnames <-NULL
+ }
+ if (.hasSlot(y, 'data')) {
+ ynames <- colnames(y at data)
+ } else {
+ ynames <-NULL
+ }
+ if (is.null(xnames) & !is.null(ynames)) {
+ dat <- y at data[NULL, ,drop=FALSE]
+ dat[1:length(x), ] <- NA
+ x <- 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 at polyobj)) { # ??
+ # warning('polygons do not intersect')
+ # next
+ # }
+ # int <- int at 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 at data))
+ rows <- 1:length(idsy)
+
+ dat <- x at data[NULL, ,drop=FALSE]
+ dat[rows, yinx] <- y at data[idsy, yinx]
+ int <- SpatialPolygonsDataFrame(int, dat, match.ID=FALSE)
+ }
+ x <- erase(x, int)
+ if (is.null(x)) {
+ x <- int
+ } else {
+ x <- bind(x, int)
+ }
+ }
+ x
+}
+
+
+
+
diff --git a/R/crop.R b/R/crop.R
new file mode 100644
index 0000000..206203c
--- /dev/null
+++ b/R/crop.R
@@ -0,0 +1,104 @@
+# Authors: Robert J. Hijmans and Jacob van Etten
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("crop")) {
+ setGeneric("crop", function(x, y, ...)
+ standardGeneric("crop"))
+}
+
+
+.copyWithProperties <- function(x) {
+ if (inherits(x, 'RasterStackBrick')) {
+ out <- brick(x, values=FALSE)
+ } else {
+ out <- raster(x)
+ out at legend <- x at legend
+ }
+ names(out) <- names(x)
+ out <- setZ(out, getZ(x))
+ fx <- is.factor(x)
+ if (isTRUE(any(fx))) {
+ out at data@isfactor <- fx
+ out at 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 (class(y) == "try-error") {
+ stop('Cannot get an Extent object from argument y')
+ }
+ methods::validObject(y)
+
+
+ out <- .copyWithProperties(x)
+ leg <- out at 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)) {
+ return(x)
+ }
+
+ nc <- ncol(out)
+ nr <- row2 - row1 + 1
+
+ if (is.null(datatype)) {
+ datatype <- unique(c(dataType(x), 'INT2S'))
+ if (length(datatype) > 1) {
+ datatype <- .commonDataType(datatype)
+ }
+ }
+ dataType(out) <- datatype
+
+ xx <- out
+ xx at ncols <- x at ncols # getValuesBlock might read entire rows and then subset
+ if (canProcessInMemory(xx, 4)) {
+ 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 at legend <- leg
+ }
+ return(out)
+}
+)
+
diff --git a/R/cropSpatial.R b/R/cropSpatial.R
new file mode 100644
index 0000000..3f97a17
--- /dev/null
+++ b/R/cropSpatial.R
@@ -0,0 +1,129 @@
+# 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')
+ y at proj4string <- x at proj4string
+ } else {
+ y <- extent(y)
+ methods::validObject(y)
+ y <- as(y, 'SpatialPolygons')
+ }
+ y at proj4string <- x at proj4string
+ }
+
+ if (! compareCRS(x, y) ) {
+ warning('non identical CRS')
+ }
+ y at proj4string <- x at proj4string
+
+ if (inherits(x, 'SpatialPolygons')) {
+ stopifnot(requireNamespace("rgeos"))
+ .cropSpatialPolygons(x, y, ...)
+ } else if (inherits(x, 'SpatialLines')) {
+ stopifnot(requireNamespace("rgeos"))
+ .cropSpatialLines(x, y, ...)
+ } else if (inherits(x, 'SpatialPoints')) {
+ .cropSpatialPoints(x, y, ...)
+ } else {
+ return( x[y] )
+ }
+ }
+)
+
+
+.cropSpatialPolygons <- function(x, y, ...) {
+
+ y <- rgeos::gUnaryUnion(y)
+ row.names(y) <- '1'
+ 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 at 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 at data[ids, ,drop=FALSE]
+ rownames(data) <- rnx[ids]
+
+ return( SpatialPolygonsDataFrame(y, data) )
+ } else {
+ y <- rgeos::gIntersection(x, y, drop_lower_td=TRUE)
+ #if (inherits(y, "SpatialCollections")) {
+ # y <- y at polyobj
+ #}
+ return(y)
+ }
+}
+
+
+
+.cropSpatialLines <- function(x, y, ...) {
+
+ rnx <- row.names(x)
+ row.names(x) <- as.character(1:length(rnx))
+
+ if (.hasSlot(x, 'data')) {
+
+ # in future versions of rgeos, this intermediate step should not 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)
+ if (inherits(y, "SpatialCollections")) {
+ y <- y at lineobj
+ }
+
+ ids <- strsplit(row.names(y), ' ')
+ ids <- as.numeric(do.call(rbind, ids)[,1])
+ row.names(y) <- as.character(rnx[ids])
+ data <- x at data[ids, ,drop=FALSE]
+ rownames(data) <- rnx[ids]
+
+ SpatialLinesDataFrame(y, data)
+ } else {
+ y <- rgeos::gIntersection(x, y)
+ if (inherits(y, "SpatialCollections")) {
+ y <- y at lineyobj
+ }
+ return(y)
+ }
+}
+
+
+
+.cropSpatialPoints <- function(x, y, ...) {
+
+ i <- which(!is.na(over(x, y)))
+ if (length(i) > 0) {
+ x <- x[i,]
+ } else {
+ x <- NULL
+ }
+ x
+
+}
+
+
diff --git a/R/crosstab.R b/R/crosstab.R
new file mode 100644
index 0000000..0c83c51
--- /dev/null
+++ b/R/crosstab.R
@@ -0,0 +1,121 @@
+# Author: Robert J. Hijmans
+# Date : March 2009
+# Version 1.0
+# Licence GPL v3
+
+# revised April 2011
+
+if (!isGeneric("crosstab")) {
+ setGeneric("crosstab", function(x, y, ...)
+ standardGeneric("crosstab"))
+}
+
+
+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='always'))
+ 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='always'))
+ d <- as.data.frame(d)
+ res <- rbind(res, d)
+ pbStep(pb, i)
+ }
+ pbClose(pb)
+
+ if (nrow(res) == 0) {
+ res <- data.frame(matrix(nrow=0, ncol=length(nms)+1))
+ }
+ colnames(res) <- c(nms, 'Freq')
+
+ if (! useNA ) {
+ i <- which(apply(res, 1, function(x) sum(is.na(x))>0))
+ res <- res[-i, ,drop=FALSE]
+ }
+
+ # keep NA classes if there are any
+ 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)
+ }
+ }
+ f <- eval(parse(text=paste('Freq ~ ', paste(nms , collapse='+'))))
+ res <- stats::xtabs(f, data=res)
+
+ }
+
+ if (long) {
+ if (nrow(res) > 1) {
+ res <- data.frame(res)
+ colnames(res) <- c(nms, 'Freq')
+ res <- res[res$Freq > 0, ,drop=FALSE]
+ }
+ }
+ 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)
+ }
+}
diff --git a/R/cut.R b/R/cut.R
new file mode 100644
index 0000000..bacf594
--- /dev/null
+++ b/R/cut.R
@@ -0,0 +1,82 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("cut")) {
+ setGeneric("cut", function(x, ...)
+ standardGeneric("cut"))
+}
+
+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)
+ }
+}
+)
+
diff --git a/R/cv.R b/R/cv.R
new file mode 100644
index 0000000..c4e7474
--- /dev/null
+++ b/R/cv.R
@@ -0,0 +1,68 @@
+# 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 == TRUE) {
+ return(0)
+ } else {
+ x <- mean(z)
+ if (x == 0) {
+ return(NA)
+ } 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)
+ }
+)
+
diff --git a/R/dataProperties.R b/R/dataProperties.R
new file mode 100644
index 0000000..5b26f66
--- /dev/null
+++ b/R/dataProperties.R
@@ -0,0 +1,68 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+#dataSize <- function(object) {return(object at 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 at layers, function(x) x at file@datanotation))
+ } else {
+ return(x at file@datanotation)
+ }
+}
+
+
+..dataIndices <- function(object) {
+# return(object at data@indices)
+}
+
+
+fromDisk <- function(x) {
+ if (inherits( x, 'RasterStack' )) {
+ return( all( sapply( x at layers, function(x) x at data@fromdisk )))
+ } else {
+ return( x at data@fromdisk )
+ }
+}
+
+inMemory <- function(x) {
+ if (inherits( x, 'RasterStack' )) {
+ return( all( sapply( x at layers, function(x) x at data@inmemory )))
+ } else {
+ return( x at data@inmemory )
+ }
+}
+
+
+hasValues <- 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)
+ }
+}
diff --git a/R/dataType.R b/R/dataType.R
new file mode 100644
index 0000000..ab54ed6
--- /dev/null
+++ b/R/dataType.R
@@ -0,0 +1,110 @@
+# 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 at data@values[] <- as.numeric(x at data@values)
+# }
+ if (size == '4') {
+ x at file@datanotation <- 'FLT4S'
+ x at file@nodatavalue <- -3.4E38
+ } else if (size == '8') {
+ x at file@datanotation <- 'FLT8S'
+ x at file@nodatavalue <- -1.7E308
+ } else {
+ stop("invalid datasize for a FLT (should be 4 or 8)")
+ }
+ } else if (type == "INT") {
+# x at data@min <- round(x at data@min)
+# x at data@max <- round(x at data@max)
+# if (dataContent(x) != 'nodata') {
+# x at data@values[] <- as.integer(round(x at data@values))
+# }
+# }
+
+ if (size == '4') {
+ if (signed) {
+ x at file@datanotation <- 'INT4S'
+ x at file@nodatavalue <- -2147483647
+ } else {
+ x at file@datanotation <- 'INT4U'
+ x at file@nodatavalue <- 4294967295
+ }
+ } else if (size == '2') {
+ if (signed) {
+ x at file@datanotation <- 'INT2S'
+ x at file@nodatavalue <- -32768
+ } else {
+ x at file@datanotation <- 'INT2U'
+ x at file@nodatavalue <- 65535
+ }
+ } else if (size == '1') {
+ if (signed) {
+ x at file@datanotation <- 'INT1S'
+ x at file@nodatavalue <- as.double(NA) # no default NA value
+ } else {
+ x at file@datanotation <- 'INT1U'
+ x at file@nodatavalue <- as.double(NA) # no default NA value
+ }
+# } else if (size == '8') {
+# x at file@nodatavalue <- -9223372036854775808
+# x at file@datanotation <- 'INT8S'
+ } else {
+ stop("invalid datasize for this datatype")
+ }
+ } else if ( type == 'LOG' ) {
+ x at file@nodatavalue <- -128
+ x at file@datanotation <- 'LOG1S'
+ } else {
+ stop("unknown datatype")
+ }
+ return(x)
+}
+
diff --git a/R/density.R b/R/density.R
new file mode 100644
index 0000000..a0e6670
--- /dev/null
+++ b/R/density.R
@@ -0,0 +1,80 @@
+# Author: Robert J. Hijmans
+# Date: December 2009
+# Version 0.1
+# Licence GPL v3
+
+
+if (!isGeneric("density")) {
+ setGeneric("density", function(x, ...)
+ standardGeneric("density"))
+}
+
+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)
+ }
+)
+
diff --git a/R/destair.R b/R/destair.R
new file mode 100644
index 0000000..5a7fa1d
--- /dev/null
+++ b/R/destair.R
@@ -0,0 +1,48 @@
+
+
+
+.destair <- function(x, keepExtent=TRUE) {
+
+ pts <- data.frame(geom(as(x, 'SpatialPolygons')))
+
+ if (keepExtent) {
+ bb <- 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)
+ proj4string(r) <- proj4string(x)
+
+ if (.hasSlot(x, 'data')) {
+ r <- SpatialPolygonsDataFrame(r, x at data)
+ }
+
+ r
+}
+
+
diff --git a/R/dim.R b/R/dim.R
new file mode 100644
index 0000000..cb77f0c
--- /dev/null
+++ b/R/dim.R
@@ -0,0 +1,89 @@
+# 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 at nrows)}
+)
+
+setMethod('ncol', signature(x='BasicRaster'),
+ function(x){ return(x at 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 at nrows <- value[1]
+ x at 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 at nrows <- value[1]
+ x at 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 at nrows <- value[1]
+ x at ncols <- value[2]
+ x at data@nlayers <- value[3]
+ }
+ return(x)
+ }
+)
+
+
diff --git a/R/direction.R b/R/direction.R
new file mode 100644
index 0000000..43c1903
--- /dev/null
+++ b/R/direction.R
@@ -0,0 +1,77 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# revised October 2011
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("direction")) {
+ setGeneric("direction", function(x, ...)
+ standardGeneric("direction"))
+}
+
+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
+ }
+ longlat <- as.integer(longlat)
+ degrees <- as.integer(degrees)
+ from <- as.integer(from)
+
+ 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 (class(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('directionToNearestPoint', xy, pts, longlat, degrees, from, 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("directionToNearestPoint", xy[j, ,drop=FALSE], pts, longlat, degrees, from, PACKAGE='raster')
+ }
+ out <- writeValues(out, vals, tr$row[i])
+ pbStep(pb)
+ }
+ pbClose(pb)
+ out <- writeStop(out)
+ return(out)
+}
+)
+
+
diff --git a/R/disaggregate.R b/R/disaggregate.R
new file mode 100644
index 0000000..01947fe
--- /dev/null
+++ b/R/disaggregate.R
@@ -0,0 +1,121 @@
+# Author: Robert Hijmans
+# Date : October 2008 - December 2011
+# Version 1.0
+# Licence GPL v3
+
+# April 2012: Several patches & improvements by Jim Regetz
+
+
+if (!isGeneric("disaggregate")) {
+ setGeneric("disaggregate", function(x, ...)
+ standardGeneric("disaggregate"))
+}
+
+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)
+}
+)
+
diff --git a/R/distance.R b/R/distance.R
new file mode 100644
index 0000000..999687b
--- /dev/null
+++ b/R/distance.R
@@ -0,0 +1,99 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("distance")) {
+ setGeneric("distance", function(x, y, ...)
+ standardGeneric("distance"))
+}
+
+
+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 (class(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("distanceToNearestPoint", xy, pts, as.integer(longlat), 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("distanceToNearestPoint", xy[j,,drop=FALSE], pts, as.integer(longlat), 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, ...) {
+ if (!requireNamespace("rgeos")) {
+ stop('This function needs the rgeos package to be available')
+ }
+ stopifnot(inherits(class(x), 'SpatialVector'))
+ stopifnot(inherits(class(y), 'SpatialVector'))
+ d <- rgeos::gDistance(x, y, byid=TRUE)
+ apply(d, 1, min)
+}
+)
+
diff --git a/R/distanceFromPoints.R b/R/distanceFromPoints.R
new file mode 100644
index 0000000..21a0ce6
--- /dev/null
+++ b/R/distanceFromPoints.R
@@ -0,0 +1,46 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+distanceFromPoints <- function(object, xy, filename='', ...) {
+
+ pts <- .pointsToMatrix(xy)
+ rm(xy)
+
+ filename <- trim(filename)
+
+ if (couldBeLonLat(object)) {
+ longlat=TRUE
+ } else {
+ longlat=FALSE
+ }
+
+ out <- raster(object)
+ if (canProcessInMemory(out, 4)) {
+ xy <- xyFromCell(out, 1:ncell(out))
+ out <- setValues(out, .Call("distanceToNearestPoint", xy, pts, as.integer(longlat), 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("distanceToNearestPoint", xy, pts, as.integer(longlat), PACKAGE='raster')
+ out <- writeValues(out, vals, tr$row[i])
+ pbStep(pb)
+ }
+ pbClose(pb)
+ out <- writeStop(out)
+ return(out)
+}
+
diff --git a/R/distanceRows.R b/R/distanceRows.R
new file mode 100644
index 0000000..fba37ef
--- /dev/null
+++ b/R/distanceRows.R
@@ -0,0 +1,70 @@
+# 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("distanceToNearestPoint", to, from, as.integer(longlat), 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)
+}
+
diff --git a/R/distanceToEdge.R b/R/distanceToEdge.R
new file mode 100644
index 0000000..7a95f06
--- /dev/null
+++ b/R/distanceToEdge.R
@@ -0,0 +1,28 @@
+
+.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
+}
+
diff --git a/R/dotdens.R b/R/dotdens.R
new file mode 100644
index 0000000..96a3e78
--- /dev/null
+++ b/R/dotdens.R
@@ -0,0 +1,59 @@
+# 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 at data[, field]
+ } else {
+ stopifnot(length(field)==length(p))
+ }
+ } else if (is.character(field)) {
+ stopifnot(field %in% names(p))
+ field <- p at 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 (spsample(p[i, ], d[i], type=f), silent=TRUE )
+ if (class(ires) == 'try-error') {
+ print(paste('error, ', d[i]))
+ ires <- NULL
+ }
+ if (!is.null(ires)) {
+ res[[i]] <- cbind(coordinates(ires), id=i)
+ }
+ }
+ }
+ res <- do.call("rbind", res)
+ colnames(res)[1:2] <- c('x', 'y')
+ if (sp) {
+ res <- data.frame(res)
+ coordinates(res) <- ~ x+y
+ crs(res) <- crs(p)
+ }
+ res
+}
+
+
diff --git a/R/drawExtent.R b/R/drawExtent.R
new file mode 100644
index 0000000..6059f7d
--- /dev/null
+++ b/R/drawExtent.R
@@ -0,0 +1,31 @@
+# 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 at xmin == e at xmax) {
+ e at xmin <- e at xmin - 0.0000001
+ e at xmax <- e at xmax + 0.0000001
+ }
+ if (e at ymin == e at ymax) {
+ e at ymin <- e at ymin - 0.0000001
+ e at ymax <- e at ymax + 0.0000001
+ }
+ if (show) {
+ p <- rbind(c(e at xmin, e at ymin), c(e at xmin, e at ymax), c(e at xmax, e at ymax), c(e at xmax, e at ymin), c(e at xmin, e at ymin) )
+ lines(p, col=col)
+ }
+ return(e)
+}
diff --git a/R/drawPoly.R b/R/drawPoly.R
new file mode 100644
index 0000000..0cbc569
--- /dev/null
+++ b/R/drawPoly.R
@@ -0,0 +1,30 @@
+# 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( SpatialPolygons(list(Polygons(list(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( SpatialLines(list(Lines(list(Line(xy)), "1"))) )
+ } else {
+ return(xy)
+ }
+}
+
diff --git a/R/drivers.R b/R/drivers.R
new file mode 100644
index 0000000..8af5df8
--- /dev/null
+++ b/R/drivers.R
@@ -0,0 +1,36 @@
+# 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', 'big', as.vector(gd[,1]))
+ long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', 'big.matrix', as.vector(gd[,2]))
+ } else {
+ 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)
+}
+
+
\ No newline at end of file
diff --git a/R/dropLayer.R b/R/dropLayer.R
new file mode 100644
index 0000000..f4a0451
--- /dev/null
+++ b/R/dropLayer.R
@@ -0,0 +1,59 @@
+# 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 at layers <- x at 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, ...))
+ }
+ }
+}
+)
+
diff --git a/R/erase.R b/R/erase.R
new file mode 100644
index 0000000..03459b3
--- /dev/null
+++ b/R/erase.R
@@ -0,0 +1,94 @@
+
+if (!isGeneric("erase")) {
+ setGeneric("erase", function(x, y, ...)
+ standardGeneric("erase"))
+}
+
+.gDif <- function(x, y) {
+ xln <- length(x at polygons)
+ yln <- length(y at polygons)
+ 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,])
+ if (is.null(z)) {
+ break
+ }
+ }
+ if (is.null(z)) {
+ x <- x[-i,]
+ rn <- rn[-i]
+ } else {
+ x at polygons[i] <- z at polygons
+ }
+ }
+ if (length(x) > 0) {
+ j <- which(rgeos::gIsValid(x, byid=TRUE, reason=FALSE))
+ #j <- which(gArea(x, byid=TRUE) > 0)
+ 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, ...){
+
+ requireNamespace("rgeos")
+
+ if (! identical(x at proj4string, y at proj4string) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+ if (!.hasSlot(x, 'data')) {
+ d <- data.frame(ID=1:length(x at polygons))
+ rownames(d) <- row.names(x)
+ x <- SpatialPolygonsDataFrame(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,])
+
+ part2 <- SpatialPolygonsDataFrame(part2, x at data[match(row.names(part2), rownames(x at data)), ,drop=FALSE])
+ if (!is.null(part1)) {
+ part2 <- rbind(part1, part2)
+ }
+
+ if (length(part2 at polygons) > 1) {
+ part2 <- aggregate(part2, colnames(part2 at data))
+ }
+ if (dropframe) {
+ return( as(part2, 'SpatialPolygons') )
+ } else {
+ return( part2 )
+ }
+ }
+)
+
diff --git a/R/extend.R b/R/extend.R
new file mode 100644
index 0000000..de64f67
--- /dev/null
+++ b/R/extend.R
@@ -0,0 +1,165 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Licence GPL v3
+# revised November 2011
+# version 1.0
+
+
+
+if (!isGeneric("extend")) {
+ setGeneric("extend", function(x, y, ...)
+ standardGeneric("extend"))
+}
+
+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 at xmin <- x at xmin - y[1]
+ x at xmax <- x at xmax + y[2]
+ x at ymin <- x at ymin - y[3]
+ x at ymax <- x at ymax + y[4]
+ methods::validObject(x)
+ x
+}
+)
+
+
+
+setMethod('extend', signature(x='Raster'),
+function(x, y, value=NA, filename='', ...) {
+
+ if (is.vector(y)) {
+ if (length(y) <= 2) {
+ adj <- abs(y) * rev(res(x))
+ y <- extent(x)
+ y at ymin <- y at ymin - adj[1]
+ y at ymax <- y at ymax + adj[1]
+ y at xmin <- y at xmin - adj[2]
+ y at xmax <- y at xmax + adj[2]
+ }
+ }
+
+ test <- try ( y <- extent(y), silent=TRUE )
+ if (class(test) == "try-error") {
+ stop('Cannot get an Extent object from argument y')
+ }
+
+ filename <- trim(filename)
+
+ y <- alignExtent(y, x)
+# only expanding here, not cropping
+ y <- union(y, extent(x))
+
+ if (nlayers(x) <= 1) {
+ out <- raster(x)
+ leg <- x at legend
+ } else {
+ out <- brick(x, values=FALSE)
+ leg <- methods::new('.RasterLegend')
+ }
+ out at 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)
+
+ }
+}
+)
+
+
diff --git a/R/extension.R b/R/extension.R
new file mode 100644
index 0000000..28e9320
--- /dev/null
+++ b/R/extension.R
@@ -0,0 +1,99 @@
+# 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)
+ if (def != '') {
+ extension(f) <- def
+ }
+ }
+ return(f)
+}
+
+
+
+.defaultExtension <- function(format=.filetype()) {
+ format <- toupper(format)
+ if (format == 'RASTER') { return('.grd')
+ } else if (format == 'GTIFF') { 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('') }
+}
+
+
diff --git a/R/extent.R b/R/extent.R
new file mode 100644
index 0000000..32d5851
--- /dev/null
+++ b/R/extent.R
@@ -0,0 +1,197 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+
+if (!isGeneric("extent")) {
+ setGeneric("extent", function(x, ...)
+ standardGeneric("extent"))
+}
+
+setMethod('extent', signature(x='Extent'),
+ function(x){ return(x) }
+)
+
+setMethod('extent', signature(x='BasicRaster'),
+ function(x, r1, r2, c1, c2){
+ e <- x at 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 at xmin
+ }
+ } else {
+ xn <- e at xmin
+ }
+ if (! missing(c2) ) {
+ xx <- xFromCol(x, c2) + 0.5 * r[1]
+ if (is.na(xx)) {
+ warning('invalid second colummn')
+ xx <- e at xmax
+ }
+ } else {
+ xx <- e at xmax
+ }
+ if (! missing(r1) ) {
+ yx <- yFromRow(x, r1) + 0.5 * r[2]
+ if (is.na(yx)) {
+ warning('invalid first row')
+ yx <- e at ymax
+ }
+ } else {
+ yx <- e at ymax
+ }
+ if (! missing(r2) ) {
+ yn <- yFromRow(x, r2) - 0.5 * r[2]
+ if (is.na(yn)) {
+ warning('invalid second row')
+ yn <- e at ymin
+ }
+ } else {
+ yn <- e at 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 <- bbox(x)
+ e <- methods::new('Extent')
+ e at xmin <- bndbox[1,1]
+ e at xmax <- bndbox[1,2]
+ e at ymin <- bndbox[2,1]
+ e at ymax <- bndbox[2,2]
+ 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 at xmin <- min(x[1,])
+ e at xmax <- max(x[1,])
+ e at ymin <- min(x[2,])
+ e at ymax <- max(x[2,])
+ } else {
+ a <- as.vector(apply(x, 2, range, na.rm=TRUE))
+ e at xmin <- a[1]
+ e at xmax <- a[2]
+ e at ymin <- a[3]
+ e at ymax <- a[4]
+ }
+ 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 at xmin <- x[1]
+ e at xmax <- x[2]
+ e at ymin <- x[3]
+ e at ymax <- x[4]
+ 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 at cellcentre.offset
+ cs <- x at cellsize
+ cdim <- x at cells.dim
+ e <- methods::new('Extent')
+ e at xmin <- cco[1] - cs[1]/2
+ e at xmax <- e at xmin + cs[1] * cdim[1]
+ e at ymin <- cco[2] - cs[2]/2
+ e at ymax <- e at 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 at xmin <- y[1]
+ x at xmax <- y[2]
+ x at ymin <- y[3]
+ x at ymax <- y[4]
+ return(x)
+ }
+)
diff --git a/R/extentUnion.R b/R/extentUnion.R
new file mode 100644
index 0000000..06269dc
--- /dev/null
+++ b/R/extentUnion.R
@@ -0,0 +1,4 @@
+# Authors: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
diff --git a/R/extract.R b/R/extract.R
new file mode 100644
index 0000000..df9f7ef
--- /dev/null
+++ b/R/extract.R
@@ -0,0 +1,18 @@
+# Author: Robert J. Hijmans
+# Date : October 2010
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("extract")) {
+ setGeneric("extract", function(x, y, ...)
+ standardGeneric("extract"))
+}
+
+
+
+setMethod('extract', signature(x='Raster', y='vector'),
+function(x, y, ...){
+ y <- round(y)
+ return( .cellValues(x, y, ...) )
+})
diff --git a/R/extractExtent.R b/R/extractExtent.R
new file mode 100644
index 0000000..e376c06
--- /dev/null
+++ b/R/extractExtent.R
@@ -0,0 +1,81 @@
+# 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 at xmin <- e at xmin + 0.25 * r[1]
+ e at xmax <- e at xmax - 0.25 * r[1]
+ e at ymin <- e at ymin + 0.25 * r[2]
+ e at ymax <- e at ymax - 0.25 * r[2]
+
+ row <- rowFromY(x, e at ymax)
+ lastrow <- rowFromY(x, e at ymin)
+ nrows <- lastrow-row+1
+ col <- colFromX(x, e at xmin)
+ lastcol <- colFromX(x, e at 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)
+ }
+)
+
+
+
diff --git a/R/extractLines.R b/R/extractLines.R
new file mode 100644
index 0000000..ba1f18c
--- /dev/null
+++ b/R/extractLines.R
@@ -0,0 +1,291 @@
+# 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 <- projection(x, asText=FALSE)
+ comp <- compareCRS(px, projection(y), unknown=TRUE)
+ if (!comp) {
+ .requireRgdal()
+ warning('Transforming SpatialLines to the CRS of the Raster object')
+ y <- 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 <- bbox(y)
+ rsbb <- bbox(x)
+ addres <- 2 * max(res(x))
+ nlns <- length( y at 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 <- 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 <- 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)
+ 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 <- SpatialLinesDataFrame(y, res[, -1, drop=FALSE])
+ } else {
+ y at data <- cbind(y at data, res[, -1, drop=FALSE])
+ }
+ return(y)
+ }
+
+
+ res
+}
+)
+
+
+.extractLinesAlong <- function(x, y, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, ...){
+
+ spbb <- bbox(y)
+ rsbb <- bbox(x)
+ addres <- 2 * max(res(x))
+ nlns <- length( y at 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 <- 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 <- SpatialLines(list(Lines(list(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, sapply(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
+}
+
+
diff --git a/R/extractPoints.R b/R/extractPoints.R
new file mode 100644
index 0000000..545e27e
--- /dev/null
+++ b/R/extractPoints.R
@@ -0,0 +1,123 @@
+# 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 <- projection(x, asText=FALSE)
+ comp <- compareCRS(px, projection(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 <- spTransform(y, px)
+ }
+ }
+ if (sp) {
+ v <- .xyValues(x, coordinates(y), ..., df=TRUE)
+ if (!.hasSlot(y, 'data')) {
+ y <- SpatialPointsDataFrame(y, v[, -1, drop=FALSE])
+ } else {
+ y at data <- cbind(y at data, v[, -1, drop=FALSE])
+ }
+ return(y)
+ } else {
+ .xyValues(x, coordinates(y), ..., 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")
+ }
+
+ } 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
+}
+
+
diff --git a/R/extractPoints_sp.R b/R/extractPoints_sp.R
new file mode 100644
index 0000000..5a2f869
--- /dev/null
+++ b/R/extractPoints_sp.R
@@ -0,0 +1,68 @@
+# Author: Robert J. Hijmans
+# Date : June 2014
+# Version 1.0
+# Licence GPL v3
+
+
+setMethod('extract', signature(x='SpatialPolygons', y='SpatialPoints'),
+function(x, y, ...){
+
+ stopifnot(requireNamespace("rgeos"))
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at 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 at 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 at data[0,][1:nrow(y),])
+ rownames(r) <- NULL
+ } else if (length(i) < nrow(y)) {
+ sp <- SpatialPoints(y[i,], proj4string=crs(x))
+ v <- extract(x, sp, ...)
+ r <- cbind(data.frame(point.ID=1:nrow(y), poly.ID=NA), x at 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 <- SpatialPoints(y, proj4string=crs(x))
+ r <- extract(x, sp, ...)
+ }
+ return(r)
+}
+)
diff --git a/R/extractPolygons.R b/R/extractPolygons.R
new file mode 100644
index 0000000..af72541
--- /dev/null
+++ b/R/extractPolygons.R
@@ -0,0 +1,356 @@
+# 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, weights=FALSE, normalizeWeights=TRUE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...){
+
+ px <- projection(x, asText=FALSE)
+ comp <- compareCRS(px, projection(y), unknown=TRUE)
+ if (!comp) {
+ .requireRgdal()
+ warning('Transforming SpatialPolygons to the CRS of the Raster')
+ y <- spTransform(y, px)
+ }
+
+ spbb <- bbox(y)
+ rsbb <- bbox(x)
+ addres <- max(res(x))
+ npol <- length(y at polygons)
+ res <- list()
+ res[[npol+1]] <- NA
+
+ if (!is.null(fun)) {
+ cellnumbers <- FALSE
+ if (weights) {
+ if (!is.null(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', 'addres', 'cellnumbers', 'small'), envir=environment())
+ clFun <- function(i, pp) {
+ spbb <- 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 {
+ rc <- .polygonsToRaster(pp, rc, silent=TRUE)
+ xy <- rasterToPoints(rc)[,-3,drop=FALSE]
+ }
+
+ if (length(xy) > 0) { # catch very small polygons
+ 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 at polygons[[1]]@Polygons
+ ishole <- sapply(ppp, function(z)z at hole)
+ xy <- lapply(ppp, function(z)z at 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) {
+ 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) {
+ res[[i]] <- apply(d$value$value, 2, fun, na.rm=na.rm)
+ } else {
+ res[[d$value$tag]] <- fun(d$value$value)
+ }
+ }
+ } 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 <- 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 {
+ rc <- .polygonsToRaster(pp, rc, silent=TRUE)
+ xy <- rasterToPoints(rc)[,-3,drop=FALSE]
+ }
+
+ if (length(xy) > 0) { # catch holes or very small polygons
+ 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 at polygons[[1]]@Polygons
+ ishole <- sapply(ppp, function(z)z at hole)
+ xy <- lapply(ppp, function(z)z at 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) {
+ 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) {
+ 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 & 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 <- SpatialPolygonsDataFrame(y, res[, -1, drop=FALSE])
+ } else {
+ y at data <- cbind(y at data, res[, -1, drop=FALSE])
+ }
+ return(y)
+ }
+
+ res
+}
+)
+
diff --git a/R/factor.R b/R/factor.R
new file mode 100644
index 0000000..a2eadc7
--- /dev/null
+++ b/R/factor.R
@@ -0,0 +1,221 @@
+# 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)
+}
+
+
+
+if (!isGeneric("is.factor")) {
+ setGeneric("is.factor", function(x)
+ standardGeneric("is.factor"))
+}
+
+setMethod('is.factor', signature(x='Raster'),
+ function(x) {
+ f <- x at 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 at layers, function(x) x at 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 at layers, function(i) i at data@attributes) )
+ } else {
+ return(x at 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 at data@attributes <- list(value)
+ x at 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 at data@attributes <- value
+ x at data@isfactor <- i
+ } else {
+ x at data@attributes <- list()
+ }
+ x at data@isfactor <- i
+ return(x)
+ }
+)
+
+
+
+
+if (!isGeneric("as.factor")) {
+ setGeneric("as.factor", function(x)
+ standardGeneric("as.factor"))
+}
+
+
+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 at data@isfactor <- TRUE
+ if (is.null(value) ) {
+ #x <- round(x) #this makes methods::slot( isfactor FALSE again
+ x at data@attributes <- list(data.frame(VALUE=unique(x)))
+ } else {
+ x at data@attributes <- value
+ }
+ return(x)
+ }
+)
diff --git a/R/filler.R b/R/filler.R
new file mode 100644
index 0000000..2d1aeee
--- /dev/null
+++ b/R/filler.R
@@ -0,0 +1,34 @@
+
+
+.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
+}
+
+
diff --git a/R/fixDBFnames.R b/R/fixDBFnames.R
new file mode 100644
index 0000000..0d26a3a
--- /dev/null
+++ b/R/fixDBFnames.R
@@ -0,0 +1,31 @@
+
+.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)
+}
+
diff --git a/R/flip.R b/R/flip.R
new file mode 100644
index 0000000..412578d
--- /dev/null
+++ b/R/flip.R
@@ -0,0 +1,166 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("flip")) {
+ setGeneric("flip", function(x, direction, ...)
+ standardGeneric("flip"))
+}
+
+
+setMethod('flip', signature(x='RasterLayer', direction='ANY'),
+ function(x, direction='y', filename='', ...) {
+
+ filename <- trim(filename)
+ outRaster <- raster(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', direction='ANY'),
+ 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 at 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)
+ }
+)
+
+
diff --git a/R/flowpath.R b/R/flowpath.R
new file mode 100644
index 0000000..0890fe3
--- /dev/null
+++ b/R/flowpath.R
@@ -0,0 +1,67 @@
+# 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)
+}
diff --git a/R/focal.R b/R/focal.R
new file mode 100644
index 0000000..4c9c0e5
--- /dev/null
+++ b/R/focal.R
@@ -0,0 +1,313 @@
+# 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)
+}
+
+
+
+
+if (!isGeneric("focal")) {
+ setGeneric("focal", function(x, ...)
+ standardGeneric("focal"))
+}
+
+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) {
+ e <- new.env()
+ 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 <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+
+ 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 <- .Call('focal_fun', values(x), w, as.integer(dim(out)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', values(x), w, as.integer(dim(out)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ }
+
+ 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 <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ 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 <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ 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 <- .Call('focal_fun', as.vector(t(v)), w, paddim, runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', as.vector(t(v)), w, paddim, narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ 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 <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[1]+addr, nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[1]+addr, nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ 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 <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ 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 <- .Call('focal_fun', v, w, as.integer(c(tr$nrows[i]+addr, nc)), runfun, NAonly, e, NAOK=TRUE, PACKAGE='raster')
+ } else {
+ v <- .Call('focal_sum', v, w, as.integer(c(tr$nrows[i]+addr, nc)), narm, NAonly, domean=domean, NAOK=TRUE, PACKAGE='raster')
+ }
+ out <- writeValues(out, v[-nc1], tr$row[i])
+ pbStep(pb)
+ }
+ out <- writeStop(out)
+ pbClose(pb)
+ }
+ return(out)
+}
+)
+
diff --git a/R/focalFun.R b/R/focalFun.R
new file mode 100644
index 0000000..4ca17f8
--- /dev/null
+++ b/R/focalFun.R
@@ -0,0 +1,70 @@
+# 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))
+ }
+}
+
+#)
+
+
diff --git a/R/focalWeight.R b/R/focalWeight.R
new file mode 100644
index 0000000..e4314df
--- /dev/null
+++ b/R/focalWeight.R
@@ -0,0 +1,93 @@
+# Author: Robert J. Hijmans
+# Date : June 2013
+# Version 1.0
+# Licence GPL v3
+
+
+.circular.weight <- function(rs, d) {
+ nx <- 1 + 2 * floor(d/rs[1])
+ ny <- 1 + 2 * floor(d/rs[2])
+ m <- matrix(ncol=nx, nrow=ny)
+ m[ceiling(ny/2), ceiling(nx/2)] <- 1
+ if (nx == 1 & ny == 1) {
+ return(m)
+ } else {
+ x <- raster(m, 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
+ d / sum(d)
+ }
+}
+
+
+
+.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')) {
+ type <- match.arg(type)
+ x <- res(x)
+ if (type == 'circle') {
+ .circular.weight(x, d[1])
+ } 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)
+}
+
diff --git a/R/fourCellsFromXY.R b/R/fourCellsFromXY.R
new file mode 100644
index 0000000..de4a0e3
--- /dev/null
+++ b/R/fourCellsFromXY.R
@@ -0,0 +1,15 @@
+# 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 at ncols, r at nrows, xmin(r), xmax(r), ymin(r), ymax(r), xy, duplicates, .isGlobalLonLat(r)))
+}
diff --git a/R/frbind.R b/R/frbind.R
new file mode 100644
index 0000000..324c53c
--- /dev/null
+++ b/R/frbind.R
@@ -0,0 +1,84 @@
+# 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
+}
diff --git a/R/freq.R b/R/freq.R
new file mode 100644
index 0000000..a2f0334
--- /dev/null
+++ b/R/freq.R
@@ -0,0 +1,153 @@
+# Author: Robert J. Hijmans
+# Date : March 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("freq")) {
+ setGeneric("freq", function(x, ...)
+ standardGeneric("freq"))
+}
+
+
+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))
+ }
+ 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)
+ }
+ }
+}
+
diff --git a/R/fullFileName.R b/R/fullFileName.R
new file mode 100644
index 0000000..e50e6c8
--- /dev/null
+++ b/R/fullFileName.R
@@ -0,0 +1,21 @@
+# 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)) {
+ x <- file.path(getwd(), x)
+ }
+ if (expand) {
+ x <- path.expand(x)
+ }
+ return(x)
+}
diff --git a/R/gainoffset.R b/R/gainoffset.R
new file mode 100644
index 0000000..256210c
--- /dev/null
+++ b/R/gainoffset.R
@@ -0,0 +1,76 @@
+# 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 at layers <- lapply( x at layers,
+ function(z) {
+ if (fromDisk(x)) {
+ z at data@gain <- value
+ } else {
+ z <- z * value
+ }
+ return(z)
+ }
+ )
+ } else {
+ if (fromDisk(x)) {
+ x at data@gain <- value
+ } else {
+ x <- x * value
+ }
+ }
+ return(x)
+}
+
+
+gain <- function(x) {
+ if (inherits(x, 'RasterStack')) {
+ r <- sapply( x at layers, function(z) { z at data@gain } )
+ } else {
+ r <- x at data@gain
+ }
+ return(r)
+}
+
+
+'offs<-' <- function(x, value) {
+ value <- as.numeric(value[1])
+ if (inherits(x, 'RasterStack')) {
+
+ x at layers <- lapply( x at layers,
+ function(z) {
+
+ if (fromDisk(z)) {
+ z at data@offset <- value
+ } else {
+ z <- z + value
+ }
+ return(z)
+ }
+ )
+
+ } else {
+ if (fromDisk(x)) {
+ x at data@offset <- value
+ } else {
+ x <- x + value
+ }
+ }
+ return(x)
+}
+
+
+offs <- function(x) {
+ if (inherits(x, 'RasterStack')) {
+ r <- sapply( x at layers, function(z) { z at data@offset } )
+ } else {
+ r <- x at data@offset
+ }
+ return(r)
+}
+
diff --git a/R/gdal.R b/R/gdal.R
new file mode 100644
index 0000000..952ef19
--- /dev/null
+++ b/R/gdal.R
@@ -0,0 +1,36 @@
+# Author: Robert J. Hijmans
+# Date : September 2012
+# Version 1.0
+# Licence GPL v3
+
+.requireRgdal <- function(stopIfAbsent=TRUE) {
+
+ y <- getOption('rasterGDALLoaded')
+
+ w <- getOption('warn')
+ options('warn'=-1)
+ x <- isTRUE( try( requireNamespace("rgdal", quietly=TRUE ) ) )
+ options('warn'= w)
+
+ 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)
+}
+
diff --git a/R/gdalFormats.R b/R/gdalFormats.R
new file mode 100644
index 0000000..1edc408
--- /dev/null
+++ b/R/gdalFormats.R
@@ -0,0 +1,108 @@
+# 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')
+ 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')
+ }
+}
+
\ No newline at end of file
diff --git a/R/geom.R b/R/geom.R
new file mode 100644
index 0000000..669246e
--- /dev/null
+++ b/R/geom.R
@@ -0,0 +1,94 @@
+
+if (!isGeneric("geom")) {
+ setGeneric("geom", function(x, ...)
+ standardGeneric("geom"))
+}
+
+setMethod('geom', signature(x='SpatialPolygons'),
+ function(x, sepNA=FALSE, ...) {
+
+ nobs <- length(x at polygons)
+ objlist <- list()
+ cnt <- 0
+ if (sepNA) {
+ sep <- rep(NA,5)
+ for (i in 1:nobs) {
+ nsubobs <- length(x at polygons[[i]]@Polygons)
+ ps <- lapply(1:nsubobs,
+ function(j)
+ rbind(cbind(j, j+cnt, x at polygons[[i]]@Polygons[[j]]@hole, x at 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 at polygons[[i]]@Polygons)
+ ps <- lapply(1:nsubobs,
+ function(j)
+ cbind(j, j+cnt, x at polygons[[i]]@Polygons[[j]]@hole, x at 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 at lines)
+ objlist <- list()
+ cnt <- 0
+ if (sepNA) {
+ sep <- rep(NA, 4)
+ for (i in 1:nobs) {
+ nsubobj <- length(x at lines[[i]]@Lines)
+ ps <- lapply(1:nsubobj,
+ function(j)
+ rbind(cbind(j, j+cnt, x at 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 at lines[[i]]@Lines)
+ ps <- lapply(1:nsubobj, function(j) cbind(j, j+cnt, x at 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 <- coordinates(x)
+ xy <- cbind(1:nrow(xy), xy)
+ colnames(xy) <- c('object', 'x', 'y')
+ return(xy)
+ }
+)
+
diff --git a/R/getData.R b/R/getData.R
new file mode 100644
index 0000000..533e414
--- /dev/null
+++ b/R/getData.R
@@ -0,0 +1,422 @@
+# 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)
+ if (name=='GADM') {
+ .GADM(..., download=download, path=path, version=2.8)
+ } 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, method="auto", 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) {
+# 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')
+ }
+
+ filename <- paste(path, 'GADM_', version, '_', country, '_adm', level, ".rds", sep="")
+ if (!file.exists(filename)) {
+ if (download) {
+
+ baseurl <- paste0("http://biogeo.ucdavis.edu/data/gadm", version)
+ if (version == 2) {
+ theurl <- paste(baseurl, '/R/', country, '_adm', level, ".RData", sep="")
+ } else {
+ theurl <- paste(baseurl, '/rds/', country, '_adm', level, ".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)) {
+ if (version == 2) {
+ thisenvir <- new.env()
+ data <- get(load(filename, thisenvir), thisenvir)
+ } else {
+ data <- readRDS(filename)
+ }
+ return(data)
+ } else {
+ return(NULL)
+ }
+}
+
+
+
+
+.countries <- function(download, path, ...) {
+# if (!file.exists(path)) { dir.create(path, recursive=T) }
+ filename <- paste(path, 'countries.RData', sep="")
+ if (!file.exists(filename)) {
+ if (download) {
+ theurl <- paste("http://biogeo.ucdavis.edu/data/gadm2.6/countries_gadm26.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)) {
+ #thisenvir = new.env()
+ #data <- get(load(filename, thisenvir), thisenvir)
+ data <- readRDS(filename)
+ 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)
+ 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('http://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('http://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('http://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("http://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='') }
+
+ f <- paste('srtm_', colTile, '_', rowTile, sep="")
+ zipfilename <- paste(path, "/", f, ".ZIP", sep="")
+ tiffilename <- paste(path, "/", f, ".TIF", sep="")
+
+ if (!file.exists(tiffilename)) {
+ if (!file.exists(zipfilename)) {
+ if (download) {
+ theurl <- paste("ftp://xftp.jrc.it/pub/srtmV4/tiff/", f, ".zip", sep="")
+ test <- try (.download(theurl, zipfilename) , silent=TRUE)
+ if (class(test) == 'try-error') {
+ theurl <- paste("http://hypersphere.telascience.org/elevation/cgiar_srtm_v4/tiff/zip/", f, ".ZIP", sep="")
+ test <- try (.download(theurl, zipfilename) , silent=TRUE)
+ if (class(test) == 'try-error') {
+ theurl <- paste("http://srtm.csi.cgiar.org/SRT-ZIP/SRTM_V41/SRTM_Data_GeoTiff/", f, ".ZIP", sep="")
+ .download(theurl, zipfilename)
+ }
+ }
+ } 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')
+ }
+}
+
diff --git a/R/getValues.R b/R/getValues.R
new file mode 100644
index 0000000..57bf76f
--- /dev/null
+++ b/R/getValues.R
@@ -0,0 +1,95 @@
+# 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 at ncols, x at nrows)
+# f <- is.factor(x)
+# if (f) {
+# labs <- labels(x)
+# }
+
+ if ( inMemory(x) ) {
+ x <- x at data@values
+ } else if ( fromDisk(x) ) {
+ x <- .readRasterLayerValues(x, 1, x at 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 at data@values) <- names(x)
+ x at 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 at layers[[i]])
+ }
+ m
+}
+)
+
+
+setMethod("getValues", signature(x='RasterLayerSparse', row='missing', nrows='missing'),
+function(x, format='') {
+
+ cr <- c(x at ncols, x at nrows)
+
+ if ( inMemory(x) ) {
+ i <- x at index
+ v <- x at data@values
+ x <- rep(NA, ncell(x))
+ x[i] <- v
+ } else if ( fromDisk(x) ) {
+ # not yet implemented
+ ### x <- .readRasterLayerValues(x, 1, x at nrows)
+ } else {
+ x <- rep(NA, ncell(x))
+ }
+
+ if (format=='matrix') {
+ x <- matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE)
+ }
+
+ return( x )
+}
+)
+
diff --git a/R/getValuesBlock.R b/R/getValuesBlock.R
new file mode 100644
index 0000000..22ac8e7
--- /dev/null
+++ b/R/getValuesBlock.R
@@ -0,0 +1,213 @@
+# 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 at nrows)
+ stopifnot(col <= x at ncols)
+ stopifnot(nrows > 0)
+ stopifnot(ncols > 0)
+ row <- max(1, min(x at nrows, round(row[1])))
+ lastrow <- min(x at nrows, row + round(nrows[1]) - 1)
+ nrows <- lastrow - row + 1
+ col <- max(1, min(x at 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]]
+ }
+
+ startcell <- cellFromRowCol(x, row, col)
+ lastcell <- cellFromRowCol(x, lastrow, lastcol)
+
+ nc <- ncol(x)
+ res <- matrix(ncol=nlyrs, nrow=nrows * ncols)
+
+ inmem <- sapply(x at layers, function(x) x at 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 at layers[[lyrs[i]]]
+ if ( inMemory(xx) ) {
+ res[,i] <- xx at 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 at nrows)
+ stopifnot(col <= x at ncols)
+ nrows <- min(round(nrows), x at nrows-row+1)
+ ncols <- min((x at 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 at ncols) {
+ rnge <- cellFromRowCol(x, c(row, lastrow), c(1, ncol(x)))
+ res <- x at data@values[rnge[1]:rnge[2], , drop=FALSE]
+ } else {
+ lastcol <- col + ncols - 1
+ res <- x at 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 at nrows, round(row[1])))
+ lastrow <- min(x at nrows, row + round(nrows[1]) - 1)
+ nrows <- lastrow - row + 1
+ col <- max(1, min(x at 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 at data@values[startcell:lastcell]
+ } else {
+ cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol)
+ res <- x at data@values[cells]
+ }
+ } else if ( fromDisk(x)) {
+ res <- .readRasterLayerValues(x, row, nrows, col, ncols)
+
+ } else { # no values
+ 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('getValuesBlock', signature(x='RasterLayerSparse'),
+ function(x=1, row, nrows=1, col=1, ncols=(ncol(x)-col+1), format='') {
+
+ row <- max(1, min(x at nrows, round(row[1])))
+ lastrow <- min(x at nrows, row + round(nrows[1]) - 1)
+ nrows <- lastrow - row + 1
+ col <- max(1, min(x at 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 at index >= startcell & x at index <= lastcell)
+ if (length(i) > 0) {
+ res <- cellFromRowColCombine(x, row:lastrow, col:lastcol)
+ m <- match(i, res)
+ res[] <- NA
+ res[m] <- x at 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
+ }
+
+)
+
diff --git a/R/getValuesFocal.R b/R/getValuesFocal.R
new file mode 100644
index 0000000..0a2dcf5
--- /dev/null
+++ b/R/getValuesFocal.R
@@ -0,0 +1,120 @@
+# 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 <- .Call('focal_get', as.vector(t(v)), as.integer(dim(v)), as.integer(ngb), NAOK=TRUE, PACKAGE='raster')
+ 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)
+}
+)
+
+
diff --git a/R/getValuesRows.R b/R/getValuesRows.R
new file mode 100644
index 0000000..4038475
--- /dev/null
+++ b/R/getValuesRows.R
@@ -0,0 +1,138 @@
+# 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 at layers[[i]], row, nrows)
+ res <- matrix(ncol=nlayers(x), nrow=length(v))
+ res[,1] <- v
+ } else {
+ res[,i] <- getValues(x at 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 at nrows, max(1, row))
+ endrow <- max(min(x at nrows, row+nrows-1), row)
+ nrows <- endrow - row + 1
+
+ if (inMemory(x)){
+ startcell <- cellFromRowCol(x, row, 1)
+ endcell <- cellFromRowCol(x, row+nrows-1, x at ncols)
+ v <- x at data@values[startcell:endcell]
+ } else if ( fromDisk(x) ) {
+ v <- .readRasterLayerValues(x, row, nrows)
+ } else {
+ v <- rep(NA, nrows * x at 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 at nrows, max(1, round(row)))
+ endrow <- max(min(x at 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 at ncols)
+ res <- x at 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
+}
+)
+
+
+
+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 at nrows, max(1, row))
+ endrow <- max(min(x at 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 at index >= startcell & x at index <= lastcell)
+ if (length(i) > 0) {
+ v <- cellFromRowColCombine(x, row:endrow, 1:nc)
+ m <- match(i, v)
+ v[] <- NA
+ v[m] <- x at data@values[i]
+ } else {
+ v <- rep(NA, nrows * x at ncols)
+ }
+ } else if ( fromDisk(x) ) {
+ # not yet implemented
+ ## v <- .readRasterLayerValues(x, row, nrows)
+ } else {
+ v <- rep(NA, nrows * x at ncols)
+ }
+ if (format=='matrix') {
+ v <- matrix(v, nrow=nrows, byrow=TRUE)
+ rownames(v) <- row:(row+nrows-1)
+ colnames(v) <- 1:ncol(v)
+ }
+ return(v)
+}
+)
\ No newline at end of file
diff --git a/R/gridDistance.R b/R/gridDistance.R
new file mode 100644
index 0000000..66163a2
--- /dev/null
+++ b/R/gridDistance.R
@@ -0,0 +1,197 @@
+# Author: Jacob van Etten
+# email jacobvanetten at yahoo.com
+# Date : May 2010
+# Version 1.1
+# Licence GPL v3
+
+# RH: updated for igraph (from igraph0)
+# sept 23, 2012
+
+
+
+if (!isGeneric("gridDistance")) {
+ setGeneric("gridDistance", function(x, ...)
+ standardGeneric("gridDistance"))
+}
+
+setMethod("gridDistance", signature("RasterLayer"),
+
+function(x, origin, omit=NULL, filename="", ...) {
+
+ if( !requireNamespace("igraph")) {
+ stop('you need to install the igraph0 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), longlat=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)
+}
diff --git a/R/gridDistance2.R b/R/gridDistance2.R
new file mode 100644
index 0000000..3bfc67d
--- /dev/null
+++ b/R/gridDistance2.R
@@ -0,0 +1,71 @@
+# 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[] <- .Call('broom', x, f, a , b, as.integer(1), NAOK=TRUE, PACKAGE='raster')
+ z2a[] <- .Call('broom', x, f, a , b, as.integer(0), NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(1), NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(1), NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(0), NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('broom', v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), as.integer(0), NAOK=TRUE, PACKAGE='raster')
+ 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)
+}
+
diff --git a/R/hdr.R b/R/hdr.R
new file mode 100644
index 0000000..bd7ecc1
--- /dev/null
+++ b/R/hdr.R
@@ -0,0 +1,78 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+
+hdr <- function(x, format, extension='.wld') {
+
+ if (inherits(x, 'RasterStack')) { stop('Only applicable to RasterLayer and RasterBrick classes (and their derivatives)') }
+
+ if (x at file@name == '') { stop('Object has no filename') }
+
+# if (missing(filename)) {
+# if (x at 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 at 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 at 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) )
+}
+
\ No newline at end of file
diff --git a/R/hdrBIL.R b/R/hdrBIL.R
new file mode 100644
index 0000000..4df3f2a
--- /dev/null
+++ b/R/hdrBIL.R
@@ -0,0 +1,51 @@
+# Author: Robert J. Hijmans
+# Date : October 2009
+# Version 0.9
+# Licence GPL v3
+
+
+.writeHdrBIL <- function(x, layout='BIL') {
+ hdrfile <- x at file@name
+ extension(hdrfile) <- '.hdr'
+ thefile <- file(hdrfile, "w") # open an txt file connectionis
+ cat("NROWS ", x at nrows, "\n", file = thefile)
+ cat("NCOLS ", x at ncols, "\n", file = thefile)
+ cat("NBANDS ", nlayers(x), "\n", file = thefile)
+ cat("NBITS ", dataSize(x at file@datanotation) * 8, "\n", file = thefile)
+ btorder <- ifelse(x at 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 at file@datanotation)
+ if (dtype == 'INT' | dtype == 'LOG' ) {
+ pixtype <- ifelse(dataSigned(x at 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 at 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=", projection(x), "\n", file = thefile)
+ cat("MinValue=", minValue(x), "\n", file = thefile)
+ cat("MaxValue=", maxValue(x), "\n", file = thefile)
+
+ close(thefile)
+ return(invisible(TRUE))
+}
diff --git a/R/hdrBov.R b/R/hdrBov.R
new file mode 100644
index 0000000..62f7449
--- /dev/null
+++ b/R/hdrBov.R
@@ -0,0 +1,32 @@
+# 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 at 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))
+}
diff --git a/R/hdrEnvi.R b/R/hdrEnvi.R
new file mode 100644
index 0000000..823eb72
--- /dev/null
+++ b/R/hdrEnvi.R
@@ -0,0 +1,57 @@
+# 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("description = {", names(r), "}", "\n", file = thefile)
+ cat("samples = ", ncol(r), "\n", file = thefile)
+ cat("lines = ", nrow(r), "\n", file = thefile)
+ cat("bands = ", r at file@nbands, "\n", file = thefile)
+ cat("header offset = 0\n", file = thefile)
+ cat("file type = ENVI Standard\n", file = thefile)
+ dsize <- dataSize(r at file@datanotation)
+ if (.shortDataType(r at 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("interleave = ", r at file@bandorder, "\n", file = thefile)
+ cat("sensor type = \n", file = thefile)
+
+ btorder <- as.integer(r at 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 = {", rgdal::showWKT(projection(r)), "}\n", file = thefile, sep="")
+ } else {
+ cat("projection info =", projection(r), "\n", file = thefile)
+ }
+ cat("z plot range = {", minValue(r),", ", maxValue(r), "}\n", file = thefile)
+ close(thefile)
+}
+
diff --git a/R/hdrErdasRaw.R b/R/hdrErdasRaw.R
new file mode 100644
index 0000000..469a54b
--- /dev/null
+++ b/R/hdrErdasRaw.R
@@ -0,0 +1,51 @@
+# 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 at 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 at file@datanotation) == 'INT') {
+ dd <- "S"
+ } else {
+ dd <- "F"
+ }
+ nbits <- dataSize(raster at 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=", projection(raster), "\n", file = thefile)
+ cat("MinValue=", minValue(raster), "\n", file = thefile)
+ cat("MaxValue=", maxValue(raster), "\n", file = thefile)
+ close(thefile)
+
+ .worldFile(raster, ".rww")
+ }
+
diff --git a/R/hdrIDRISI.R b/R/hdrIDRISI.R
new file mode 100644
index 0000000..a2bbe44
--- /dev/null
+++ b/R/hdrIDRISI.R
@@ -0,0 +1,57 @@
+# 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 at 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))
+}
diff --git a/R/hdrPRJ.R b/R/hdrPRJ.R
new file mode 100644
index 0000000..ed2c8a0
--- /dev/null
+++ b/R/hdrPRJ.R
@@ -0,0 +1,24 @@
+# Author: Robert J. Hijmans
+# Date : April 2011
+# Version 1.0
+# Licence GPL v3
+
+
+.writeHdrPRJ <- function(x, ESRI=TRUE) {
+ if (.requireRgdal()) {
+
+ p4s <- try( rgdal::showWKT(projection(x), file = NULL, morphToESRI = ESRI) )
+ if (class(p4s) != 'try-error') {
+ prjfile <- filename(x)
+ extension(prjfile) <- '.prj'
+ cat(p4s, file=prjfile)
+ } else {
+ return(FALSE)
+ }
+ return(invisible(TRUE))
+ } else {
+ return(FALSE)
+ }
+}
+
+
diff --git a/R/hdrRaster.R b/R/hdrRaster.R
new file mode 100644
index 0000000..e1a3ad5
--- /dev/null
+++ b/R/hdrRaster.R
@@ -0,0 +1,101 @@
+# 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=", projection(x), "\n", file = thefile, sep='')
+
+ cat("[data]", "\n", file = thefile, sep='')
+ cat("datatype=", x at file@datanotation, "\n", file = thefile, sep='')
+ cat("byteorder=", x at file@byteorder, "\n", file = thefile, sep='')
+ nl <- nlayers(x)
+ cat("nbands=", nl, "\n", file = thefile, sep='')
+ cat("bandorder=", x at 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 at data@attributes[[1]]
+ cat("ratnames=", paste(colnames(r), collapse=':'), "\n", file = thefile, sep='')
+ cat("rattypes=", paste(sapply(r, class), collapse=':'), "\n", file = thefile, sep='')
+ cat("ratvalues=", paste(trim(as.character(as.matrix(r))), collapse=':'), "\n", file = thefile, sep='')
+ }
+ if (length(x at legend@colortable) > 1) {
+ cat("colortable=", paste(x at legend@colortable, collapse=':'), "\n", file = thefile, sep='')
+ }
+ }
+
+# cat("levels=", x at 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 at sparse, "\n", file = thefile, sep='')
+# cat("nCellvals=", x at data@ncellvals, "\n", file = thefile, sep='')
+
+ cat("[legend]", "\n", file = thefile, sep='')
+ cat("legendtype=", x at legend@type, "\n", file = thefile, sep='')
+ cat("values=", paste(x at legend@values, collapse=':'), "\n", file = thefile, sep='')
+ cat("color=", paste(x at 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 at 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 at history), silent=TRUE )
+ if (!is.null(a)) {
+ cat("history=", a, "\n", file = thefile, sep='')
+ }
+
+ a <- NULL
+ try( a <- rapply(x at history, function(x) paste(as.character(x), collapse='#,#')), silent=TRUE )
+ if (!is.null(a)) {
+ a <- gsub('\n', '#NL#', a)
+ type <- rapply(x at 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)
+}
+
+
diff --git a/R/hdrSAGA.R b/R/hdrSAGA.R
new file mode 100644
index 0000000..75ef603
--- /dev/null
+++ b/R/hdrSAGA.R
@@ -0,0 +1,51 @@
+# 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 at file@datanotation)
+ dsize <- dataSize(x at 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 at file@datanotation)) {
+ pixtype <- paste(pixtype, "_UNSIGNED", sep="")
+ }
+ } else if ( x at file@datanotation == 'FLT4S' ) {
+ pixtype <- "FLOAT"
+ } else {
+ stop(paste('cannot write SAGA file with data type:', x at file@datanotation))
+ }
+
+ cat("DATAFORMAT\t=", pixtype, "\n", file = thefile)
+
+ cat("DATAFILE_OFFSET\t= 0\n", file = thefile)
+ cat("BYTEORDER_BIG\t=", x at 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))
+}
diff --git a/R/hdrVRT.R b/R/hdrVRT.R
new file mode 100644
index 0000000..5f309c8
--- /dev/null
+++ b/R/hdrVRT.R
@@ -0,0 +1,82 @@
+# Author: Robert J. Hijmans
+# Date : October 2010
+# Version 1.0
+# Licence GPL v3
+
+
+.writeHdrVRT <- function(x) {
+
+ fn <- fname <- x at 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 at file@datanotation)
+ nbands <- nlayers(x)
+
+ bandorder <- x at file@bandorder
+ if (bandorder == 'BIL') {
+ pixoff <- pixsize
+ lineoff <- pixsize * x at ncols * nbands
+ imgoff <- ((1:nbands)-1) * x at ncols * pixsize
+
+ } else if (bandorder == 'BSQ') {
+ pixoff <- pixsize
+ lineoff <- pixsize * x at ncols
+ imgoff <- ((1:nbands)-1) * ncell(x) * pixsize
+
+ } else if (bandorder == 'BIP') {
+ pixoff <- pixsize * nbands
+ lineoff <- pixsize * x at ncols * nbands
+ imgoff <- (1:nbands)-1
+ }
+
+ datatype <- .getGdalDType(x at file@datanotation)
+
+ if (x at file@byteorder == "little") {
+ byteorder <- "LSB"
+ } else {
+ byteorder <- "MSB"
+ }
+ if (! x at file@toptobottom) { rotation <- 180 } else { rotation <- 0 }
+ e <- x at extent
+ r <- res(x)
+ prj <- projection(x)
+
+ f <- file(fname, "w")
+ cat('<VRTDataset rasterXSize="', x at ncols, '" rasterYSize="', x at nrows, '">\n' , sep = "", file = f)
+ if (rotated(r)) {
+ cat('<GeoTransform>', paste(x at rotation@geotrans, collapse=', '), '</GeoTransform>\n', sep = "", file = f)
+ } else {
+ cat('<GeoTransform>', e at xmin, ', ', r[1], ', ', rotation, ', ', e at ymax, ', ', 0.0, ', ', -1*r[2], '</GeoTransform>\n', sep = "", file = f)
+ }
+ if (! is.na(prj) ) {
+ cat('<SRS>', prj ,'</SRS>\n', sep = "", file = f)
+ }
+
+ for (i in 1:nlayers(x)) {
+ cat('\t<VRTRasterBand dataType="', datatype, '" band="', i, '" subClass="VRTRawRasterBand">\n', sep = "" , file = f)
+ cat('\t\t<Description>', names(x), '</Description>\n', sep = "", file = f)
+ cat('\t\t<SourceFilename relativetoVRT="1">', basename(fn), '</SourceFilename>\n', sep = "", file = f)
+ cat('\t\t<ImageOffset>', imgoff[i], '</ImageOffset>\n', sep = "", file = f)
+ cat('\t\t<PixelOffset>', pixoff, '</PixelOffset>\n', sep = "", file = f)
+ cat('\t\t<LineOffset>', lineoff, '</LineOffset>\n', sep = "", file = f)
+ cat('\t\t<ByteOrder>', byteorder, '</ByteOrder>\n', sep = "", file = f)
+ cat('\t\t<NoDataValue>', x at file@nodatavalue, '</NoDataValue>\n', sep = "", file = f)
+ cat('\t\t<Offset>', x at data@offset, '</Offset>\n', sep = "", file = f)
+ cat('\t\t<Scale>', x at data@gain, '</Scale>\n', sep = "", file = f)
+ cat('\t</VRTRasterBand>\n', sep = "", file = f)
+ }
+ cat('</VRTDataset>\n', sep = "", file = f)
+ close(f)
+ return( invisible(TRUE) )
+}
+
+
+
+
\ No newline at end of file
diff --git a/R/hdrWorldFile.R b/R/hdrWorldFile.R
new file mode 100644
index 0000000..d595286
--- /dev/null
+++ b/R/hdrWorldFile.R
@@ -0,0 +1,18 @@
+# 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)
+}
diff --git a/R/head.R b/R/head.R
new file mode 100644
index 0000000..ee13e43
--- /dev/null
+++ b/R/head.R
@@ -0,0 +1,85 @@
+# Author: Robert J. Hijmans
+# Date : December 2010
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("head")) {
+ setGeneric("head", function(x, ...)
+ standardGeneric("head"))
+}
+
+if (!isGeneric("tail")) {
+ setGeneric("tail", function(x, ...)
+ standardGeneric("tail"))
+}
+
+setMethod('head', signature(x='RasterLayer'),
+ function(x, cols=20, rows=10, ...) {
+ nr <- min(x at nrows, max(1, rows))
+ nc <- min(x at 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 at nrows, max(1, rows))
+ nc <- min(x at ncols, max(1, cols))
+ sr <- x at nrows - nr + 1
+ sc <- x at 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 at nrows, max(1, rows))
+ nc <- min(x at 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 at nrows, max(1, rows))
+ nc <- min(x at ncols, max(1, cols))
+ nl <- min(nlayers(x), max(1, layers))
+ sr <- x at nrows - nr + 1
+ sc <- x at 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 at data, n=n, ...)
+ } else {
+ x[1,]
+ }
+ }
+)
+
+
+
+setMethod('tail', signature(x='Spatial'),
+ function(x, n=6L, ...) {
+ if (.hasSlot(x, 'data')) {
+ tail(x at data, n=n, ...)
+ } else {
+ x[length(x),]
+ }
+ }
+)
+
+
diff --git a/R/hillShade.R b/R/hillShade.R
new file mode 100644
index 0000000..5fdc672
--- /dev/null
+++ b/R/hillShade.R
@@ -0,0 +1,25 @@
+# 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)
+}
+
diff --git a/R/hist.R b/R/hist.R
new file mode 100644
index 0000000..004bb4d
--- /dev/null
+++ b/R/hist.R
@@ -0,0 +1,101 @@
+# 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, ...)
+ }
+}
+
+
+
diff --git a/R/idwValue.R b/R/idwValue.R
new file mode 100644
index 0000000..b59d8d3
--- /dev/null
+++ b/R/idwValue.R
@@ -0,0 +1,55 @@
+# 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, coordinates(r))
+#plot(r)
diff --git a/R/image.R b/R/image.R
new file mode 100644
index 0000000..2da751e
--- /dev/null
+++ b/R/image.R
@@ -0,0 +1,45 @@
+# Author: Robert J. Hijmans
+# Date : April 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("image")) {
+ setGeneric("image", function(x,...)
+ standardGeneric("image"))
+}
+
+setMethod("image", signature(x='RasterLayer'),
+ function(x, maxpixels=500000, useRaster=TRUE, ...) {
+# coltab <- x at 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, ...)
+ }
+)
+
diff --git a/R/imageplot.R b/R/imageplot.R
new file mode 100644
index 0000000..a8aa64c
--- /dev/null
+++ b/R/imageplot.R
@@ -0,0 +1,232 @@
+# 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))
+}
+
+
+
diff --git a/R/imageplot2.R b/R/imageplot2.R
new file mode 100644
index 0000000..c7c29ba
--- /dev/null
+++ b/R/imageplot2.R
@@ -0,0 +1,271 @@
+# 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 at extent@ymax, x at 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
+ }
+ }
+
+ 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 (! 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()
+
+}
+
diff --git a/R/index.R b/R/index.R
new file mode 100644
index 0000000..7eaa4d3
--- /dev/null
+++ b/R/index.R
@@ -0,0 +1,156 @@
+# 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 <- coordinates(i)
+ 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 (! hasValues(x) ) {
+ stop('no data associated with this Raster object')
+ }
+ if (length(i) < 1) return(NULL)
+
+ nacount <- sum(is.na(i))
+ if (nacount > 0) {
+ warning('some indices are invalid (NA returned)')
+ }
+
+ if (drop) {
+ return( .cellValues(x, i) )
+
+ } else {
+ i <- stats::na.omit(i)
+ r <- rasterFromCells(x, i, values=FALSE)
+ newi <- cellFromXY(r, xyFromCell(x, i))
+ if (nlayers(x) > 1) {
+ r <- brick(r)
+ v <- matrix(NA, nrow=ncell(r), ncol=nlayers(x))
+ v[newi,] <- .cellValues(x, i)
+ v <- setValues(r, v)
+ return(v)
+ } else {
+ r[newi] <- .cellValues(x, i)
+ return(r)
+ }
+ }
+}
+
diff --git a/R/indexReplace.R b/R/indexReplace.R
new file mode 100644
index 0000000..daa19f0
--- /dev/null
+++ b/R/indexReplace.R
@@ -0,0 +1,183 @@
+# 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 (class(x) != 'try-error') {
+ v[] <- value
+ x <- try( setValues(x, v) )
+ }
+ }
+ if (class(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 {
+ # if (! is.numeric(i)) {
+ # i <- as.integer(i)
+ # }
+ i <- stats::na.omit(i)
+ }
+
+ 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) ) {
+ x at 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)
+ } else if ( fromDisk(x) ) {
+ x <- readAll(x)
+ x <- .clearFile(x)
+ } else {
+ x <- setValues(x, rep(NA, times=ncell(x)))
+ }
+ x at data@values[i] <- value
+ x <- setMinMax(x)
+ 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)
+ for (k in 1:tr$n) {
+ cells <- cellFromRowCol(x, tr$row[k], 1):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=length(cells), ncol=nl)
+ }
+ cells <- cells + rep(add, each=length(cells))
+ j <- cells %in% i
+ if (sum(j) > 0) {
+ v[j] <- value
+ }
+ r <- writeValues(r, v, tr$row[k])
+ pbStep(pb, k)
+ }
+ r <- writeStop(r)
+ pbClose(pb)
+ return(r)
+ }
+ }
+}
+
+
diff --git a/R/indexReplaceBrick.R b/R/indexReplaceBrick.R
new file mode 100644
index 0000000..784c351
--- /dev/null
+++ b/R/indexReplaceBrick.R
@@ -0,0 +1,277 @@
+# 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')) {
+ 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) {
+ n <- which(i == names(x))[1]
+ if (is.na(n)) {
+ n <- nlayers(x) + 1
+ }
+ if (inherits(value, 'Raster')) {
+ names(value) <- i
+ }
+ x[[n]] <- value
+ x
+ }
+)
+
+
+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 at layers[[i]] <- value
+ }
+ x
+ }
+)
+
+
+
+setReplaceMethod("[[", c("RasterBrick", "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 (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 at polygons)
+ v[] <- value
+ return( .polygonsToRaster(i, x, value=v, fun='last', mask=FALSE, update=TRUE, updateValue="all", silent=TRUE) )
+
+ } else if (inherits(i, 'SpatialLines')) {
+ v <- 1:length(i at 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, coordinates(i))
+
+ 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 (class(x) != 'try-error') {
+ v[] <- value
+ x <- try( setValues(x, v) )
+ }
+ }
+ if (class(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)
+ }
+)
+
diff --git a/R/inifile.R b/R/inifile.R
new file mode 100644
index 0000000..dce6c2a
--- /dev/null
+++ b/R/inifile.R
@@ -0,0 +1,91 @@
+# 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)
+}
+
+
+
diff --git a/R/init.R b/R/init.R
new file mode 100644
index 0000000..9d1c38f
--- /dev/null
+++ b/R/init.R
@@ -0,0 +1,105 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 1.0
+# Licence GPL v3
+
+init <- 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'")
+ }
+ }
+
+ 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)
+}
+
diff --git a/R/intDataType.R b/R/intDataType.R
new file mode 100644
index 0000000..a314bd9
--- /dev/null
+++ b/R/intDataType.R
@@ -0,0 +1,94 @@
+# 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)
+}
+
+
diff --git a/R/interpolate.R b/R/interpolate.R
new file mode 100644
index 0000000..161aeb4
--- /dev/null
+++ b/R/interpolate.R
@@ -0,0 +1,199 @@
+
+if (!isGeneric("interpolate")) {
+ setGeneric("interpolate", function(object, ...)
+ standardGeneric("interpolate"))
+}
+
+# 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)
+ xylyrnames <- c('x', 'y', lyrnames)
+
+ haveFactor <- FALSE
+ dataclasses <- try( attr(model$terms, "dataClasses")[-1], silent=TRUE)
+ if (!is.null(dataclasses)) {
+ varnames <- names(dataclasses)
+ if (class(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
+ if (haveFactor) {
+ for (i in 1:length(f)) {
+ blockvals[,f[i]] <- as.factor(blockvals[,f[i]])
+ }
+ }
+
+ 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)
+ }
+
+ colnames(blockvals)[1:2] <- xyNames[1:2]
+
+ if (gstatmod) {
+ if (sp) {
+ row.names(p) <- 1:nrow(p)
+ blockvals <- SpatialPointsDataFrame(coords=p, data = blockvals, proj4string=projection(predrast, asText = FALSE))
+ }
+ 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 at 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)
+ }
+)
diff --git a/R/intersect.R b/R/intersect.R
new file mode 100644
index 0000000..1ce1439
--- /dev/null
+++ b/R/intersect.R
@@ -0,0 +1,64 @@
+# Author: Robert J. Hijmans
+# Date : December 2011
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("intersect")) {
+ setGeneric("intersect", function(x, y)
+ standardGeneric("intersect"))
+}
+
+
+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 at xmin <- max(x at xmin, y at xmin)
+ x at xmax <- min(x at xmax, y at xmax)
+ x at ymin <- max(x at ymin, y at ymin)
+ x at ymax <- min(x at ymax, y at ymax)
+
+ if ((x at xmax <= x at xmin) | (x at ymax <= x at 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 at xmin <- max(e at xmin, e2 at xmin)
+ e at xmax <- min(e at xmax, e2 at xmax)
+ e at ymin <- max(e at ymin, e2 at ymin)
+ e at ymax <- min(e at ymax, e2 at ymax)
+ }
+ if ((e at xmax <= e at xmin) | (e at ymax <= e at ymin) ) {
+ if (validate) {
+ stop('Objects do not intersect')
+ } else {
+ return(NULL)
+ }
+ }
+ return(e)
+}
+
+
diff --git a/R/intersect_sp.R b/R/intersect_sp.R
new file mode 100644
index 0000000..96f8654
--- /dev/null
+++ b/R/intersect_sp.R
@@ -0,0 +1,319 @@
+# Author: Robert J. Hijmans
+# Date : December 2011
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("intersect")) {
+ setGeneric("intersect", function(x, y)
+ standardGeneric("intersect"))
+}
+
+
+setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPolygons'),
+function(x, y) {
+
+ requireNamespace("rgeos")
+
+ x <- spChFIDs(x, as.character(1:length(x)))
+ y <- spChFIDs(y, as.character(1:length(y)))
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+ 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 at data), colnames(y at data)))
+ colnames(x at data) <- xnames <- nms[1:ncol(x at data)]
+ colnames(y at data) <- ynames <- nms[(ncol(x at data)+1):length(nms)]
+ dat <- cbind(x at data[NULL, ,drop=FALSE], y at data[NULL, ,drop=FALSE])
+ } else if (xdata) {
+ dat <- x at data[NULL, ,drop=FALSE]
+ xnames <- colnames(dat)
+ } else if (ydata) {
+ dat <- y at 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 at polyobj)) { # merely touching, no intersection
+# #warning('polygons do not intersect')
+# return(NULL)
+# }
+# int <- int at 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 at data))
+ dat[rows, xnames] <- x at data[idsx, ]
+ }
+ if (ydata) {
+ idsy <- match(ids[,2], rownames(y at data))
+ dat[rows, ynames] <- y at data[idsy, ]
+ }
+ rownames(dat) <- 1:nrow(dat)
+ int <- spChFIDs(int, as.character(1:nrow(dat)))
+ int <- SpatialPolygonsDataFrame(int, dat)
+ }
+
+ if (length(int) > 0) {
+ j <- which(rgeos::gIsValid(int, byid=TRUE, reason=FALSE))
+ int <- int[j, ]
+ }
+ int
+}
+)
+
+
+setMethod('intersect', signature(x='SpatialPolygons', y='SpatialLines'),
+function(x, y) {
+
+ requireNamespace("rgeos")
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+ subs <- rgeos::gIntersects(x, y, byid=TRUE)
+ if (sum(subs)==0) {
+ warning('lines and polygons do not intersect')
+ return(NULL)
+ }
+
+ i <- which(apply(subs, 2, any))
+ x[i, ]
+}
+)
+
+setMethod('intersect', signature(x='SpatialLines', y='SpatialPolygons'),
+function(x, y) {
+
+ requireNamespace("rgeos")
+
+ x <- spChFIDs(x, as.character(1:length(x)))
+ y <- spChFIDs(y, as.character(1:length(y)))
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at 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 at data), colnames(y at data)))
+ colnames(x at data) <- xnames <- nms[1:ncol(x at data)]
+ colnames(y at data) <- ynames <- nms[(ncol(x at data)+1):length(nms)]
+ dat <- cbind(x at data[NULL, ,drop=FALSE], y at data[NULL, ,drop=FALSE])
+ } else if (xdata) {
+ dat <- x at data[NULL, ,drop=FALSE]
+ xnames <- colnames(dat)
+ } else if (ydata) {
+ dat <- y at 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 at polyobj)) { # merely touching, no intersection
+# #warning('polygons do not intersect')
+# return(NULL)
+# }
+# int <- int at 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 at data))
+ dat[rows, xnames] <- x at data[idsx, ]
+ }
+ if (ydata) {
+ idsy <- match(ids[,2], rownames(y at data))
+ dat[rows, ynames] <- y at data[idsy, ]
+ }
+ rownames(dat) <- 1:nrow(dat)
+ int <- spChFIDs(int, as.character(1:nrow(dat)))
+ int <- SpatialLinesDataFrame(int, dat)
+ }
+
+ if (length(int) > 0) {
+ j <- which(rgeos::gIsValid(int, byid=TRUE, reason=FALSE))
+ int <- int[j, ]
+ }
+ int
+}
+)
+
+
+setMethod('intersect', signature(x='SpatialLines', y='SpatialLines'),
+function(x, y) {
+ stopifnot(requireNamespace("rgeos"))
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+
+ xdata <-.hasSlot(x, 'data')
+ ydata <-.hasSlot(y, 'data')
+
+ x <- spChFIDs(x, as.character(1:length(x)))
+ y <- spChFIDs(y, as.character(1:length(y)))
+
+ if (! any(c(xdata, ydata))) {
+ z <- rgeos::gIntersection(x, y, byid=TRUE)
+ if (is.null(z)) {
+ z <- SpatialPoints(cbind(0,0), proj4string=crs(x))
+ z <- SpatialPointsDataFrame(z,data.frame(x=0, y=0))
+ return( z[-1, ] )
+ }
+ rn <- rownames(z at coords)
+ d <- data.frame(matrix(as.integer(unlist(strsplit(rn, ' '))), ncol=2, byrow=TRUE))
+ colnames(d) <- c('x', 'y')
+ rownames(z at coords) <- NULL
+ z <- SpatialPointsDataFrame(z,d)
+ return(z)
+ }
+
+ z <- rgeos::gIntersection(y, x, byid=TRUE)
+
+ if (is.null(z)) {
+ z <- SpatialPoints(cbind(0,0), proj4string=crs(x))
+ return( z[-1, ] )
+ }
+
+ if (inherits(z, 'SpatialCollections')) {
+ z <- z at pointobj
+ }
+
+ s <- strsplit(spChFIDs(z), ' ')
+ s <- matrix(as.integer(unlist(s)), ncol=2, byrow=TRUE)
+
+ if (xdata & ydata) {
+ nms <- .goodNames(c(colnames(x at data), colnames(y at data)))
+ xnames <- nms[1:ncol(x at data)]
+ ynames <- nms[(ncol(x at data)+1):length(nms)]
+ xd <- x at data[s[,2], ]
+ yd <- y at data[s[,1], ]
+ d <- cbind(xd, yd)
+ colnames(d) <- c(xnames, ynames)
+ } else if (xdata) {
+ d <- x at data[s[,2], ]
+ } else if (ydata) {
+ d <- y at data[s[,1], ]
+ }
+ row.names(d) <- NULL
+ row.names(z) <- as.character(1:length(z))
+ SpatialPointsDataFrame(z, d)
+}
+)
+
+
+
+setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPoints'),
+function(x, y) {
+
+ stopifnot(requireNamespace("rgeos"))
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+ i <- rgeos::gIntersects(x, y, byid=TRUE)
+ i <- which(apply(i, 2, any))
+ 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 (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+ if (inherits(y, 'SpatialPolygons')) {
+
+ stopifnot(requireNamespace("rgeos"))
+ 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]
+ j <- j[order(j[,2]), ]
+ x <- x[j[,2], ]
+
+ if (.hasSlot(y, 'data')) {
+ d <- y at data[j[,1], ]
+ if (!.hasSlot(x, 'data')) {
+ x <- SpatialPointsDataFrame(x, d)
+ } else {
+ x at data <- cbind(x at data, d)
+ }
+ }
+ return(x)
+
+ } else {
+ y <- extent(y)
+ xy <- coordinates(x)
+ i <- xy[,1] >= y at xmin & xy[,1] <= y at xmax & xy[,2] >= y at ymin & xy[,2] <= y at ymax
+ x[i, ]
+ }
+}
+)
+
+
+
+
+setMethod('intersect', signature(x='SpatialPolygons', y='ANY'),
+function(x, y) {
+ y <- extent(y)
+ y <- as(y, 'SpatialPolygons')
+ intersect(x, y)
+}
+)
diff --git a/R/is.na.R b/R/is.na.R
new file mode 100644
index 0000000..4dff942
--- /dev/null
+++ b/R/is.na.R
@@ -0,0 +1,129 @@
+# 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)
+ }
+ }
+)
+
diff --git a/R/isLonLat.R b/R/isLonLat.R
new file mode 100644
index 0000000..d5c2458
--- /dev/null
+++ b/R/isLonLat.R
@@ -0,0 +1,122 @@
+# 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(...) {
+ couldBeLonLat(...)
+}
+
+couldBeLonLat <- function(x, warnings=TRUE) {
+ crsLL <- isLonLat(x)
+ crsNA <- is.na(projection(x))
+ e <- extent(x)
+ extLL <- (e at xmin > -365 & e at xmax < 365 & e at ymin > -90.1 & e at 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)
+ }
+}
+
+
+if (!isGeneric("isLonLat")) {
+ setGeneric("isLonLat", function(x)
+ standardGeneric("isLonLat"))
+}
+
+
+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 <- projection(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 at projargs)) {
+ return(FALSE)
+ } else {
+ p4str <- trim(x at projargs)
+ }
+ 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='ANY'),
+ function(x){
+ isLonLat(as.character(x))
+ }
+)
diff --git a/R/kernelDens.R b/R/kernelDens.R
new file mode 100644
index 0000000..d4aa15a
--- /dev/null
+++ b/R/kernelDens.R
@@ -0,0 +1,36 @@
+
+### 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)
+
diff --git a/R/kml.R b/R/kml.R
new file mode 100644
index 0000000..9b05dc4
--- /dev/null
+++ b/R/kml.R
@@ -0,0 +1,108 @@
+# 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')
+ spTransform(x, CRS('+proj=longlat +datum=WGS84'))
+ }
+ }
+
+ if (!.hasSlot(x, 'data') ) {
+ x <- 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')
+ }
+ }
+
+
+
+ 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, ...)
+ dev.off()
+
+ name <- names(x)[1]
+ if (name == "") { name <- 'x' }
+ kml <- c('<?xml version="1.0" encoding="UTF-8"?>', '<kml xmlns="http://www.opengis.net/kml/2.2">', "<GroundOverlay>")
+ kmname <- paste("<name>", name, "</name>", sep = "")
+ icon <- paste("<Icon><href>", basename(imagefile), "</href><viewBoundScale>0.75</viewBoundScale></Icon>", sep = "")
+ e <- extent(x)
+ latlonbox <- c("\t<LatLonBox>", paste("\t\t<north>", e at ymax, "</north><south>", e at ymin, "</south><east>", e at xmax, "</east><west>", e at xmin, "</west>", sep = ""), "\t</LatLonBox>")
+ footer <- "</GroundOverlay></kml>"
+
+ 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)
+}
+)
diff --git a/R/kml_multiple.R b/R/kml_multiple.R
new file mode 100644
index 0000000..30611dc
--- /dev/null
+++ b/R/kml_multiple.R
@@ -0,0 +1,128 @@
+# 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('<?xml version="1.0" encoding="UTF-8"?>', '<kml xmlns="http://www.opengis.net/kml/2.2">')
+ kml <- c(kml, c("<Folder>", paste("<name>", extension(basename(filename), ''), "</name>", sep='')))
+ e <- extent(x)
+ latlonbox <- c("\t<LatLonBox>", paste("\t\t<north>", e at ymax, "</north><south>", e at ymin, "</south><east>",
+ e at xmax, "</east><west>", e at xmin, "</west>", sep = ""), "\t</LatLonBox>", "</GroundOverlay>")
+
+ imagefile <- paste(extension(filename, ''), "_", 1:nl, ".png", sep="")
+
+
+ for (i in 1:nl) {
+ 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, ...)
+ dev.off()
+ a <- c("<GroundOverlay>", paste("\t<name>", name[i], "</name>", sep=''))
+ if (dotime) {
+ if (when) {
+ atime <- c("\t<TimeSpan>", paste("\t\t<when>", time[i], "</when>", sep=''), "\t</TimeSpan>")
+ } else {
+ atime <- c("\t<TimeSpan>", paste("\t\t<begin>", time[i], "</begin>", sep=''),
+ paste("\t\t<end>", time[i+1], "</end>", sep=''), "\t</TimeSpan>")
+ }
+ }
+ kml <- c(kml, a, atime, paste("\t<Icon><href>", basename(imagefile[i]), "</href></Icon>", sep=''), latlonbox)
+ }
+
+ kml <- c(kml, "</Folder>", "</kml>")
+ cat(paste(kml, sep="", collapse="\n"), file=kmlfile, sep = "")
+ .zipKML(kmlfile, imagefile, zip, overwrite=overwrite)
+}
+)
+
diff --git a/R/labels.R b/R/labels.R
new file mode 100644
index 0000000..6cfb2bd
--- /dev/null
+++ b/R/labels.R
@@ -0,0 +1,43 @@
+
+
+.polygonLabelPosition <- function(x, cex=1) {
+ xy <- coordinates(x)
+ # make sure that labels are inside of polygons
+ sx <- 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 at xmax - e at xmin)
+ dy <- 0.25 * (e at ymax - e at 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
+}
+
+
diff --git a/R/layerStats.R b/R/layerStats.R
new file mode 100644
index 0000000..f6c28f5
--- /dev/null
+++ b/R/layerStats.R
@@ -0,0 +1,104 @@
+# 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)
+
+ }
+}
+
+
diff --git a/R/layerize.R b/R/layerize.R
new file mode 100644
index 0000000..c07d61e
--- /dev/null
+++ b/R/layerize.R
@@ -0,0 +1,178 @@
+# Author: Robert J. Hijmans
+# Date : August 2012
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("layerize")) {
+ setGeneric("layerize", function(x, y, ...)
+ standardGeneric("layerize"))
+}
+
+
+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 <- .Call("layerize", v, as.integer(classes), as.integer(falseNA), PACKAGE='raster')
+ 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 <- .Call("layerize", v, classes, fNA, PACKAGE='raster')
+ 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
+}
+)
+
diff --git a/R/localFun.R b/R/localFun.R
new file mode 100644
index 0000000..db804c3
--- /dev/null
+++ b/R/localFun.R
@@ -0,0 +1,44 @@
+# 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))
+ }
+ }
+)
+
diff --git a/R/makeProjString.R b/R/makeProjString.R
new file mode 100644
index 0000000..9047613
--- /dev/null
+++ b/R/makeProjString.R
@@ -0,0 +1,72 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+
+.newCRS <- function(projs) {
+
+ if (is.null(projs)) {
+ prj <- CRS()
+ } else if (is.na(projs)) {
+ prj <- CRS()
+ } else if (.nchar(projs) < 3) {
+ prj <- CRS()
+ } else {
+ projs <- trim(projs)
+ prj <- try(CRS(projs), silent = TRUE)
+ if (class(prj) == "try-error") {
+ warning(paste(projs, 'is not a valid PROJ.4 CRS string'))
+ prj <- 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 at projargs))
+ } else {
+ return(crs)
+ }
+}
+
diff --git a/R/makeRasterList.R b/R/makeRasterList.R
new file mode 100644
index 0000000..0e1d1d2
--- /dev/null
+++ b/R/makeRasterList.R
@@ -0,0 +1,70 @@
+# 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 <- sum(sapply(x, hasValues))
+ if (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, ...)
+}
+)
+
diff --git a/R/mask.R b/R/mask.R
new file mode 100644
index 0000000..6e77375
--- /dev/null
+++ b/R/mask.R
@@ -0,0 +1,674 @@
+# Author: Robert J. Hijmans
+# Date : November 2009
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("mask")) {
+ setGeneric("mask", function(x, mask, ...)
+ standardGeneric("mask"))
+}
+
+
+setMethod('mask', signature(x='Raster', mask='Spatial'),
+function(x, mask, filename="", inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...){
+ mask <- rasterize(mask, x, 1, silent=TRUE)
+ mask(x, mask, 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)
+ }
+}
+)
+
diff --git a/R/match.R b/R/match.R
new file mode 100644
index 0000000..551f87f
--- /dev/null
+++ b/R/match.R
@@ -0,0 +1,30 @@
+# Author: Robert J. Hijmans
+# Date : October 2011
+# October 2011
+# version 1
+# Licence GPL v3
+
+
+if (!isGeneric("%in%")) {
+ setGeneric("%in%", function(x, table)
+ standardGeneric("%in%"))
+}
+
+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))
+ }
+)
+
diff --git a/R/math.R b/R/math.R
new file mode 100644
index 0000000..5bd0085
--- /dev/null
+++ b/R/math.R
@@ -0,0 +1,198 @@
+# 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("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 at data@values)))
+ } else {
+ setValues(x, methods::callGeneric(x at data@values))
+ }
+ }
+)
+
+
+
+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)
+ }
+)
+
diff --git a/R/maxDataType.R b/R/maxDataType.R
new file mode 100644
index 0000000..3dd4eec
--- /dev/null
+++ b/R/maxDataType.R
@@ -0,0 +1,12 @@
+
+.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' )
+ }
+}
\ No newline at end of file
diff --git a/R/mean.R b/R/mean.R
new file mode 100644
index 0000000..448f9eb
--- /dev/null
+++ b/R/mean.R
@@ -0,0 +1,233 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# revised: October 2011
+# Version 1.0
+# Licence GPL v3
+
+
+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 (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) )
+ }
+}
+
+
diff --git a/R/merge.R b/R/merge.R
new file mode 100644
index 0000000..94ce8a0
--- /dev/null
+++ b/R/merge.R
@@ -0,0 +1,439 @@
+# 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
+
+if (!isGeneric("merge")) {
+ setGeneric("merge", function(x, y, ...)
+ standardGeneric("merge"))
+}
+
+
+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 (class(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)
+}
+)
+
+
diff --git a/R/metadata.R b/R/metadata.R
new file mode 100644
index 0000000..8ed7c1c
--- /dev/null
+++ b/R/metadata.R
@@ -0,0 +1,28 @@
+
+metadata <- function(x) {
+ x at 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 at history <- value
+ x
+}
+
diff --git a/R/minValue.R b/R/minValue.R
new file mode 100644
index 0000000..d599524
--- /dev/null
+++ b/R/minValue.R
@@ -0,0 +1,160 @@
+# 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 at data@haveminmax ) {
+ v <- x at data@min
+ if (isTRUE( v == Inf)) {
+ v <- NA
+ } else {
+ if (! inMemory(x) ) {
+ v <- v * x at data@gain + x at 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 at data@haveminmax ) {
+ v <- x at data@min
+ v[v == Inf] <- NA
+ if (! inMemory(x) ) {
+ v <- v * x at data@gain + x at data@offset
+ }
+ return(v)
+ } else {
+ warning('min value not known, use setMinMax')
+ return(rep(NA, nlayers(x)))
+ }
+ } else {
+ if ( x at data@haveminmax ) {
+ v <- x at data@min[layer] * x at data@gain + x at 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 at layers[[i]], warn=warn)
+ }
+ } else {
+ if (layer <= nl) {
+ v <- minValue(x at 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 at data@haveminmax ) {
+ v <- x at data@max
+ if (isTRUE( v == -Inf)) {
+ v <- NA
+ } else {
+ if (! inMemory(x) ) {
+ v <- v * x at data@gain + x at 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 at data@haveminmax ) {
+ v <- x at data@max
+ v[!is.finite(v)] <- NA
+ if (! inMemory(x) ) {
+ v <- v * x at data@gain + x at 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 at layers[[i]], warn=warn)
+ }
+ } else {
+ if (layer <= nl) {
+ v <- maxValue(x at layers[[layer]])
+ } else {
+ stop('incorrect layer number')
+ }
+ }
+ return(v)
+ }
+)
+
diff --git a/R/modal.R b/R/modal.R
new file mode 100644
index 0000000..1346205
--- /dev/null
+++ b/R/modal.R
@@ -0,0 +1,68 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# revised: October 2011, May 2015
+# Version 1.0
+# Licence GPL v3
+
+
+setGeneric("modal", function(x, ...)
+ standardGeneric("modal"))
+
+
+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)
+}
+)
+
diff --git a/R/modalRaster.R b/R/modalRaster.R
new file mode 100644
index 0000000..3e5b0b1
--- /dev/null
+++ b/R/modalRaster.R
@@ -0,0 +1,47 @@
+# 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) {
+ stop('there is not much point in computing a modal value for a single layer')
+ } 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)
+ }
+)
+
diff --git a/R/moran.R b/R/moran.R
new file mode 100644
index 0000000..d0412e3
--- /dev/null
+++ b/R/moran.R
@@ -0,0 +1,67 @@
+# 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
+}
+
+
diff --git a/R/mosaic.R b/R/mosaic.R
new file mode 100644
index 0000000..5d2b8a4
--- /dev/null
+++ b/R/mosaic.R
@@ -0,0 +1,170 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+# redesigned for multiple row processing
+# October 2011
+# version 1
+
+if (!isGeneric("mosaic")) {
+ setGeneric("mosaic", function(x, y, ...)
+ standardGeneric("mosaic"))
+}
+
+
+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) == '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)
+}
+)
+
diff --git a/R/movingFun.R b/R/movingFun.R
new file mode 100644
index 0000000..1fc5819
--- /dev/null
+++ b/R/movingFun.R
@@ -0,0 +1,36 @@
+# 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]
+}
+
diff --git a/R/multiCore.R b/R/multiCore.R
new file mode 100644
index 0000000..9538a4f
--- /dev/null
+++ b/R/multiCore.R
@@ -0,0 +1,95 @@
+# 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)
+}
+
diff --git a/R/naValue.R b/R/naValue.R
new file mode 100644
index 0000000..c8126a7
--- /dev/null
+++ b/R/naValue.R
@@ -0,0 +1,42 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 1.0
+# Licence GPL v3
+
+.naChanged <- function(x) {
+ if (.hasSlot(x at file, 'NAchanged')) {
+ return(x at 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 at layers[[i]]@file at nodatavalue <- value[i]
+ x at layers[[i]]@file at NAchanged <- TRUE
+ }
+ } else {
+ x at file@nodatavalue <- value[[1]]
+ x at file@NAchanged <- TRUE
+ }
+ return(x)
+}
+
+NAvalue <- function(x) {
+ if (inherits(x, 'RasterStack')) {
+ sapply(x at layers, function(x) { x at file@nodatavalue })
+ } else {
+ return(x at file@nodatavalue)
+ }
+}
+
diff --git a/R/names.R b/R/names.R
new file mode 100644
index 0000000..b1256bd
--- /dev/null
+++ b/R/names.R
@@ -0,0 +1,98 @@
+# Author: Robert J. Hijmans
+# Date: October 2008
+# Version 0.9
+# Licence GPL v3
+
+
+.uniqueNames <- function(x, sep='.') {
+ y <- as.matrix(table(x))
+ y <- y[y[,1] > 1, ,drop=F]
+ if (nrow(y) > 0) {
+ y <- rownames(y)
+ for (i in 1:length(y)) {
+ j <- which(x==y[i])
+ 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 at data, 'names')) {
+ ln <- x at data@names
+ } else {
+ ln <- x at layernames
+ }
+ ln <- ln[1:nlayers(x)]
+ validNames(as.vector(ln))
+ }
+)
+
+
+setMethod('names', signature(x='RasterStack'),
+ function(x) {
+ ln <- sapply(x at layers, function(i) i at 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 at layers <- sapply(1:nl, function(i){
+ r <- x at layers[[i]]
+ r at data@names <- value[i]
+ r
+ })
+
+ } else {
+ if (.hasSlot(x at data, 'names')) {
+ x at data@names <- value
+ } else {
+ x at layernames <- value
+ }
+ }
+
+ return(x)
+ }
+)
+
diff --git a/R/ncell.R b/R/ncell.R
new file mode 100644
index 0000000..ea4b277
--- /dev/null
+++ b/R/ncell.R
@@ -0,0 +1,32 @@
+# Author: Robert J. Hijmans
+# Date : April 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("ncell")) {
+ setGeneric("ncell", function(x)
+ standardGeneric("ncell"))
+}
+
+setMethod('ncell', signature(x='BasicRaster'),
+ function(x) {
+ return(as.numeric(x at ncols) * x at nrows)
+ }
+)
+
+
+setMethod('ncell', signature(x='ANY'),
+ function(x) {
+ NROW(x) * NCOL(x)
+ }
+)
+
+
+
+setMethod('length', signature(x='BasicRaster'),
+ function(x) {
+ ncell(x) * nlayers(x)
+ }
+)
+
diff --git a/R/nchar.R b/R/nchar.R
new file mode 100644
index 0000000..be33fd8
--- /dev/null
+++ b/R/nchar.R
@@ -0,0 +1,7 @@
+
+.nchar <- function(x) {
+ x[is.na(x)] <- ''
+ sapply(strsplit(x, NULL), length)
+}
+
+
diff --git a/R/netCDFread.R b/R/netCDFread.R
new file mode 100644
index 0000000..8ca745b
--- /dev/null
+++ b/R/netCDFread.R
@@ -0,0 +1,198 @@
+# 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 at file@toptobottom ) {
+ row <- x at nrows - row - nrows + 2
+ }
+ is.open <- x at file@open
+ if (is.open) {
+ nc <- x at file@con
+ } else {
+ nc <- ncdf4::nc_open(x at file@name)
+ on.exit( ncdf4::nc_close(nc) )
+ }
+
+ zvar <- x at 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 at data@band)
+ count <- c(ncols, nrows, 1)
+ d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)
+
+ } else {
+ if (x at data@dim3 == 4) {
+ start <- c(col, row, x at data@level, x at 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 at data@band, x at data@level)
+ count <- c(ncols, nrows, 1, 1)
+ d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)
+ }
+ }
+
+
+ #if (!is.na(x at file@nodatavalue)) { d[d==x at file@nodatavalue] <- NA }
+ #d <- x at data@add_offset + d * x at data@scale_factor
+
+ if (length(dim(d)) > 1) {
+ if ( x at file@toptobottom ) {
+ d <- d[, ncol(d):1]
+ }
+ }
+ d <- as.vector(d)
+ d[d == x at file@nodatavalue] <- NA
+ return(d)
+}
+
+
+
+.readRowsBrickNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) {
+
+
+ if (nlayers(x) == 1) {
+ return(.readRowsNetCDF(x=x, row=row, nrows=nrows, col=col, ncols=ncols) )
+ }
+
+ is.open <- x at file@open
+
+ if ( x at file@toptobottom ) {
+ row <- x at nrows - row - nrows + 2
+ }
+ navalue <- x at 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 at nrows-row+1)
+ ncols <- min((x at ncols-col+1), ncols)
+ stopifnot(nrows > 0)
+ stopifnot(ncols > 0)
+
+ if (is.open) {
+ nc <- x at file@con
+ } else {
+ nc <- ncdf4::nc_open(x at file@name)
+ on.exit( ncdf4::nc_close(nc) )
+ }
+ zvar <- x at data@zvar
+
+ if (nc$var[[zvar]]$ndims == 4) {
+ if (x at data@dim3 == 4) {
+ start <- c(col, row, x at data@level, layer)
+ count <- c(ncols, nrows, 1, nn)
+ } else {
+ start <- c(col, row, layer, x at data@level)
+ count <- c(ncols, nrows, nn, 1)
+ }
+ } 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 at file@nodatavalue)) { d[d==x at file@nodatavalue] <- NA }
+ #d <- x at data@add_offset + d * x at data@scale_factor
+
+ if (nlayers(x) > 1) {
+ dims = dim(d)
+
+ if (length(dims) == 3) {
+ if ( x at 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 at 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 at file@toptobottom ) {
+ v[] <- as.vector(d[,ncol(d):1])
+ } else {
+ v[] <- as.vector(d)
+ }
+
+ } else if (ncols==1) {
+ if ( x at 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 at file@toptobottom & nrows > 1) {
+ d <- rev(d)
+ }
+
+ v[] <- d # d[, alyrs, drop=FALSE]
+ }
+ } else {
+ if ( x at 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)
+}
+
diff --git a/R/netCDFreadCells.R b/R/netCDFreadCells.R
new file mode 100644
index 0000000..f93bd73
--- /dev/null
+++ b/R/netCDFreadCells.R
@@ -0,0 +1,174 @@
+# 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 at 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 at file@toptobottom ) {
+ readrows <- x at nrows - readrows + 1
+ }
+
+ zvar = x at data@zvar
+ time = x at data@band
+
+ nc <- ncdf4::nc_open(x at file@name)
+ on.exit( ncdf4::nc_close(nc) )
+ getfun <- ncdf4::ncvar_get
+
+ if (nc$var[[zvar]]$ndims == 1) {
+ ncx <- x at ncols
+ count <- ncx
+ for (i in 1:length(rows)) {
+ start <- (readrows[i]-1) * ncx + 1
+ v <- as.vector(getfun(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 at ncols, 1)
+ for (i in 1:length(rows)) {
+ start <- c(1, readrows[i])
+ v <- as.vector(getfun(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 at ncols, 1, 1)
+ for (i in 1:length(rows)) {
+ start <- c(1, readrows[i], time)
+ v <- as.vector(getfun(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 at data@dim3 == 4) {
+ count <- c(x at ncols, 1, 1, 1)
+ for (i in 1:length(rows)) {
+ start <- c(1, readrows[i], x at data@level, time)
+ v <- as.vector(getfun(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 at ncols, 1, 1, 1)
+ for (i in 1:length(rows)) {
+ start <- c(1, readrows[i], time, x at data@level)
+ v <- as.vector(getfun(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 at file@nodatavalue)) { colrow[colrow==x at file@nodatavalue] <- NA }
+ #colrow <- x at data@add_offset + colrow * x at data@scale_factor
+
+ colrow[colrow == x at 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 at data@zvar
+ dim3 <- x at data@dim3
+ cols <- colFromCell(x, cells)
+ rows <- rowFromCell(x, cells)
+ if ( x at file@toptobottom ) {
+ rows <- x at nrows - rows + 1
+ }
+
+
+ nc <- ncdf4::nc_open(x at file@name)
+ on.exit( ncdf4::nc_close(nc) )
+ getfun <- ncdf4::ncvar_get
+
+ # 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] <- getfun(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,] <- getfun(nc, varid=zvar, start=start, count=count)
+ }
+ } else {
+ if (x at 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 at data@level, layer)
+ res[i,] <- getfun(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 at data@level)
+ res[i,] <- getfun(nc, varid=zvar, start=start, count=count)
+ }
+ }
+ }
+
+ #if (!is.na(x at file@nodatavalue)) { res[res==x at file@nodatavalue] <- NA }
+ #res <- x at data@add_offset + res * x at data@scale_factor
+
+ res[res == x at file@nodatavalue] <- NA
+ return(res)
+}
+
+
+
+
diff --git a/R/netCDFtoRasterCD.R b/R/netCDFtoRasterCD.R
new file mode 100644
index 0000000..8498223
--- /dev/null
+++ b/R/netCDFtoRasterCD.R
@@ -0,0 +1,342 @@
+# 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
+
+ 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
+ }
+ if (dohours) {
+ startTime <- substr(un, 13, 30)
+ startTime <- strptime(startTime, "%Y-%m-%d %H:%M:%OS")
+ time <- startTime + as.numeric(getZ(x)) * 3600
+ time <- as.character(time)
+ if (!is.na(time[1])) {
+ x at z <- list(time)
+ names(x at 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 at z <- list(time)
+ names(x at 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=3, level=0,
+ warn=TRUE, dims=1:3, crs=NA, stopIfNotEqualSpaced=TRUE, ...) {
+
+ stopifnot(requireNamespace("ncdf4"))
+
+ nc <- ncdf4::nc_open(filename)
+ on.exit( ncdf4::nc_close(nc) )
+ conv <- ncdf4::ncatt_get(nc, 0, "Conventions")
+
+ # 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 (type != 'RasterQuadBrick') {
+ nlevs <- nc$var[[zvar]]$dim[[lvar]]$len
+ if (level <=0 ) {
+ level <- 1
+ 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
+
+ xx <- nc$var[[zvar]]$dim[[dims[1]]]$vals
+ 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)
+
+
+ yy <- nc$var[[zvar]]$dim[[dims[2]]]$vals
+ 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 <- ''
+
+ prj <- NA
+ 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)
+ } else {
+ a <- ncdf4::ncatt_get(nc, zvar, "projection_format")
+ if ( a$hasatt ) {
+ projection_format <- a$value
+ if (isTRUE(projection_format == "PROJ.4")) {
+ a <- ncdf4::ncatt_get(nc, zvar, "projection")
+ if ( a$hasatt ) {
+ prj <- a$value
+ }
+ }
+ }
+ }
+ natest <- ncdf4::ncatt_get(nc, zvar, "_FillValue")
+ natest2 <- ncdf4::ncatt_get(nc, zvar, "missing_value")
+
+
+ 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 at title <- long_name
+ } else if (type == 'RasterQuadBrick') {
+ r <- .quad(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs)
+ r at title <- long_name
+ if (lvar == 4) {
+ dim3 <- 3
+ step3 <- 4
+ } else {
+ dim3 <- 4
+ step3 <- 3
+ }
+ r at nlevels <- nc$var[[zvar]]$dim[[dim3]]$len
+ r at steps <- nc$var[[zvar]]$dim[[step3]]$len
+ }
+
+ r at file@name <- filename
+ r at file@toptobottom <- toptobottom
+ r at data@unit <- unit
+
+
+ attr(r at data, "zvar") <- zvar
+ attr(r at data, "dim3") <- dim3
+ attr(r at data, "level") <- level
+
+ r at file@driver <- "netcdf"
+
+ if (natest$hasatt) {
+ r at file@nodatavalue <- as.numeric(natest$value)
+ } else if (natest2$hasatt) {
+ r at file@nodatavalue <- as.numeric(natest2$value)
+ }
+ r at data@fromdisk <- TRUE
+
+ if (ndims == 2) {
+ nbands = 1
+ } else {
+ r at file@nbands <- nc$var[[zvar]]$dim[[dim3]]$len
+ r at z <- list( nc$var[[zvar]]$dim[[dim3]]$vals )
+ if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) {
+ try( r <- .doTime(r, nc, zvar, dim3) )
+ } else {
+ names(r at z) <- nc$var[[zvar]]$dim[[dim3]]$units
+ }
+ }
+
+ 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 at data@band <- as.integer(1)
+ } else {
+ band <- as.integer(band)
+ if ( band > nbands(r) ) {
+ stop(paste("band too high. Should be between 1 and", nbands))
+ }
+ if ( band < 1) {
+ stop(paste("band should be 1 or higher"))
+ }
+ r at data@band <- band
+ }
+ r at z <- list( getZ(r)[r at data@band] )
+ }
+
+ } else {
+ r at data@nlayers <- r at file@nbands
+ r at data@min <- rep(Inf, r at file@nbands)
+ r at data@max <- rep(-Inf, r at file@nbands)
+ try( names(r) <- as.character(r at z[[1]]), silent=TRUE )
+ }
+
+ return(r)
+}
+
diff --git a/R/netCDFtoRasterGMT.R b/R/netCDFtoRasterGMT.R
new file mode 100644
index 0000000..a27ea15
--- /dev/null
+++ b/R/netCDFtoRasterGMT.R
@@ -0,0 +1,41 @@
+# 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 at file@name <- nc$filename
+ r at file@toptobottom <- FALSE
+ attr(r at data, "zvar") <- zvar
+ attr(r at data, "dim3") <- 1
+ r at file@driver <- "netcdf"
+ r at data@fromdisk <- TRUE
+ return(r)
+}
+
diff --git a/R/netCDFtoStack.R b/R/netCDFtoStack.R
new file mode 100644
index 0000000..705677e
--- /dev/null
+++ b/R/netCDFtoStack.R
@@ -0,0 +1,51 @@
+# 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)
+ 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 at title <- names(r)
+
+ if (length(bands) > 1) {
+ st at z <- list( nc$var[[zvar]]$dim[[dim3]]$vals[bands] )
+ names(st at 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 at z[[1]])
+ st at layers <- lapply(bands, function(x){
+ r at data@band <- x;
+ r at data@names <- nms[x];
+ return(r)}
+ )
+ }
+ return( st )
+}
+
+ #s = .stackCDF(f, varname='uwnd')
diff --git a/R/netCDFutil.R b/R/netCDFutil.R
new file mode 100644
index 0000000..9e08f14
--- /dev/null
+++ b/R/netCDFutil.R
@@ -0,0 +1,123 @@
+# Author: Robert J. Hijmans
+# Date: June 2010
+# Version 1.0
+# Licence GPL v3
+
+
+.getCRSfromGridMap4 <- function(g) {
+# 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", "+lon_0", "semi_major_axis", "+a", "inverse_flattening", "+rf"), ncol=2, byrow=TRUE)
+
+
+ sp <- g$standard_parallel
+ if (!is.null(sp)) {
+ if (length(sp) > 1) {
+ g$standard_parallel1 <- sp[1]
+ g$standard_parallel2 <- sp[2]
+ g$standard_parallel <- NULL
+ }
+ }
+ vars <- names(g)
+ vals <- as.vector(unlist(g))
+ 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)
+ mtxt <- paste(apply(gg, 1, function(x) paste(x, collapse='=')), collapse='; ')
+ 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)
+ 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(CRS(cr), silent=TRUE)
+ if (class(crtst) == 'try-error') {
+ mtxt <- paste(m, collapse='; ')
+ warning("cannot create a valid CRS\n", mtxt)
+ return(NA)
+ } else {
+ return(cr)
+ }
+}
+
+
+.isNetCDF <- function(x) {
+ on.exit(options('warn'= getOption('warn')))
+ options('warn'=-1)
+ fcon <- file(x, "rb")
+ 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" )
+ }
+ }
+}
+
+
diff --git a/R/netCDFwriteCD.R b/R/netCDFwriteCD.R
new file mode 100644
index 0000000..300bc3d
--- /dev/null
+++ b/R/netCDFwriteCD.R
@@ -0,0 +1,256 @@
+# Author: Robert J. Hijmans
+# Date: June 2010
+# Version 1.0
+# Licence GPL v3
+
+
+
+.startWriteCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, 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 at title
+ varname <- attr(x at data, 'zvar')
+ if (is.null(varname)) {
+ varname <- names(x at z)
+ if (is.null(varname)) {
+ varname <- 'variable'
+ }
+ }
+ }
+ }
+ x at title <- varname
+ if (missing(varunit)) varunit <- ''
+ if (missing(longname)) longname <- varname
+
+ 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-01-01 00:00:00')
+ zunit <- 'days'
+ } else {
+ zatt <- list('units=seconds since 1970-01-01 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'
+ }
+
+ 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), NAvalue(x), prec = ncdatatype, ... )
+ } else {
+ vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim, ydim), NAvalue(x), prec = ncdatatype, ... )
+ }
+ nc <- ncdf4::nc_create(filename, vardef, force_v4=force_v4)
+
+ if (! missing(zatt)){
+ for (i in 1:length(zatt)) {
+ a <- trim(unlist(strsplit(zatt[[i]], '=')))
+ ncdf4::ncatt_put(nc, zname, a[1], a[2])
+ }
+ }
+
+ if (!missing(NAflag)) {
+ x at file@nodatavalue <- NAflag
+ }
+
+ ncdf4::ncatt_put(nc, varname, '_FillValue', x at file@nodatavalue, prec=ncdatatype, definemode=TRUE)
+ ncdf4::ncatt_put(nc, varname, 'missing_value', x at file@nodatavalue, prec=ncdatatype)
+ ncdf4::ncatt_put(nc, varname, 'long_name', longname, prec='text')
+
+ proj <- projection(x)
+ if (! is.na(proj)) {
+ ncdf4::ncatt_put(nc, 0, 'crs', proj, prec='text')
+ ncdf4::ncatt_put(nc, 0, 'crs_format', 'PROJ.4', 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 at data@min <- rep(Inf, nl)
+ x at data@max <- rep(-Inf, nl)
+ x at data@haveminmax <- FALSE
+ x at file@driver <- 'netcdf'
+ x at file@name <- filename
+
+ return(x)
+}
+
+
+.stopWriteCDF <- function(x) {
+ nc <- ncdf4::nc_open(x at file@name, write=TRUE)
+ on.exit( ncdf4::nc_close(nc) )
+ ncdf4::ncatt_put(nc, x at title, 'min', as.numeric(x at data@min))
+ ncdf4::ncatt_put(nc, x at title, 'max', as.numeric(x at data@max))
+
+ if (inherits(x, 'RasterBrick')) {
+ r <- brick(x at file@name)
+ } else {
+ r <- raster(x at file@name)
+ }
+
+ return(r)
+}
+
+
+.writeValuesCDF <- function(x, v, start=1) {
+
+ rsd <- stats::na.omit(v)
+ if (length(rsd) > 0) {
+ x at data@min <- min(x at data@min, rsd)
+ x at data@max <- max(x at data@max, rsd)
+ }
+
+ v[is.na(v)] <- x at file@nodatavalue
+ nr <- length(v) / x at ncols
+ v <- matrix(v, ncol=nr)
+
+ nc <- ncdf4::nc_open(x at file@name, write=TRUE)
+ on.exit( ncdf4::nc_close(nc) )
+ try ( ncdf4::ncvar_put(nc, x at title, v, start=c(1, start), count=c(x at 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 at data@min <- pmin(x at data@min, rsd[1,])
+ x at data@max <- pmax(x at data@max, rsd[2,])
+ options('warn'= w)
+
+ } else {
+ nl <- 1
+ lstart <- layer
+ lend <- layer
+
+ rsd <- stats::na.omit(v)
+ if (length(rsd) > 0) {
+ x at data@min[layer] <- min(x at data@min[layer], rsd)
+ x at data@max[layer] <- max(x at data@max[layer], rsd)
+ }
+
+ }
+ ncols <- x at ncols
+
+
+ v[is.na(v)] = x at file@nodatavalue
+ rows <- length(v) / (ncols * nl)
+ v <- array(v, c(rows, ncols, nl))
+
+ nc <- ncdf4::nc_open(x at file@name, write=TRUE)
+ on.exit( ncdf4::nc_close(nc) )
+ try ( ncdf4::ncvar_put(nc, x at 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)
+
+
diff --git a/R/newPLot.R b/R/newPLot.R
new file mode 100644
index 0000000..7cd11f2
--- /dev/null
+++ b/R/newPLot.R
@@ -0,0 +1,171 @@
+# 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 at extent@ymax + x at 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)
+
+
+
+
\ No newline at end of file
diff --git a/R/nlayers.R b/R/nlayers.R
new file mode 100644
index 0000000..d952c06
--- /dev/null
+++ b/R/nlayers.R
@@ -0,0 +1,45 @@
+# 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 at layers, nlayers) ) ) )
+ }
+)
+
+setMethod('nlayers', signature(x='RasterBrick'),
+ function(x){
+ return(x at data@nlayers)
+ }
+)
+
+setMethod('nlayers', signature(x='Spatial'),
+ function(x){
+ if (! is.null( attr(x, 'data') ) ) {
+ return( dim(x at data)[2] )
+ } else {
+ return( 0 )
+ }
+ }
+)
+
diff --git a/R/notused.R b/R/notused.R
new file mode 100644
index 0000000..9f3c97a
--- /dev/null
+++ b/R/notused.R
@@ -0,0 +1,45 @@
+# 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 at file@driver <- 'raster'
+ if (!overwrite & file.exists(filename)) {
+ stop(filename, "exists. Use 'overwrite=TRUE' if you want to overwrite it")
+ }
+
+ raster at data@values[is.nan(raster at data@values)] <- NA
+
+ dtype <- .shortDataType(raster at data@datanotation)
+ if (dtype == "integer") {
+ raster at data@values <- as.integer(raster at data@values)
+ }
+ if (class(raster at data@values)=='integer') {
+ dataType(raster) <- 'INT4S'
+ }
+ raster <- setMinMax(raster)
+
+ binraster <- .setFileExtensionValues(raster at file@name, 'raster')
+
+ raster <- readStart(raster)
+ writeBin( as.vector(raster at data@indices), raster at file@con, size = as.integer(4))
+ writeBin( as.vector(raster at data@values), raster at file@con, size = dataSize(raster at file@datanotation) )
+ raster <- readStop(raster)
+
+ # add the 'sparse' key word to the hdr file!!!
+ hdr(raster)
+ return(raster)
+}
+
diff --git a/R/nsidcICE.R b/R/nsidcICE.R
new file mode 100644
index 0000000..af09115
--- /dev/null
+++ b/R/nsidcICE.R
@@ -0,0 +1,57 @@
+.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 = "GMT")
+ ## 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")
+
+}
diff --git a/R/origin.R b/R/origin.R
new file mode 100644
index 0000000..0a82b6a
--- /dev/null
+++ b/R/origin.R
@@ -0,0 +1,62 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("origin")) {
+ setGeneric("origin", function(x, ...)
+ standardGeneric("origin"))
+}
+
+
+setMethod('origin', signature(x='BasicRaster'),
+function(x, ...) {
+ e <- x at extent
+ r <- res(x)
+ x <- e at xmin - r[1]*(round(e at xmin / r[1]))
+ y <- e at ymax - r[2]*(round(e at 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))
+}
+)
+
+
+if (!isGeneric("origin<-")) {
+ setGeneric("origin<-", function(x, value)
+ standardGeneric("origin<-"))
+}
+
+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 at xmin <- e at xmin + dif[1]
+ e at xmax <- e at xmax + dif[1]
+ e at ymin <- e at ymin + dif[2]
+ e at ymax <- e at ymax + dif[2]
+ x at extent <- e
+ return(x)
+ }
+)
+
diff --git a/R/overlay.R b/R/overlay.R
new file mode 100644
index 0000000..09150b5
--- /dev/null
+++ b/R/overlay.R
@@ -0,0 +1,209 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+# version 1, April 2012
+
+
+if (!isGeneric('overlay')) {
+ setGeneric('overlay', function(x, y, ...)
+ standardGeneric('overlay'))
+}
+
+
+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 (class(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 (class(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 (class(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)
+}
+
diff --git a/R/pairs.R b/R/pairs.R
new file mode 100644
index 0000000..dc71814
--- /dev/null
+++ b/R/pairs.R
@@ -0,0 +1,46 @@
+
+ if (!isGeneric("pairs")) {
+ setGeneric("pairs", function(x, ...)
+ standardGeneric("pairs"))
+}
+
+
+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)
+ 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)
+ }
+)
+
diff --git a/R/persp.R b/R/persp.R
new file mode 100644
index 0000000..a414645
--- /dev/null
+++ b/R/persp.R
@@ -0,0 +1,29 @@
+# Author: Robert J. Hijmans
+# Date : April 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("persp")) {
+ setGeneric("persp", function(x,...)
+ standardGeneric("persp"))
+}
+
+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, ...)
+ }
+)
+
diff --git a/R/plot.R b/R/plot.R
new file mode 100644
index 0000000..cec838b
--- /dev/null
+++ b/R/plot.R
@@ -0,0 +1,154 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("plot")) {
+ setGeneric("plot", function(x,y,...)
+ standardGeneric("plot"))
+}
+
+
+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 at 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 at 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 at 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, ...)
+}
+)
diff --git a/R/plot2rasters.R b/R/plot2rasters.R
new file mode 100644
index 0000000..b4e2cc5
--- /dev/null
+++ b/R/plot2rasters.R
@@ -0,0 +1,174 @@
+# 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, ...)
+}
+
+
diff --git a/R/plotCT.R b/R/plotCT.R
new file mode 100644
index 0000000..ef7743d
--- /dev/null
+++ b/R/plotCT.R
@@ -0,0 +1,92 @@
+# 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))
+ sethook <- TRUE
+ }
+ if (missing(asp)) {
+ if (couldBeLonLat(x)) {
+ ym <- mean(c(x at extent@ymax, x at 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[ z<zlim[1] ] <- zlim[1]
+ z[ z>zlim[2] ] <- zlim[2]
+ } else { #if (is.na(zlimcol)) {
+ z[z<zlim[1] | z>zlim[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(t(bbox(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(...) {
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+ on.exit(graphics::par(old.par))
+ }, action="replace")
+ setHook("plot.new", function(...) setHook("plot.new", NULL, "replace"))
+ }
+
+}
+
+
diff --git a/R/plotExent.R b/R/plotExent.R
new file mode 100644
index 0000000..7a6265a
--- /dev/null
+++ b/R/plotExent.R
@@ -0,0 +1,28 @@
+# 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 at xmin
+ xy[2:3,1] <- x at xmax
+ xy[1:2,2] <- x at ymax
+ xy[3:4,2] <- x at 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, ...)
+ }
+ }
+)
+
diff --git a/R/plotRGB.R b/R/plotRGB.R
new file mode 100644
index 0000000..8f768d1
--- /dev/null
+++ b/R/plotRGB.R
@@ -0,0 +1,131 @@
+# Author: Robert J. Hijmans
+# Date : April 2010
+# Version 0.9
+# Licence GPL v3
+
+# partly based on functions in the pixmap package by Friedrich Leisch
+
+if (!isGeneric("plotRGB")) {
+ setGeneric("plotRGB", function(x, ...)
+ standardGeneric("plotRGB"))
+}
+
+
+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, ...) {
+
+ if (missing(scale)) {
+ scale <- 255
+ if (! inherits(x, 'RasterStack')) {
+ if ( x at data@haveminmax ) {
+ scale <- max(max(x at data@max), 255)
+ }
+ }
+ }
+ scale <- as.vector(scale)[1]
+
+ r <- sampleRegular(raster(x,r), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE)
+ g <- sampleRegular(raster(x,g), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE)
+ b <- sampleRegular(raster(x,b), 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[ RGB<zlim[1] ] <- zlim[1]
+ RGB[ RGB>zlim[2] ] <- zlim[2]
+ } else { #if (is.na(zlimcol)) {
+ RGB[RGB<zlim[1] | RGB>zlim[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, max=255)
+ z <- rep( bg, times=ncell(r))
+ z[-naind] <- grDevices::rgb(RGB[,1], RGB[,2], RGB[,3], alpha=alpha, max=scale)
+ } else {
+ z <- grDevices::rgb(RGB[,1], RGB[,2], RGB[,3], alpha=alpha, max=scale)
+ }
+
+ z <- matrix(z, nrow=nrow(r), ncol=ncol(r), byrow=T)
+
+ requireNamespace("grDevices")
+ bb <- as.vector(t(bbox(r)))
+
+
+ if (!add) {
+ if (!axes) graphics::par(plt=c(0,1,0,1))
+
+ if (is.null(asp)) {
+ if (couldBeLonLat(x)) {
+ ym <- mean(c(x at extent@ymax, x at 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()
+ }
+ }
+}
+)
+
diff --git a/R/plotRaster.R b/R/plotRaster.R
new file mode 100644
index 0000000..0171897
--- /dev/null
+++ b/R/plotRaster.R
@@ -0,0 +1,82 @@
+# 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 at extent@ymax + object at 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 at xmax) e at xmin <- xlim[1]
+ if (xlim[2] > e at xmin) e at xmax <- xlim[2]
+ }
+ if (!missing(ylim)) {
+ if (ylim[1] >= ylim[2]) stop('invalid ylim')
+ if (ylim[1] < e at ymax) e at ymin <- ylim[1]
+ if (ylim[2] > e at ymin) e at ymax <- ylim[2]
+ }
+ }
+
+ leg <- object at 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 at color) > 0) {
+ breaks <- leg at values
+ object <- cut(object, breaks)
+ col <- leg at color
+ lab.breaks <- as.character(breaks)
+ }
+
+ z <- t(as.matrix(object)[object at nrows:1,])
+ if (nrow(z) == 1 | ncol(z) == 1) z <- t(z)
+ z[is.infinite(z)] <- NA
+
+ if (length(leg at 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()
+ }
+ }
+
+}
+
+
diff --git a/R/plotRaster2.R b/R/plotRaster2.R
new file mode 100644
index 0000000..b04fc39
--- /dev/null
+++ b/R/plotRaster2.R
@@ -0,0 +1,55 @@
+# 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 at xmax) ext at xmin <- xlim[1]
+ if (xlim[2] > ext at xmin) ext at xmax <- xlim[2]
+ }
+ if (!missing(ylim)) {
+ if (ylim[1] >= ylim[2]) stop('invalid ylim')
+ if (ylim[1] < ext at ymax) ext at ymin <- ylim[1]
+ if (ylim[2] > ext at ymin) ext at ymax <- ylim[2]
+ }
+# leg <- object at 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()
+ }
+ }
+
+}
+
+
diff --git a/R/pointdistance.R b/R/pointdistance.R
new file mode 100644
index 0000000..f179604
--- /dev/null
+++ b/R/pointdistance.R
@@ -0,0 +1,148 @@
+# Author: Robert J. Hijmans and Jacob van Etten
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+.pointsToMatrix <- function(p) {
+ if (inherits(p, 'SpatialPoints')) {
+ p <- 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
+ }
+}
+
+
+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, CSIRO Laboratories
+# 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("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) )
+}
+
diff --git a/R/predict.R b/R/predict.R
new file mode 100644
index 0000000..a11aeaf
--- /dev/null
+++ b/R/predict.R
@@ -0,0 +1,238 @@
+# Author: Robert J. Hijmans
+# Date : August 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("predict")) {
+ setGeneric("predict", function(object, ...)
+ standardGeneric("predict"))
+}
+
+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 (inherits(model, "randomForest")) {
+ f <- names(which(sapply(model$forest$xlevels, max) != "0"))
+ if (length(f) > 0) {
+ haveFactor <- TRUE
+ factlevels <- list()
+ for (i in 1:length(f)) {
+ factlevels[[i]] <- model$forest$xlevels[[ f[i] ]]
+ }
+ }
+ } else {
+ dataclasses <- try (attr(model$terms, "dataClasses")[-1], silent=TRUE)
+ if (class(dataclasses) != "try-error") {
+ varnames <- names(dataclasses)
+ if ( length( unique(lyrnames[(lyrnames %in% varnames)] )) != length(lyrnames[(lyrnames %in% varnames)] )) {
+ stop('duplicate names in Raster* object: ', lyrnames)
+ }
+ f <- names( which(dataclasses == 'factor') )
+ f <- f[f %in% names(object)]
+ if (length(f) > 0) {
+ haveFactor <- TRUE
+ factlevels <- list()
+ for (i in 1:length(f)) {
+ factlevels[[i]] <- levels( model$data[f][,1] )
+ }
+ }
+ } else if (!is.null(factors)) {
+ haveFactor <- TRUE
+ factlevels <- list()
+ for (i in 1:length(f)) {
+ f <- names(factors)
+ factlevels <- factors
+ }
+ }
+ }
+
+ 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' )
+
+ factorwarned <- FALSE
+ 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 (haveFactor) {
+ for (j in 1:length(f)) {
+ fl <- NULL
+ try(fl <- factlevels[[j]], silent=TRUE)
+ fv <- blockvals[,f[j]]
+ if (!is.null(fl)) {
+ fv[! fv %in% factlevels[[j]] ] <- NA
+ blockvals[,f[j]] <- factor(fv, levels=fl)
+ } else {
+ blockvals[,f[j]] <- factor(fv)
+ if (!factorwarned) {
+ warning('not sure if the correct factor levels are used here')
+ factorwarned <- TRUE
+ }
+ }
+ }
+ }
+
+ if (! is.null(const)) {
+ blockvals <- cbind(blockvals, const)
+ }
+
+ 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) {
+ w <- getOption('warn')
+ options('warn'=-1)
+ tst <- as.integer(as.character(levels(predv)))
+ options('warn'= w)
+ if (any(is.na(tst))) {
+ factaschar = FALSE
+ } else {
+ factaschar = TRUE
+ }
+ levs <- levels(predv)
+ predrast at data@attributes <- list(data.frame(ID=1:length(levs), value=levs))
+ predrast at 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)
+ }
+)
+
+
diff --git a/R/print.R b/R/print.R
new file mode 100644
index 0000000..7ac4cfd
--- /dev/null
+++ b/R/print.R
@@ -0,0 +1,146 @@
+# 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 at file@driver == 'netcdf') {
+ nc <- ncdf4::nc_open(x at file@name)
+ print(nc)
+ ncdf4::nc_close(nc)
+ } else if (any(is.factor(x))) {
+ cat('factor levels (value attributes)\n')
+ f <- x at 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 at data@levels, collapse=', '), '\n')
+ # cat('labels :' , paste(object at 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')) {
+ hasData <- TRUE
+ nc <- ncol(x at data)
+ }
+ ln <- 1
+ if (inherits(x, 'SpatialPixels')) {
+ isRaster <- TRUE
+ cr <- x at grid@cells.dim
+ cat ('dimensions : ', cr[2], ', ', cr[1], ', ', nrow(x at coords), ', ', nc, ' (nrow, ncol, npixels, nlayers)\n', sep="" )
+ cs <- x at grid@cellsize
+ cat ('resolution : ', cs[1], ', ', cs[2], ' (x, y)\n', sep="")
+
+ } else if (inherits(x, 'SpatialGrid')) {
+ isRaster <- TRUE
+ cr <- x at grid@cells.dim
+ cat ('dimensions : ', cr[2], ', ', cr[1], ', ', prod(cr), ', ', nc, ' (nrow, ncol, ncell, nlayers)\n', sep="" )
+ cs <- x at grid@cellsize
+ cat ('resolution : ', cs[1], ', ', cs[2], ' (x, y)\n', sep="")
+
+ } else {
+ nf <- length(x)
+ cat('features :' , nf, '\n')
+ }
+
+ e <- 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('coord. ref. :' , projection(x, TRUE), '\n')
+
+ if (hasData) {
+ x <- x at data
+
+ maxnl <- 15
+
+ if (! isRaster) {
+ cat('variables : ', nc, '\n', sep="" )
+ }
+ 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)
+ 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 > 0) {
+ cat('min values :', paste(m[2,], collapse=', '), '\n')
+ cat('max values :', paste(m[3,], collapse=', '), '\n')
+ }
+
+ }
+}
+
diff --git a/R/progressBar.R b/R/progressBar.R
new file mode 100644
index 0000000..854190e
--- /dev/null
+++ b/R/progressBar.R
@@ -0,0 +1,67 @@
+# 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')
+ }
+}
+
+
diff --git a/R/project.R b/R/project.R
new file mode 100644
index 0000000..0c4d95a
--- /dev/null
+++ b/R/project.R
@@ -0,0 +1,59 @@
+# Author: Robert J. Hijmans
+# Date : June 2014
+# Version 1.0
+# Licence GPL v3
+
+
+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
+ }
+ spTransform(x, CRSobj=crs(crs), ...)
+ }
+)
+
+
diff --git a/R/projectRaster.R b/R/projectRaster.R
new file mode 100644
index 0000000..f55b480
--- /dev/null
+++ b/R/projectRaster.R
@@ -0,0 +1,374 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 1.0
+# Licence GPL v3
+
+
+projectExtent <- function(object, crs) {
+ .requireRgdal()
+
+ 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
+
+ methods::validObject(projection(object, asText=FALSE))
+ methods::validObject(projection(crs, asText=FALSE))
+ projfrom <- projection(object)
+ projto <- projection(crs)
+
+
+
+# rs <- res(object)
+# xmn <- object at extent@xmin - 0.5 * rs[1]
+# xmx <- object at extent@xmax + 0.5 * rs[1]
+# ymn <- object at extent@ymin - 0.5 * rs[2]
+# ymx <- object at 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) {
+
+ 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)
+
+ }
+
+ 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(raster, crs) {
+
+ x <- xmin(raster) + 0.5 * (xmax(raster) - xmin(raster))
+ y <- ymin(raster) + 0.5 * (ymax(raster) - ymin(raster))
+ res <- res(raster)
+ 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))
+ pXY <- rgdal::rawTransform( projection(raster), 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]))
+ if (any(is.na(res))) {
+ if (isLonLat(raster)) {
+ 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=projection(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()
+
+
+ methods::validObject( projection(from, asText=FALSE) )
+ projfrom <- projection(from)
+ if (is.na(projfrom)) {
+ stop("input projection is NA")
+ }
+ lonlat <- isLonLat(projfrom)
+
+ if (missing(to)) {
+ if (missing(crs)) {
+ stop("'crs' argument is missing.")
+ }
+ projto <- projection(crs)
+ to <- projectExtent(from, projto)
+ if (missing(res)) {
+ res <- .computeRes(from, projto)
+ }
+ res(to) <- res
+ projection(to) <- crs
+
+ # add some cells to capture curvature
+ e <- extent(to)
+ add <- min(5, min(dim(to)[1:2])/10) * max(res)
+ e at ymin <- e at ymin - add
+ e at ymax <- e at ymax + add
+ e at xmin <- e at xmin - add
+ e at xmax <- e at xmax + add
+ if (!is.character(projto)) projto <- projto at projargs
+ if (substr(projto, 1, 13) == "+proj=longlat") {
+ e at xmin <- max(-180, e at xmin)
+ e at xmax <- min(180, e at xmax)
+ e at ymin <- max(-90, e at ymin)
+ e at ymax <- min(90, e at ymax)
+ }
+ to <- extend(to, e)
+ } else {
+ projto <- projection(to)
+ if (is.na(projto)) {
+ stop("output projection is NA")
+ }
+
+ e <- extent( projectExtent(from, projto) )
+ add <- min(10, min(dim(to)[1:2])/10) * max(raster::res(to))
+ e at ymin <- e at ymin - add
+ e at ymax <- e at ymax + add
+ e at xmin <- e at xmin - add
+ e at xmax <- e at xmax + add
+ if (!is.character(projto)) projto <- projto at projargs
+ if (substr(projto, 1, 13) == "+proj=longlat") {
+ e at xmin <- max(-180, e at xmin)
+ e at xmax <- min(180, e at xmax)
+ e at ymin <- max(-90, e at ymin)
+ e at ymax <- min(90, e at ymax)
+ }
+ }
+
+ methods::validObject(to)
+ methods::validObject(projection(to, asText=FALSE))
+
+ #if (identical(projfrom, projto)) {
+ # warning('projections of "from" and "to" are the same')
+ #}
+ if (lonlat & over) {
+ projto_int <- paste(projto, "+over")
+ } else {
+ projto_int <- projto
+ }
+
+ if (alignOnly) {
+ to <- .getAlignedRaster(to, from)
+ }
+
+# pbb <- projectExtent(to, projection(from))
+# bb <- intersect(extent(pbb), extent(from))
+# methods::validObject(bb)
+
+ if (!method %in% c('bilinear', 'ngb')) {
+ stop('invalid method')
+ }
+ if (method=='ngb') {
+ method <- 'simple' # for extract (.xyValues)
+ }
+
+ nl <- nlayers(from)
+ if ( nl == 1) {
+ to <- raster(to)
+ } else {
+ to <- brick(to, values=FALSE, nl=nl)
+ }
+ 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 at 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 at xmin & xy[,1] < e at xmax)
+ v <- matrix(nrow=length(cells), ncol=nl)
+ if (nrow(xy) > 0) {
+ ci <- match(cellFromXY(to, xy), cells)
+ 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 * .chunksize() / nlayers(to))
+
+
+ if (inMemory) {
+
+ xy <- coordinates(to)
+ xy <- subset(xy, xy[,1] > e at xmin & xy[,1] < e at xmax)
+ cells <- cellFromXY(to, xy)
+ 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 at xmin & xy[,1] < e at xmax)
+ if (nrow(xy) > 0) {
+ ci <- match(cellFromXY(to, xy), cells)
+ 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)
+ }
+ }
+}
+
diff --git a/R/projection.R b/R/projection.R
new file mode 100644
index 0000000..87c79f6
--- /dev/null
+++ b/R/projection.R
@@ -0,0 +1,109 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+
+if (!isGeneric("crs")) {
+ setGeneric("crs", function(x, ...)
+ standardGeneric("crs"))
+}
+
+setMethod("crs", signature('ANY'),
+ function(x, asText=FALSE, ...) {
+ projection(x, asText=asText)
+ }
+)
+
+
+'crs<-' <- function(x, value) {
+ projection(x) <- value
+ x
+}
+
+
+setMethod('is.na', signature(x='CRS'),
+ function(x) {
+ is.na(x at projargs)
+ }
+)
+
+
+setMethod('as.character', signature(x='CRS'),
+ function(x, ...) {
+ x at projargs
+ }
+)
+
+'projection<-' <- function(x, value) {
+
+ if (class(value)=="CRS") {
+ crs <- value
+ } else {
+ crs <- .newCRS(value)
+ }
+
+ if (inherits(x, 'RasterStack')) {
+ if (nlayers(x) > 0) {
+ for (i in 1:nlayers(x)) {
+ x at layers[[i]]@crs <- crs
+ }
+ }
+ }
+
+ if (inherits(x, 'Spatial')) {
+ x at proj4string <- crs
+ } else {
+ x at crs <- crs
+ }
+ return(x)
+
+}
+
+
+
+projection <- function(x, asText=TRUE) {
+
+ if (methods::extends(class(x), "BasicRaster")) {
+ x <- x at crs
+ } else if (methods::extends(class(x), "Spatial")) {
+ x <- x at proj4string
+ } else if (class(x) == 'character') {
+ if (asText) {
+ return(x)
+ } else {
+ return( CRS(x) )
+ }
+ } else if (class(x) != "CRS") {
+ return(as.logical(NA))
+ }
+
+ if (asText) {
+ if (is.na(x at projargs)) {
+ return(as.character(NA))
+ } else {
+ return(trim(x at projargs))
+ }
+ } else {
+ return(x)
+ }
+}
+
+
+setMethod("proj4string", signature('Raster'),
+# redundant, for compatibility with sp
+ function(obj) {
+ projection(obj)
+ }
+)
+
+
+setMethod("proj4string<-", signature('Raster'),
+# redundant, for compatibility with sp
+ function(obj, value) {
+ projection(obj) <- value
+ obj
+ }
+)
+
diff --git a/R/properties.R b/R/properties.R
new file mode 100644
index 0000000..94e8419
--- /dev/null
+++ b/R/properties.R
@@ -0,0 +1,61 @@
+# 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 at layers, function(x) x at file@driver)
+ if (any(d == '' & warn)) {
+ warning('There is no driver associated with one or more layers of this RasterStack')
+ }
+ } else {
+ d <- object at 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 at layers, function(x) x at file@nodatavalue) )
+ }
+ return(object at file@nodatavalue)
+}
+
+
+filename <- function(x) {
+ if (inherits(x, 'RasterStack')) {
+ return(x at filename)
+ }
+ return(x at file@name)
+}
+
+
+
+
+# fileext <- toupper(extension(fn))
+# if ( fileext == ".GRD" | fileext == ".GRI" ) {
+# return('raster')
+# } else {
+# return('gdal')
+# }
+
+# fcon <- class(try( object at 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')
+# }
+
+
+
diff --git a/R/quad.R b/R/quad.R
new file mode 100644
index 0000000..02c29f9
--- /dev/null
+++ b/R/quad.R
@@ -0,0 +1,43 @@
+
+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 at xmin > -400 & e at xmax < 400 & e at ymin > -90.1 & e at ymax < 90.1) {
+ crs ="+proj=longlat +datum=WGS84"
+ } else {
+ crs=NA
+ }
+ }
+ 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) <- crs
+ levels <- as.integer(max(round(levels), 0))
+ steps <- as.integer(max(round(steps), 0))
+ nl <- levels * steps
+ b at nlevels <- levels
+ b at nsteps <- steps
+ b at data@nlayers <- as.integer(nl)
+ return(b)
+ }
+)
+
diff --git a/R/quantile.R b/R/quantile.R
new file mode 100644
index 0000000..589b161
--- /dev/null
+++ b/R/quantile.R
@@ -0,0 +1,39 @@
+# Author: Robert J. Hijmans
+# r.hijmans at 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 (class(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 (class(v) == 'try-error') {
+ stop('ncells too large')
+ }
+ }
+ if (na.rm) {
+ v <- stats::na.omit(v)
+ }
+ if (nlayers(x)==1) {
+ return(quantile(v, ...))
+ } else {
+ q <- stats::quantile(v[,1], ...)
+ for (i in 2:nlayers(x)) {
+ q <- rbind(q, stats::quantile(v[,i], ...))
+ }
+ rownames(q) <- names(x)
+ return(q)
+ }
+ }
+)
+
diff --git a/R/randomize.R b/R/randomize.R
new file mode 100644
index 0000000..f4144bc
--- /dev/null
+++ b/R/randomize.R
@@ -0,0 +1,18 @@
+
+
+.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)))
+ }
+}
+
diff --git a/R/range.R b/R/range.R
new file mode 100644
index 0000000..42faada
--- /dev/null
+++ b/R/range.R
@@ -0,0 +1,74 @@
+# 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
+}
+
+
+
diff --git a/R/raster.R b/R/raster.R
new file mode 100644
index 0000000..c4a4855
--- /dev/null
+++ b/R/raster.R
@@ -0,0 +1,482 @@
+# Author: Robert J. Hijmans
+# Date : September 2008
+# Version 1.0
+# Licence GPL v3
+
+
+
+if ( !isGeneric("raster") ) {
+ setGeneric("raster", function(x, ...)
+ standardGeneric("raster"))
+}
+
+
+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 at xmin > -360.01 & ext at xmax < 360.01 & ext at ymin > -90.01 & ext at ymax < 90.01) {
+ crs <- CRS("+proj=longlat +datum=WGS84")
+ } else {
+ # if sp >= 1.2.1 crs <- CRS(as.character(NA), doCheckCRSArgs=FALSE)
+ crs <- CRS(as.character(NA))
+ }
+ } else {
+ crs <- CRS(as.character(projection(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=crs)
+ } else {
+ r <- methods::new('RasterLayer', extent=ext, crs=crs)
+ 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 <- "+proj=longlat +datum=WGS84"
+ } else {
+ crs <- as.character(NA)
+ }
+ }
+
+ 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=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 <- 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 at file@driver <- 'big.matrix'
+# if (is.filebacked(x)) {
+# r at file@name <- bigmemory:::file.name(x)
+# }
+ r at data@fromdisk <- TRUE
+ r at data@inmemory <- FALSE
+ attr(r at 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 at extent, nrows=x at nrows, ncols=x at ncols, crs=x at crs)
+ if (rotated(x)) {
+ r at rotated <- TRUE
+ r at rotation <- x at rotation
+ }
+ return(r)
+ }
+)
+
+setMethod('raster', signature(x='RasterLayer'),
+ function(x) {
+ r <- raster(x at extent, nrows=x at nrows, ncols=x at ncols, crs=x at crs)
+ r at rotated <- x at rotated
+ r at rotation <- x at rotation
+ r at file@blockrows <- x at file@blockrows
+ r at file@blockcols <- x at file@blockcols
+ return(r)
+ }
+)
+
+setMethod('raster', signature(x='RasterLayerSparse'),
+ function(x) {
+ r <- raster(x at extent, nrows=x at nrows, ncols=x at ncols, crs=x at crs)
+ if (length(stats::na.omit(x at data@values)) > 0) {
+ v <- rep(NA, ncell(r))
+ v[x at index] <- x at data@values
+ setValues(r, v)
+ } else {
+ 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 at layers[[dindex]]
+ names(r) <- names(x)[dindex]
+ } else {
+ r <- raster(extent(x))
+ dim(r) <- c(nrow(x), ncol(x))
+ projection(r) <- projection(x)
+ }
+ extent(r) <- extent(x) # perhaps it was changed by user and different on disk
+ if (rotated(x at layers[[1]])) {
+ r at rotated <- TRUE
+ r at rotation <- x at 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=projection(x))
+ r at file <- x at file
+
+ r at file@blockrows <- x at file@blockrows
+ r at file@blockcols <- x at file@blockcols
+
+ r at data@offset <- x at data@offset
+ r at data@gain <- x at data@gain
+ r at data@inmemory <- FALSE
+ r at data@fromdisk <- TRUE
+ r at data@haveminmax <- x at data@haveminmax
+
+ r at data@band <- dindex
+ r at data@min <- x at data@min[dindex]
+ r at data@max <- x at data@max[dindex]
+ ln <- x at data@names[dindex]
+ if (! is.na(ln) ) {
+ r at data@names <- ln
+ }
+ #zv <- unlist(x at z[1])[dindex]
+ zv <- NULL
+ try( zv <- x at z[[1]][dindex], silent=TRUE )
+ if (! is.null(zv) ) {
+ r at z <- list(zv)
+ }
+
+ # ncdf files
+ zvar <- try(methods::slot(x at data, 'zvar'), silent=TRUE)
+ if (class(zvar) != 'try-error') {
+ attr(r at data, "zvar") <- zvar
+ attr(r at data, "dim3") <- x at data@dim3
+ attr(r at data, "level") <- x at data@level
+ }
+
+ r at data@offset <- x at data@offset
+ r at data@gain <- x at data@gain
+ r at file@nodatavalue <- x at file@nodatavalue
+
+ } else {
+
+ r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=projection(x))
+ if ( inMemory(x) ) {
+ if ( dindex != layer ) { warning(paste("layer was changed to", dindex)) }
+ r <- setValues(r, x at data@values[,dindex])
+ r at data@names <- names(x)[dindex]
+ }
+ }
+ isf <- is.factor(x)[dindex]
+ if (isTRUE(isf)) {
+ r at data@isfactor <- TRUE
+ r at data@attributes <- levels(x)[dindex]
+ }
+
+ } else {
+ r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=projection(x))
+ }
+
+ if (rotated(x)) {
+ r at rotated <- TRUE
+ r at rotation <- x at rotation
+ }
+
+ return(r)
+ }
+)
+
+
+setMethod('raster', signature(x='Extent'),
+ function(x, nrows=10, ncols=10, crs=NA, ...) {
+ raster(xmn=x at xmin, xmx=x at xmax, ymn=x at ymin, ymx=x at ymax, ncols=ncols, nrows=nrows, crs=crs, ...)
+ }
+)
+
+
+setMethod('raster', signature(x='Spatial'),
+ function(x, origin, ...){
+ r <- raster(extent(x), ...)
+ r at crs <- x at proj4string
+ 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) <- x at proj4string
+ dim(r) <- c(x at grid@cells.dim[2], x at grid@cells.dim[1])
+ if (layer < 1) {
+ values <- FALSE
+ }
+
+ if (inherits(x, 'SpatialGridDataFrame') & values) {
+ if (dim(x at data)[2] > 0) {
+ layer = layer[1]
+ if (is.numeric(layer)) {
+ dindex <- max(1, min(dim(x at data)[2], layer))
+ if (dindex != layer) {
+ warning(paste("layer was changed to: ", dindex))
+ }
+ layer <- dindex
+ names(r) <- colnames(x at data)[layer]
+ } else if (!(layer %in% names(x))) {
+ stop(layer, ' is not a valid name')
+ } else {
+ names(r) <- layer
+ }
+
+ if (is.character( x at data[[layer]]) ) {
+ x at data[[layer]] <- as.factor(x at data[[layer]])
+ }
+ if (is.factor( x at data[[layer]]) ) {
+ r at data@isfactor <- TRUE
+ levs <- levels(x at data[[layer]])
+ r at data@attributes <- list(data.frame(ID=1:length(levs), levels=levs))
+ r <- setValues(r, as.integer(x at data[[layer]]))
+ } else {
+ r <- setValues(r, x at 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 at extent
+ if (e at xmin > -360.1 & e at xmax < 360.1 & e at ymin > -90.1 & e at ymax < 90.1) {
+ 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 at extent
+ if (e at xmin > -360.1 & e at xmax < 360.1 & e at ymin > -90.1 & e at ymax < 90.1) {
+ crs <- "+proj=longlat +datum=WGS84"
+ } else {
+ 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 at extent
+ if (e at xmin > -360.1 & e at xmax < 360.1 & e at ymin > -90.1 & e at ymax < 90.1) {
+ crs <- "+proj=longlat +datum=WGS84"
+ } else {
+ 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 at cells.dim[2], ncols=x at cells.dim[1])
+ }
+)
+
diff --git a/R/rasterFromASCII.R b/R/rasterFromASCII.R
new file mode 100644
index 0000000..7a8e9af
--- /dev/null
+++ b/R/rasterFromASCII.R
@@ -0,0 +1,124 @@
+# Author: Robert J. Hijmans
+# Date : October 2009
+# Version 0.9
+# Licence GPL v3
+
+
+.rasterFromASCIIFile <- function(filename, offset=6, crs=NA, ...) {
+
+ 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])
+
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+ test <- sum(as.numeric(ini[,1]), na.rm=TRUE) > 0
+ options('warn' = w)
+ 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 <- xn - 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 at data@fromdisk <- TRUE
+ x at file@offset <- offset
+ x at file@driver <- 'ascii'
+ x at file@nodatavalue <- nodataval
+ x at file@name <- filename
+
+
+ if (!is.na(crs)) {
+ projection(x) <- crs
+ }
+
+ return(x)
+}
+
+
diff --git a/R/rasterFromBIL.R b/R/rasterFromBIL.R
new file mode 100644
index 0000000..cfbb497
--- /dev/null
+++ b/R/rasterFromBIL.R
@@ -0,0 +1,197 @@
+# Author: Robert J. Hijmans
+# Date : October 2009
+# Version 0.9
+# Licence GPL v3
+
+
+.rasterFromGenericFile <- function(filename, band=1, SIGNEDINT=NULL, type='RasterLayer', crs=NA, ...) {
+ 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 at data@nlayers <- as.integer(nbands)
+ x at data@min <- minval
+ x at data@max <- maxval
+ } else {
+ x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs)
+ x at data@band <- as.integer(band)
+ x at data@min <- minval[band]
+ x at data@max <- maxval[band]
+ }
+ if (x at data@min[1] != Inf) {x at data@haveminmax <- TRUE
+ } else { x at data@haveminmax <- FALSE }
+
+
+ x at file@nbands <- as.integer(nbands)
+
+ if (bandorder %in% c("BSQ", "BIP", "BIL")) {
+ x at 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 at 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 at file@byteorder <- 'little'
+ } else if (byteorder == "M") {
+ x at file@byteorder <- 'big'
+ } else {
+ x at file@byteorder <- .Platform$endian
+ }
+
+ x at data@fromdisk <- TRUE
+
+ x at file@driver <- bandorder
+ x at file@nodatavalue <- nodataval
+
+ return(x)
+}
+
diff --git a/R/rasterFromCells.R b/R/rasterFromCells.R
new file mode 100644
index 0000000..afd8ccd
--- /dev/null
+++ b/R/rasterFromCells.R
@@ -0,0 +1,28 @@
+# Author: Robert J. Hijmans
+# Date : April 2009
+# Version 0.9
+# Licence GPL v3
+
+
+rasterFromCells <- function(x, cells, values=TRUE) {
+ x <- raster(x)
+ u <- unique(cells)
+ 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)
+}
+
diff --git a/R/rasterFromFile.R b/R/rasterFromFile.R
new file mode 100644
index 0000000..7c203a4
--- /dev/null
+++ b/R/rasterFromFile.R
@@ -0,0 +1,129 @@
+# 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, 4))
+ if (! start %in% c('http', '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 at file@toptobottom | r at 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 (class(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)
+ }
+}
+
diff --git a/R/rasterFromGDAL.R b/R/rasterFromGDAL.R
new file mode 100644
index 0000000..62117ba
--- /dev/null
+++ b/R/rasterFromGDAL.R
@@ -0,0 +1,308 @@
+# 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=NA, ...) {
+
+ .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=''))
+ }
+ }
+
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+ gdalinfo <- try ( rgdal::GDALinfo(filename, silent=silent, returnRAT=RAT, returnCategoryNames=RAT) )
+ options('warn'= w)
+
+ if (class(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"]])
+
+ 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 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 at geotrans <- gtr
+ rot at 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 (class(bnames)=='try-error') {
+ bnames <- NULL
+ }
+ } else {
+ bnames <- NULL
+ }
+
+
+ if (type == 'RasterBrick') {
+
+ r <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs="")
+ r at file@nbands <- r at 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 at 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 at data@band <- as.integer(band)
+ nbands <-1
+ }
+ if (rotated) {
+ r at rotated <- TRUE
+ r at rotation <- rot
+ }
+
+ projection(r) <- .getProj(attr(gdalinfo, 'projection'), crs)
+
+# r at 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 at 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 at file@blockrows <- blockrows
+ r at 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') {
+ if (length(bnames) == nlayers(r)) {
+ names(r) <- bnames
+ } else {
+ names(r) <- rep(gsub(" ", "_", extension(basename(filename), "")), nbands)
+ }
+ } else {
+ lnames <- gsub(" ", "_", extension(basename(filename), ""))
+ if (nbands > 1) {
+ lnames <- paste(lnames, '_', band, sep='')
+ }
+ names(r) <- lnames
+
+ }
+ r at file@name <- filename
+ r at file@driver <- 'gdal'
+
+
+ r at 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 ( is.finite(minv) && is.finite(maxv) ) {
+ r at data@haveminmax <- TRUE
+ }
+ r at file@datanotation <- datatype
+
+ r at data@min <- minv[band]
+ r at 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 at 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 at data@attributes <- att[band]
+ r at 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 at data@attributes <- att[band]
+ r at data@isfactor <- cats[band]
+ }
+ }
+ return(r)
+}
+
+
diff --git a/R/rasterFromIDRISI.R b/R/rasterFromIDRISI.R
new file mode 100644
index 0000000..84f6348
--- /dev/null
+++ b/R/rasterFromIDRISI.R
@@ -0,0 +1,89 @@
+# Author: Robert J. Hijmans
+# Date : October 2009
+# Version 0.9
+# Licence GPL v3
+
+.rasterFromIDRISIFile <- function(filename, crs=NA, 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") {
+ w <- getOption('warn')
+ options('warn'=-1)
+ nodataval <- try(as.numeric(ini[i,3], silent=TRUE))
+ if (!is.numeric(nodataval)) {nodataval <- -Inf}
+ options('warn'= w)
+ }
+ }
+
+ 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 at file@name <- filename
+ x at data@min <- minval
+ x at data@max <- maxval
+ x at 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 at file@nodatavalue <- nodataval
+ x at data@fromdisk <- TRUE
+
+ x at file@driver <- idformat
+ return(x)
+}
+
+
+
diff --git a/R/rasterFromRasterFile.R b/R/rasterFromRasterFile.R
new file mode 100644
index 0000000..f911f33
--- /dev/null
+++ b/R/rasterFromRasterFile.R
@@ -0,0 +1,285 @@
+# 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 at data@isfactor <- TRUE
+ x at data@attributes <- list(rat)
+ x
+
+}
+
+
+.getProj <- function(proj, crs) {
+ if ( ! is.na(crs) ) {
+ if (is.na(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=NA, ...) {
+
+ 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)
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+
+ #match(c("MINX", "MAXX", "MINY", "MAXY", "XMIN", "XMAX", "YMIN", "YMAX", "ROWS", "COLUMNS", "NROWS", "NCOLS"), toupper(ini[,2]))
+
+ 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") {
+ options('warn'=-1)
+ try ( minval <- as.numeric(unlist(strsplit(ini[i,3], ':'), use.names=FALSE)), silent = TRUE )
+ options('warn' = w)
+ } else if (ini[i,2] == "MAXVALUE") {
+ options('warn'=-1)
+ try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE )
+ options('warn' = w)
+ } 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)
+ } 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 at data@nlayers <- as.integer(nbands)
+ x at data@min <- minval
+ x at data@max <- maxval
+ } else {
+ x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=prj)
+ x at data@band <- as.integer(band)
+ x at data@min <- minval[band]
+ x at 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 at file@nbands <- as.integer(nbands)
+
+ if (bandorder %in% c("BSQ", "BIP", "BIL")) {
+ x at 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 at z <- zvalues
+ }
+
+ if (type == 'RasterBrick') {
+ names(x) <- lnames
+ } else {
+ names(x) <- lnames[band]
+ }
+
+ dataType(x) <- inidatatype
+
+ x at data@haveminmax <- TRUE # should check?
+ x at file@nodatavalue <- nodataval
+
+ if ((byteorder == "little") | (byteorder == "big")) {
+ x at file@byteorder <- byteorder
+ }
+ x at data@fromdisk <- TRUE
+ x at file@driver <- driver
+
+# if( dataSize(x) * (ncell(x) * nbands(x) + x at file@offset) != file.info(valuesfile)$size ) {
+
+# if (driver == 'big.matrix') {
+# requireNamespace("bigmemory")
+# x at file@name <- valuesfile
+# dscfile <- extension(valuesfile, 'big.dsc')
+# attr(x at file, 'big.matrix') <- attach.big.matrix(dscfile)
+
+# } else {
+ x at 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 at legend@colortable <- colortable
+ }
+
+ x at history <- metadata
+
+ return(x)
+}
+
+
diff --git a/R/rasterFromSAGA.R b/R/rasterFromSAGA.R
new file mode 100644
index 0000000..36b36fb
--- /dev/null
+++ b/R/rasterFromSAGA.R
@@ -0,0 +1,98 @@
+# Author: Robert J. Hijmans
+# Date : October 2009
+# Version 0.9
+# Licence GPL v3
+
+
+.rasterFromSAGAFile <- function(filename, crs=NA, ...) {
+ 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 at file@offset <- dfoffset
+ x at file@toptobottom <- toptobottom
+
+ if (.nchar(layernames) > 1) {
+ lnams <- unlist(strsplit(layernames, ':'))
+ } else {
+ lnams <- gsub(" ", "_", extension(basename(filename), ""))
+ }
+ names(x) <- lnams
+
+ x at file@name <- filename
+ x at data@haveminmax <- FALSE
+ x at 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 at file@byteorder <- 'big'
+ } else {
+ x at file@byteorder <- 'little'
+ }
+ x at data@fromdisk <- TRUE
+ x at data@gain <- zfactor
+
+ x at file@driver <- 'SAGA'
+ return(x)
+}
+
+
diff --git a/R/rasterFromSurferFile.R b/R/rasterFromSurferFile.R
new file mode 100644
index 0000000..cda514a
--- /dev/null
+++ b/R/rasterFromSurferFile.R
@@ -0,0 +1,116 @@
+# 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 at ncols <- readBin(con, "int", n=1, size=2)
+ r at rows <- readBin(con, "int", n=1, size=2)
+ r at extent@xmin <- readBin(con, "double", n=1, size=8)
+ r at extent@xmax <- readBin(con, "double", n=1, size=8)
+ r at extent@ymin <- readBin(con, "double", n=1, size=8)
+ r at extent@ymax <- readBin(con, "double", n=1, size=8)
+ r at data@min <- readBin(con, "double", n=1, size=8)
+ r at data@max <- readBin(con, "double", n=1, size=8)
+ close(con)
+ r at file@offset <- 56
+ r at file@toptobottom <- FALSE
+ dataType(r) <- 'FLT4S'
+ r at data@fromdisk <- TRUE
+
+ r at 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 at rows <- as.integer(readBin(con, "numeric", n=1, size=4))
+ r at cols <- as.integer(readBin(con, "numeric", n=1, size=4))
+ r at extent@xmin <- readBin(con, "double", n=1, size=8)
+ r at 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 at extent@xmax <- r at extent@xmin + xr * r at cols
+ r at extent@ymax <- r at extent@ymin + yr * r at rows
+ r at data@min <- readBin(con, "double", n=1, size=8)
+ r at 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 at data@max <- readBin(con, "double", n=1, size=8)
+ r at 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 at file@offset <- offset + 8
+ r at 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 at file@driver <- "surfer"
+ return(r)
+}
+
+
diff --git a/R/rasterFromXYZ.R b/R/rasterFromXYZ.R
new file mode 100644
index 0000000..3d5e952
--- /dev/null
+++ b/R/rasterFromXYZ.R
@@ -0,0 +1,95 @@
+# Author: Robert J. Hijmans
+# Date : July 2010
+# Version 1.0
+# Licence GPL v3
+
+
+rasterFromXYZ <- function(xyz, res=c(NA, NA), crs=NA, digits=5) {
+
+ if (length(res) == 1) res = c(res, res)
+
+ if (inherits(xyz, 'SpatialPoints')) {
+ if (inherits(xyz, 'SpatialPointsDataFrame')) {
+ xyz <- cbind(coordinates(xyz), xyz at data[,1])
+ } else {
+ xyz <- coordinates(xyz)
+ }
+ }
+
+ ln <- colnames(xyz)
+
+ if (inherits(xyz, 'data.frame')) {
+ xyz <- as.matrix(xyz)
+ xyz <- matrix(as.numeric(xyz), ncol=ncol(xyz), nrow=nrow(xyz))
+ }
+ x <- sort(unique(xyz[,1]))
+ dx <- x[-1] - x[-length(x)]
+
+ if (is.na(res[1])) {
+ 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])) {
+ 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)
+}
+
+
diff --git a/R/rasterOptions.R b/R/rasterOptions.R
new file mode 100644
index 0000000..9e4a2b8
--- /dev/null
+++ b/R/rasterOptions.R
@@ -0,0 +1,609 @@
+# Author: Robert J. Hijmans
+# September 2009
+# Version 1.0
+# Licence GPL v3
+
+
+rasterOptions <- function(format, overwrite, datatype, tmpdir, tmptime, progress, timer, chunksize, maxmemory, 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^9)
+ options(rasterChunkSize = chunksize )
+ }
+
+ setFileExt <- function(setfileext) {
+ options(rasterSetFileExt = as.logical(setfileext) )
+ }
+
+ setMaxMemorySize <- function(maxmemory) {
+ maxmemory = max(10000, round(maxmemory[1]))
+ options(rasterMaxMemory = maxmemory )
+ }
+
+ 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 = 1000000)
+ options(rasterMaxMemory = 10000000)
+ 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(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(),
+ 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("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('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)
+}
+
+
+
+.chunksize <- function(){
+ default <- 1e+07
+ 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)
+}
+
+
+
+.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)
+}
+
+
+
+
+.maxmemory <- function() {
+ default <- 1e+08
+ d <- getOption('rasterMaxMemory')
+ if (is.null(d)) {
+ return( default )
+ }
+ d <- round(as.numeric(d[1]))
+ if (is.na(d) | d < 10000) {
+ d <- default
+ }
+ 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) {
+ if (missing(datatype)) {
+ datatype <- getOption('rasterDatatype')
+ if (is.null(datatype)) {
+ return('FLT8S')
+ }
+ }
+ if (! datatype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'INT4U', 'FLT4S', 'FLT8S')) {
+ warning(datatype, ' is an invalid datatype value, changed to "FLT8S"')
+ 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)
+}
+
diff --git a/R/rasterToPoints.R b/R/rasterToPoints.R
new file mode 100644
index 0000000..2abfebb
--- /dev/null
+++ b/R/rasterToPoints.R
@@ -0,0 +1,94 @@
+# 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) {
+ crs <- projection(x, asText=FALSE)
+ return(SpatialPoints(coords=xyFromCell(x, 1:ncell(x)), proj4string=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)], 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) {
+ v <- data.frame(xyv[ ,-c(1:2), drop=FALSE])
+ colnames(v) <- laynam
+ crs <- projection(x, asText=FALSE)
+ return( SpatialPointsDataFrame(coords=xyv[,1:2,drop=FALSE], data=v, proj4string=crs ) )
+
+ } else {
+ colnames(xyv)[3:ncol(xyv)] <- laynam
+ return(xyv)
+ }
+}
+
diff --git a/R/rasterToPolygons.R b/R/rasterToPolygons.R
new file mode 100644
index 0000000..b4cbe64
--- /dev/null
+++ b/R/rasterToPolygons.R
@@ -0,0 +1,111 @@
+# 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) Polygons(list(Polygon( matrix( cr[i,], ncol=2 ) )), i))
+ sp <- SpatialPolygons(sp, proj4string=crs(x))
+ 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
+}
+
+
diff --git a/R/rasterize.R b/R/rasterize.R
new file mode 100644
index 0000000..9064399
--- /dev/null
+++ b/R/rasterize.R
@@ -0,0 +1,65 @@
+# Author: Robert J. Hijmans
+# Date : October 2010
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("rasterize")) {
+ setGeneric("rasterize", function(x, y, ...)
+ standardGeneric("rasterize"))
+}
+
+
+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='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, ...){
+
+ 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,...)
+
+ }
+)
diff --git a/R/rasterizeLines.R b/R/rasterizeLines.R
new file mode 100644
index 0000000..191e813
--- /dev/null
+++ b/R/rasterizeLines.R
@@ -0,0 +1,366 @@
+# 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="", ...) {
+
+ stopifnot(requireNamespace("rgeos"))
+ 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) <- projection(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 <- 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 at lines)
+ info <- matrix(NA, nrow=nline, ncol=4)
+ info[,4] <- 1:nrow(info)
+ info[,1] <- sapply(lns at lines, function(i) length(i at Lines))
+ for (i in 1:nline) {
+ r <- range(sapply( lns at lines[[i]]@Lines, function(j) range(j at 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 at data@isfactor <- TRUE
+ rstr at 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 at lines[[i]]@Lines[[j]]@coords[,2] ) < lly | min( lns at lines[[i]]@Lines[[j]]@coords[,2] ) > uly ) {
+ # line part entirely outside of row. do nothing
+ } else {
+ aline <- lns at 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)
+}
+
diff --git a/R/rasterizePoints.R b/R/rasterizePoints.R
new file mode 100644
index 0000000..611b60b
--- /dev/null
+++ b/R/rasterizePoints.R
@@ -0,0 +1,234 @@
+# 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 at 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 at 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)
+}
diff --git a/R/rasterizePointsNGB.R b/R/rasterizePointsNGB.R
new file mode 100644
index 0000000..3e8746c
--- /dev/null
+++ b/R/rasterizePointsNGB.R
@@ -0,0 +1,22 @@
+
+
+
+.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
+}
+
+
diff --git a/R/rasterizePolygons.R b/R/rasterizePolygons.R
new file mode 100644
index 0000000..1a8d112
--- /dev/null
+++ b/R/rasterizePolygons.R
@@ -0,0 +1,587 @@
+# 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 at 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 at 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, ...) {
+
+ 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 at 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 (getCover) {
+# fun <- 'first'
+# mask <- FALSE
+# update <- FALSE
+# field <- -1
+ return (.polygoncover(p, rstr, filename, ...))
+ }
+
+ 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) <- projection(p)
+ }
+
+# check if bbox of raster and p overlap
+ spbb <- 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 at polygons)
+ pvals <- .getPutVals(p, field, npol, mask)
+ putvals <- pvals[,1]
+ if (ncol(pvals) > 1) {
+ rstr at data@isfactor <- TRUE
+ rstr at 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 <- matrix(NA, nrow=npol * 2, ncol=6)
+ colnames(polinfo) <- c('part', 'miny', 'maxy', 'value', 'hole', 'object')
+ addpol <- matrix(NA, nrow=500, ncol=6)
+
+ pollist <- list()
+ cnt <- 0
+ for (i in 1:npol) {
+ nsubpol <- length(p at 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 at polygons[[i]]@Polygons[[j]]@coords[,2])
+ polinfo[cnt, 3] <- max(p at polygons[[i]]@Polygons[[j]]@coords[,2])
+ polinfo[cnt, 4] <- putvals[i]
+ if ( p at polygons[[i]]@Polygons[[j]]@hole ) {
+ polinfo[cnt, 5] <- 1
+ } else {
+ polinfo[cnt, 5] <- 0
+ }
+ polinfo[cnt, 6] <- i
+ pollist[[cnt]] <- p at 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 at coords)
+ x <- sort(intersection[,1])
+ if (length(x) > 0) {
+ if ( sum(x[-length(x)] == x[-1]) > 0 ) {
+ # single node intersection going out of polygon ....
+ spPnts <- SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr))))
+ spPol <- SpatialPolygons(list(Polygons(list(mypoly), 1)))
+ over <- 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) { 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) {
+ rvtmp[holes < 1] <- NA
+ vals <- cbind(vals, rvtmp)
+ rvtmp <- rv1
+ }
+ }
+ }
+
+
+ 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 <- projection(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 at 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 <- SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr))))
+ spPol <- SpatialPolygons(list(Polygons(list(mypoly), 1)))
+ over <- 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 <- 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 at polygons)
+ } else {
+ putvals <- as.vector(p at 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 <- 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)
+}
+
diff --git a/R/rasterizePolygons3.R b/R/rasterizePolygons3.R
new file mode 100644
index 0000000..08ac164
--- /dev/null
+++ b/R/rasterizePolygons3.R
@@ -0,0 +1,200 @@
+# Author: Robert J. Hijmans
+# Date : July 2011
+# Version 1.0
+# Licence GPL v3
+
+
+.checkFields <- function(putvals) {
+ for (i in 1:ncol(putvals)) {
+ if (class(putvals[,i]) == 'factor') {
+ ptv <- try( as.numeric(as.character(putvals[,i])) )
+ if (class(ptv) == 'try-error') {
+ putvals[,i] <- as.numeric(putvals[,i])
+ } else {
+ putvals[,i] <- ptv
+ }
+ } else if (class(putvals) == 'character') {
+ ptv <- try( as.numeric(as.character(putvals[,i])) )
+ if (class(ptv) == 'try-error') {
+ stop('field: ', colnames(putvals)[i], ' cannot be converted to a number')
+ } else {
+ putvals <- ptv
+ }
+ }
+ }
+ putvals
+}
+
+
+.p3r <- function(p, x, field=0, background=NA, mask=FALSE, update=FALSE, filename="", ...) {
+
+ filename <- trim(filename)
+ if (mask | update) {
+ if (mask & update) {
+ stop('you cannot use mask=TRUE & update=TRUE at the same time')
+ }
+ oldx <- x
+
+ }
+ x <- raster(x)
+ projp <- projection(p)
+ if (! compareCRS(projp, x)) {
+ # warning('crs or raster and polygons do not match')
+ }
+ if (! is.na(projp)) {
+ projection(x) = projp
+ }
+
+ spbb <- bbox(p)
+ rsbb <- bbox(x)
+ 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]) {
+ stop('polygon and raster have no overlapping areas')
+ }
+ npol <- length(p at polygons)
+
+ if (! is.numeric(field) ) {
+ putvals <- .checkFields( p at data[, field, drop=FALSE] )
+ } else if (length(field) > 1) {
+ if (length(field) == npol) {
+ putvals <- field
+ } else {
+ if (inherits(p, 'SpatialPolygonsDataFrame')) {
+ putvals <- .checkFields( p at data[, field, drop=FALSE] )
+ } else {
+ stop('incorrect value for "field"')
+ }
+ }
+ } else if (mask) {
+ putvals <- rep(1, length=npol)
+ } else if (field < 0) {
+ putvals <- rep(1, length=npol)
+ } else if (field == 0) {
+ putvals <- as.integer(1:npol)
+ } else {
+ putvals <- .checkFields(p at data[, field, drop=FALSE])
+ }
+ if (is.vector(putvals)) {
+ putvals <- matrix(putvals, ncol=1)
+ } else {
+ putvals <- as.matrix(putvals)
+ }
+
+ nl <- NCOL(putvals)
+ if (nl > 1) {
+ x <- brick(x, nl=nl)
+ }
+
+ npol <- length(p at polygons)
+ polinfo <- matrix(NA, nrow=npol * 3, ncol=7)
+ addpol <- matrix(NA, nrow=500, ncol=7)
+ polx <- poly <- vector(length=npol * 3, mode='list')
+ cnt <- 0
+
+ for (i in 1:npol) {
+ nsubpol <- length(p at polygons[[i]]@Polygons)
+ for (j in 1:nsubpol) {
+ cnt <- cnt + 1
+ if (cnt > dim(polinfo)[1]) {
+ polinfo <- rbind(polinfo, addpol)
+ }
+ polinfo[cnt, 1] <- cnt
+ rg <- range(p at polygons[[i]]@Polygons[[j]]@coords[,1])
+ polinfo[cnt, 2] <- rg[1]
+ polinfo[cnt, 3] <- rg[2]
+ rg <- range(p at polygons[[i]]@Polygons[[j]]@coords[,2])
+ polinfo[cnt, 4] <- rg[1]
+ polinfo[cnt, 5] <- rg[2]
+ polinfo[cnt, 6] <- p at polygons[[i]]@Polygons[[j]]@hole
+ polinfo[cnt, 7] <- i
+
+ polx[[cnt]] <- p at polygons[[i]]@Polygons[[j]]@coords[,1]
+ poly[[cnt]] <- p at polygons[[i]]@Polygons[[j]]@coords[,2]
+ }
+ }
+ #rm(p)
+ polinfo <- subset(polinfo, polinfo[,1] <= cnt, drop=FALSE)
+
+ polx <- polx[1:cnt]
+ poly <- poly[1:cnt]
+
+ message('Found', npol, 'region(s) and', cnt, 'polygon(s)')
+
+ if (!canProcessInMemory(x)) {
+ if (filename == "") {
+ filename <- rasterTmpFile()
+ }
+ }
+ if (filename == "") {
+ v <- matrix(NA, ncol=nlayers(x), nrow=ncell(x))
+ } else {
+ x <- writeStart(x, filename=filename, ...)
+ }
+
+ tr <- blockSize(x, n=2*nlayers(x))
+ pb <- pbCreate(tr$n, label='rasterize', ...)
+
+ rx <- c(xmin(x), xmax(x))
+
+ for (i in 1:tr$n) {
+
+ cells <- cellFromRowCol(x, tr$row[i], 1) : cellFromRowCol(x, tr$row[i]+(tr$nrows[i]-1), ncol(x))
+ xy <- xyFromCell(x, cells)
+ ry <- range(xy[,2])
+ subpol <- subset(polinfo, !(polinfo[,2] > rx[2] | polinfo[,3] < rx[1] | polinfo[,4] > ry[2] | polinfo[,5] < ry[1] ), drop=FALSE)
+
+ if (nrow(subpol) > 0) {
+ rrv <- rep(NA, nrow(xy))
+
+ px <- polx[subpol[,1]]
+ py <- poly[subpol[,1]]
+ p <- xy[,1] >= min(subpol[,2]) & xy[,1] <= max(subpol[,3]) & xy[,2] >= min(subpol[,4]) & xy[,2] <= max(subpol[,5])
+
+ rrv[p] <- .Call('point_in_polygon2', xy[p,1], xy[p,2], px, py, as.integer(subpol[,7]), as.integer(subpol[,6]), PACKAGE='raster')
+
+ if (!is.na(background)) {
+ rrv[is.na(rrv)] <- background
+ }
+
+ if (mask) {
+ vals <- getValues(oldx, tr$row[i], tr$nrows[i])
+ if (nl == 1) {
+ vals <- matrix(vals, ncol=1)
+ }
+ vals[is.na(rrv), ] <- NA
+ } else if (update) {
+ vals <- getValues(oldx, tr$row[i], tr$nrows[i])
+ if (nl == 1) {
+ vals <- matrix(vals, ncol=1)
+ }
+ vals[is.na(rrv), ] <- putvals[!is.na(rrv), ]
+ } else {
+ vals <- putvals[rrv, ]
+ }
+
+ if (filename == "") {
+ v[cells,] <- vals
+ } else {
+ x <- writeValues(x, vals, tr$row[i])
+ }
+ } else {
+ if (filename != "") {
+ vals <- matrix(NA, nrow=length(cells), ncol=nl)
+ x <- writeValues(x, vals, tr$row[i])
+ }
+ }
+ pbStep(pb, i)
+ }
+ pbClose(pb)
+
+ if (filename == "") {
+ x <- setValues(x, v)
+ } else {
+ x <- writeStop(x)
+ }
+ return(x)
+}
+
+#e = .p3r(p, r)
+
+
+
\ No newline at end of file
diff --git a/R/ratify.R b/R/ratify.R
new file mode 100644
index 0000000..487a8db
--- /dev/null
+++ b/R/ratify.R
@@ -0,0 +1,134 @@
+# Author: Robert J. Hijmans
+# Date : June 2012
+# Version 1.0
+# Licence GPL v3
+
+ratify <- 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 at data@isfactor <- TRUE
+ x at data@attributes <- list(f)
+ if (filename != '') {
+ x <- writeRaster(x, filename, ...)
+ # only native format stores this, hence re-assign these:
+ x at data@isfactor <- TRUE
+ x at 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 at data@isfactor <- FALSE
+ x at 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) {
+ w <- getOption('warn')
+ options('warn'=-1)
+ v <- as.numeric(as.character(RAT[,i]))
+ options('warn' = w)
+ if (isTRUE(all(RAT[,i] == v))) {
+ RAT[,i] <- v
+ }
+ }
+ }
+ subs(x, RAT, by=1, which=cc, subsWithNA=TRUE, filename=filename, ...)
+}
+
+
diff --git a/R/read.R b/R/read.R
new file mode 100644
index 0000000..9d479f9
--- /dev/null
+++ b/R/read.R
@@ -0,0 +1,67 @@
+# 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 at data@fromdisk) {
+ warning('cannot read values; there is no file associated with this RasterLayer')
+ return(object)
+ }
+ object at data@values <- .readRasterLayerValues(object, 1, object at nrows)
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+ object at data@min <- as.vector( min(object at data@values, na.rm=TRUE ) )
+ object at data@max <- as.vector( max(object at data@values, na.rm=TRUE ) )
+ object at data@haveminmax <- TRUE
+ object at data@inmemory <- TRUE
+ object at data@fromdisk <- FALSE
+
+ return(object)
+ }
+)
+
+
+setMethod('readAll', signature(object='RasterStack'),
+ function(object){
+ for (i in seq(nlayers(object))) {
+ if (! object at layers[[i]]@data at inmemory ) {
+ object at layers[[i]] <- readAll(object at layers[[i]])
+# object at layers[[i]]@data at values <- .readRasterLayerValues(object at layers[[i]], 1, object at nrows)
+ }
+ }
+ return(object)
+ }
+)
+
+
+setMethod('readAll', signature(object='RasterBrick'),
+ function(object){
+ if (! object at data@fromdisk) {
+ warning('cannot read values; there is no file associated with this RasterBrick')
+ return(object)
+ }
+ object at data@values <- .readRasterBrickValues(object, 1, object at nrows)
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+ rge <- apply(object at data@values, 2, FUN=function(x){ range(x, na.rm=TRUE) } )
+ object at data@min <- as.vector(rge[1,])
+ object at data@max <- as.vector(rge[2,])
+ object at data@haveminmax <- TRUE
+ object at data@inmemory <- TRUE
+ object at data@fromdisk <- FALSE
+ return(object)
+ }
+)
+
diff --git a/R/readAscii.R b/R/readAscii.R
new file mode 100644
index 0000000..0305b0d
--- /dev/null
+++ b/R/readAscii.R
@@ -0,0 +1,66 @@
+# 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 at offset, what='character', quiet=TRUE) )
+# if (x at file@nodatavalue < -10000) {
+# v[v <= x at file@nodatavalue ] <- NA
+# } else {
+ v[v == x at file@nodatavalue ] <- NA
+# }
+ return ( v )
+}
+
+
+.readRowsAscii <- function(x, startrow, nrows, startcol=1, ncols=x at ncols) {
+
+ if (startcol > 1 | ncols < x at ncols) {
+ v <- matrix(nrow=ncols, ncol=nrows)
+ endcol <- startcol+ncols-1
+ skiprows <- x at 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 at file@offset + startrow - 1
+ v <- as.numeric ( scan(filename(x), skip=skiprows, nlines=nrows, what='character', quiet=TRUE) )
+ }
+# if (x at file@nodatavalue < 0) {
+# v[v <= x at file@nodatavalue ] <- NA
+# } else {
+ v[v == x at 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 at ncols)
+ thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE]
+ colrow[colrow[,2] == rows[i],4] <- v[thisrow[,1]]
+ }
+ return(colrow[,4])
+}
+
+
diff --git a/R/readCells.R b/R/readCells.R
new file mode 100644
index 0000000..76e63e3
--- /dev/null
+++ b/R/readCells.R
@@ -0,0 +1,252 @@
+# 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 at 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 at data@gain != 1 | x at data@offset != 0) {
+ vals <- vals * x at data@gain + x at data@offset
+ }
+ }
+
+ # if NAvalue() has been used.....
+ if (.naChanged(x)) {
+ if (x at file@nodatavalue < 0) {
+ vals[vals <= x at file@nodatavalue] <- NA
+ } else {
+ vals[vals == x at file@nodatavalue] <- NA
+ }
+ }
+
+ return(vals)
+}
+
+
+
+.readBigMatrixCells <- function(x, cells, layers) {
+
+ b <- attr(x at 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 at 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]
+ }
+}
+
+
+.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 at ncols
+ con <- rgdal::GDAL.open(x at 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)]
+}
+
+
+
+
+.readCellsRaster <- function(x, cells, layers=1) {
+ nl <- length(layers)
+ res <- vector(length=length(cells)*nl)
+ res[] <- NA
+
+ if (! x at file@toptobottom) {
+ rows <- rowFromCell(x, cells)
+ cols <- colFromCell(x, cells)
+ rows <- nrow(x) - rows + 1
+ cells <- cellFromRowCol(x, rows, cols)
+ }
+ cells <- cells + x at file@offset
+
+ if (nbands(x) > 1) {
+ if (inherits(x, 'RasterLayer')) {
+ if (.bandOrder(x) == 'BIL') {
+ cells <- cells + (rowFromCell(x, cells)-1) * x at ncols * (nbands(x)-1) + (bandnr(x)-1) * x at 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 at ncols * (nbands(x)-1) , each=nl) + (layers-1) * x at 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 at file@byteorder
+ dsize <- dataSize(x at file@datanotation)
+ if (.shortDataType(x at file@datanotation) == "FLT") {
+ dtype <- "numeric"
+ } else {
+ dtype <- "integer"
+ }
+ cells <- (cells-1) * dsize
+ signed <- dataSigned(x at file@datanotation)
+ if (dsize > 2) { signed <- TRUE }
+
+ is.open <- x at file@open
+ if (!is.open) {
+ x <- readStart(x)
+ }
+
+ for (i in seq(along.with=cells)) {
+ seek(x at file@con, cells[i])
+ res[i] <- readBin(x at file@con, what=dtype, n=1, size=dsize, endian=byteord, signed=signed)
+ }
+ if (!is.open) {
+ x <- readStop(x)
+ }
+
+ if (x at 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 at file@nodatavalue] <- NA
+ } else {
+ res[res == x at file@nodatavalue] <- NA
+ }
+ if (nl > 1) {
+ res <- t(matrix(res, nrow=nl))
+ colnames(res) <- names(x)[layers]
+ }
+ return(res)
+}
+
diff --git a/R/readRasterBrick.R b/R/readRasterBrick.R
new file mode 100644
index 0000000..3e6a546
--- /dev/null
+++ b/R/readRasterBrick.R
@@ -0,0 +1,203 @@
+# 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 at nrows)
+ endrow <- min(object at nrows, startrow+nrows-1)
+ nrows <- endrow - startrow + 1
+
+ if (ncols < 1) { stop("ncols should be > 1") }
+ startcol <- min(max(1, round(startcol)), object at ncols)
+ endcol <- min(object at ncols, startcol+ncols-1)
+ ncols <- endcol - startcol + 1
+
+ if (.isNativeDriver(object at file@driver)) {
+
+ getBSQData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) {
+ if (c==1 & ncols==raster at ncols ) {
+ if (r==1 & nrows==raster at nrows) {
+ nc <- nrows*ncols*raster at data@nlayers
+ seek(raster at file@con, raster at file@offset * dsize)
+ result <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ dim(result) <- c(nrows*ncols, raster at data@nlayers)
+ } else {
+ ncells <- nrows*ncols
+ result <- matrix(nrow=ncells, ncol=raster at data@nlayers)
+ for (b in 1:raster at data@nlayers) {
+ offset <- raster at file@offset + (b-1) * raster at ncols * raster at nrows + (r-1) * raster at ncols
+ seek(raster at file@con, offset * dsize)
+ result[,b] <- readBin(raster at file@con, what=dtype, n=ncells, dsize, dsign, endian=raster at file@byteorder)
+ }
+ }
+ } else {
+ nc <- nrows*ncols
+ result <- matrix(nrow=nc, ncol=raster at data@nlayers)
+ res <- matrix(ncol=nrows, nrow=ncols)
+ for (b in 1:raster at data@nlayers) {
+ offset <- raster at file@offset + (b-1) * raster at ncols * raster at nrows + (r-1) * raster at ncols + (c-1)
+ for (i in 1:nrows) {
+ off <- offset + (i-1) * raster at ncols
+ seek(raster at file@con, off * dsize)
+ res[,i] <- readBin(raster at file@con, what=dtype, n=ncols, dsize, dsign, endian=raster at file@byteorder)
+ }
+ result[,b] <- as.vector(res)
+ }
+ }
+ return( result )
+ }
+
+ getBilData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) {
+ if (c==1 & ncols==raster at ncols ) {
+ nc <- nrows*ncols*raster at data@nlayers
+ if (r==1 & nrows==raster at nrows) {
+ seek(raster at file@con, raster at file@offset * dsize)
+ res <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ } else {
+ offset <- raster at file@offset + raster at data@nlayers * raster at ncols * (r-1)
+ seek(raster at file@con, offset * dsize)
+ res <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ }
+ } else {
+ res <- matrix(ncol=nrows*raster at data@nlayers, nrow=ncols)
+ offset <- raster at file@offset + raster at data@nlayers * raster at ncols * (r-1) + (c-1)
+ for (i in 1:ncol(res)) {
+ off <- offset + (i-1) * raster at ncols
+ seek(raster at file@con, off * dsize)
+ res[,i] <- readBin(raster at file@con, what=dtype, n=ncols, dsize, dsign, endian=raster at file@byteorder)
+ }
+ res <- as.vector(res)
+ }
+
+ result <- matrix(nrow=ncols*nrows, ncol=nlayers(raster))
+ dim(res) <- c(ncols, raster at data@nlayers*nrows)
+ a <- rep(1:raster at data@nlayers, nrows)
+ for (b in 1:raster at 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 at ncols ) {
+ nc <- nrows*ncols*raster at data@nlayers
+ if (r==1 & nrows==raster at nrows) {
+ seek(raster at file@con, raster at file@offset * dsize)
+ result <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ } else {
+ offset <- raster at file@offset + raster at data@nlayers * raster at ncols * (r-1)
+ seek(raster at file@con, offset * dsize)
+ result <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ }
+ } else {
+ nc <- ncols*raster at data@nlayers
+ result <- matrix(ncol=nrows, nrow=ncols*raster at data@nlayers)
+ offset <- raster at file@offset + raster at data@nlayers * raster at ncols * (r-1)
+ for (i in 1:nrows) {
+ off <- offset + (i-1) * raster at data@nlayers * raster at ncols + (c-1) * raster at data@nlayers
+ seek(raster at file@con, off * dsize)
+ result[,i] <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ }
+ result <- as.vector(result)
+ }
+ dim(result) <- c(raster at data@nlayers, nrows*ncols)
+ t(result)
+ }
+
+
+ if (! object at file@toptobottom ) {
+ stop('bottom-to-top data not supported for RasterBrick objects')
+ }
+ dtype <- substr(object at file@datanotation, 1, 3)
+ if (dtype == "INT" | dtype == "LOG" ) {
+ dtype <- "integer"
+ } else {
+ dtype <- "numeric"
+ }
+ dsize <- dataSize(object at file@datanotation)
+ dsign <- dataSigned(object at file@datanotation)
+ if (dsize > 2) { dsign <- TRUE }
+
+ is.open <- object at file@open
+ if (!is.open) {
+ object <- readStart(object)
+ }
+ if (object at data@nlayers > 1) {
+ bo <- object at 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 at file@datanotation == 'INT4U') {
+ i <- !is.na(result) & result < 0
+ result[i] <- 2147483647 - result[i]
+ }
+
+ if (dtype == 'numeric') {
+ result[result <= (0.999999 * object at file@nodatavalue)] <- NA
+ result[is.nan(result)] <- NA
+ } else {
+ result[result == object at file@nodatavalue ] <- NA
+ }
+ if (dtype == 'logical') {
+ result <- as.logical(result)
+ }
+
+
+ } else if (object at file@driver == 'netcdf') {
+ result <- .readRowsBrickNetCDF(object, startrow, nrows, startcol, ncols)
+
+ } else if (object at file@driver == 'big.matrix') {
+
+ b <- attr(object at 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 at 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 at data@nlayers) {
+ result[, b] <- rgdal::getRasterData(con, offset = offs,
+ region.dim = reg, band = b)
+ }
+
+ rgdal::closeDataset(con)
+ result[result == object at file@nodatavalue] <- NA
+
+ }
+
+ if (object at data@gain != 1 | object at data@offset != 0) {
+ result <- result * object at data@gain + object at data@offset
+ }
+
+ colnames(result) <- names(object)
+ return(result)
+}
+
+
+
diff --git a/R/readRasterLayer.R b/R/readRasterLayer.R
new file mode 100644
index 0000000..ddf9de2
--- /dev/null
+++ b/R/readRasterLayer.R
@@ -0,0 +1,170 @@
+# 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 at nrows)
+# endrow <- min(object at nrows, startrow+nrows-1)
+# nrows <- endrow - startrow + 1
+
+# if (ncols < 1) { stop("ncols should be > 1") }
+# startcol <- min(max(1, round(startcol)), object at ncols)
+# endcol <- min(object at ncols, startcol+ncols-1)
+# ncols <- endcol - startcol + 1
+
+ driver <- object at file@driver
+
+ if (.isNativeDriver(driver)) {
+
+ getBSQData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band=1) {
+ offset <- raster at file@offset + (band-1) * raster at ncols * raster at nrows + (r-1) * raster at ncols
+ if (c==1 & ncols==raster at ncols) {
+ seek(raster at file@con, offset * dsize)
+ result <- readBin(raster at file@con, what=dtype, n=nrows*ncols, dsize, dsign, endian=raster at file@byteorder)
+ } else {
+ result <- matrix(ncol=nrows, nrow=ncols)
+ for (i in 1:nrows) {
+ off <- offset + (i-1) * raster at ncols + (c-1)
+ seek(raster at file@con, off * dsize)
+ result[,i] <- readBin(raster at file@con, what=dtype, n=ncols, dsize, dsign, endian=raster at file@byteorder)
+ }
+ }
+ return(as.vector(result))
+ }
+
+ getBilData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band) {
+ offset <- raster at file@offset + raster at file@nbands * raster at ncols * (r-1) + (c-1)
+ result <- matrix(ncol=nrows, nrow=ncols)
+ for (i in 1:nrows) {
+ off <- offset + (i-1) * raster at ncols * raster at file@nbands + (band-1) * raster at ncols
+ seek(raster at file@con, off * dsize)
+ result[,i] <- readBin(raster at file@con, what=dtype, n=ncols, dsize, dsign, endian=raster at file@byteorder)
+ }
+ return(as.vector(result))
+ }
+
+ getBipData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band) {
+ offset <- raster at file@offset + raster at file@nbands * raster at ncols * (r-1)
+ nc <- ncols * raster at file@nbands
+ index <- rep(FALSE, raster at 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 at ncols * raster at file@nbands + (c-1) * raster at file@nbands
+ seek(raster at file@con, off * dsize)
+ res <- readBin(raster at file@con, what=dtype, n=nc, dsize, dsign, endian=raster at file@byteorder)
+ result[,i] <- res[index]
+ }
+ return(as.vector(result))
+ }
+
+
+ if (! object at file@toptobottom ) {
+ endrow <- object at nrows - startrow + 1
+ startrow <- endrow - nrows + 1
+ }
+ dtype <- substr(object at file@datanotation, 1, 3)
+ if (dtype == "INT" | dtype == "LOG" ) {
+ dtype <- "integer"
+ } else {
+ dtype <- "numeric"
+ }
+ dsize <- dataSize(object at file@datanotation)
+ dsign <- dataSigned(object at file@datanotation)
+ if (dsize > 2) { dsign <- TRUE }
+
+ is.open <- object at file@open
+ if (!is.open) {
+ object <- readStart(object)
+ }
+ if (object at file@nbands > 1) {
+ band <- object at data@band
+ bo <- object at 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 at file@toptobottom ) {
+ result <- t(matrix(result, nrow=ncols, ncol=nrows))
+ result <- result[nrows:1,]
+ result <- as.vector(t(result))
+ }
+
+ if (object at file@datanotation == 'INT4U') {
+ i <- !is.na(result) & result < 0
+ result[i] <- 2147483647 - result[i]
+ }
+ if (dtype == 'numeric') {
+ result[result <= (0.999999 * object at file@nodatavalue)] <- NA
+ result[is.nan(result)] <- NA
+ } else {
+ result[result == object at 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 at 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 at file@open ) {
+ result <- rgdal::getRasterData(object at file@con, offset=offs, region.dim=reg, band=object at data@band)
+ } else {
+ con <- rgdal::GDAL.open(object at file@name, silent=TRUE)
+ result <- rgdal::getRasterData(con, offset=offs, region.dim=reg, band=object at data@band)
+ rgdal::closeDataset(con)
+ }
+ result <- as.vector(result)
+
+ # if NAvalue() has been used.....
+ if (object at file@nodatavalue < 0) {
+ result[result <= object at file@nodatavalue ] <- NA
+ } else {
+ result[result == object at file@nodatavalue ] <- NA
+ }
+
+ }
+
+ if (object at data@gain != 1 | object at data@offset != 0) {
+ result <- result * object at data@gain + object at data@offset
+ }
+
+ return(result)
+}
+
diff --git a/R/reclassify.R b/R/reclassify.R
new file mode 100644
index 0000000..381568a
--- /dev/null
+++ b/R/reclassify.R
@@ -0,0 +1,120 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("reclassify")) {
+ setGeneric("reclassify", function(x, rcl, ...)
+ standardGeneric("reclassify"))
+}
+
+
+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)
+ }
+
+ include.lowest <- as.integer(include.lowest)
+ 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, .Call('reclass', values(x), rcl, include.lowest, right, onlyNA, valNA, NAOK=TRUE, PACKAGE='raster'))
+ 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 <- .Call('reclass', vals, rcl, include.lowest, right, onlyNA, valNA, NAOK=TRUE, PACKAGE='raster')
+ 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)
+ }
+}
+)
+
+
+
diff --git a/R/rectify.R b/R/rectify.R
new file mode 100644
index 0000000..0c16696
--- /dev/null
+++ b/R/rectify.R
@@ -0,0 +1,26 @@
+# Robert J. Hijmans
+# May 2010
+# Version 1.0
+# Licence GPL v3
+
+rotated <- function(x) {
+ isTRUE(try(x at rotated, silent=TRUE))
+}
+
+
+rectify <- 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) <- raster::res(x)
+ } else {
+ res(out) <- res
+ }
+ resample(x, out, method=method, filename=filename, ...)
+}
+
diff --git a/R/replaceProperties.R b/R/replaceProperties.R
new file mode 100644
index 0000000..d2c8e61
--- /dev/null
+++ b/R/replaceProperties.R
@@ -0,0 +1,54 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+
+'ncol<-' <- function(x, value) {
+ dim(x) <- c(nrow(x), value)
+ return(x)
+}
+
+'nrow<-' <- function(x, value) {
+ dim(x) <- c(value, ncol(x))
+ return(x)
+}
+
+
+'xmin<-' <- function(x, value) {
+ if (inherits(x, 'Extent')) {
+ x at xmin <- value
+ } else {
+ x at extent@xmin <- value
+ }
+ return(x)
+}
+
+'xmax<-' <- function(x, value) {
+ if (inherits(x, 'Extent')) {
+ x at xmax <- value
+ } else {
+ x at extent@xmax <- value
+ }
+ return(x)
+}
+
+'ymin<-' <- function(x, value) {
+ if (inherits(x, 'Extent')) {
+ x at ymin <- value
+ } else {
+ x at extent@ymin <- value
+ }
+ return(x)
+}
+
+'ymax<-' <- function(x, value) {
+ if (inherits(x, 'Extent')) {
+ x at ymax <- value
+ } else {
+ x at extent@ymax <- value
+ }
+ return(x)
+}
+
diff --git a/R/resample.R b/R/resample.R
new file mode 100644
index 0000000..1ef7cb6
--- /dev/null
+++ b/R/resample.R
@@ -0,0 +1,168 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("resample")) {
+ setGeneric("resample", function(x, y, ...)
+ standardGeneric("resample"))
+}
+
+
+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)
+ } 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 at 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 at 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 at ncols)
+ v[start:end, ] <- vals
+
+ pbStep(pb, i)
+ }
+ v <- setValues(y, v)
+ if (filename != '') {
+ 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)
+
+}
+)
diff --git a/R/resolution.R b/R/resolution.R
new file mode 100644
index 0000000..8405d1e
--- /dev/null
+++ b/R/resolution.R
@@ -0,0 +1,34 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+'res<-' <- 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 at xmax - bb at xmin) / xr ))
+ nr <- max(1, round( (bb at ymax - bb at ymin) / yr ))
+ if (nr != x at nrows | nc != x at ncols) {
+ if (methods::extends(class(x), "Raster")) {
+ x <- clearValues(x)
+ }
+ }
+ bb at xmax <- bb at xmin + nc * xr
+ bb at ymin <- bb at ymax - nr * yr
+ extent(x) <- bb
+ dim(x) <- c(nr, nc)
+ return(x)
+}
+
diff --git a/R/rotate.R b/R/rotate.R
new file mode 100644
index 0000000..a7d2cd5
--- /dev/null
+++ b/R/rotate.R
@@ -0,0 +1,61 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("rotate")) {
+ setGeneric("rotate", function(x, ...)
+ standardGeneric("rotate"))
+}
+
+
+setMethod('rotate', signature(x='Raster'),
+ function(x, filename='', ...) {
+
+ e <- extent(x)
+ xrange <- e at xmax - e at xmin
+ if (xrange < 350 | xrange > 370 | e at xmin < -10 | e at xmax > 370) {
+ if (xrange < 350 | xrange > 370 | e at xmin < -190 | e at 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 at z <- x at z
+
+ # suggested by Mike Sumner:
+ p <- projection(out)
+ if (length(grep("\\+over", p)) > 0) {
+ projection(out) <- gsub("[[:space:]]\\+over", "", p)
+ }
+
+ if (filename != '') {
+ out <- writeRaster(out, filename, ...)
+ }
+ return(out)
+ }
+)
+
diff --git a/R/roundExtent.R b/R/roundExtent.R
new file mode 100644
index 0000000..3f0e729
--- /dev/null
+++ b/R/roundExtent.R
@@ -0,0 +1,37 @@
+# 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 at xmin <- methods::callGeneric( x at xmin, digits)
+ x at xmax <- methods::callGeneric( x at xmax, digits)
+ x at ymin <- methods::callGeneric( x at ymin, digits)
+ x at ymax <- methods::callGeneric( x at ymax, digits)
+ return(x)
+ }
+)
+
+setMethod("floor", signature(x='Extent'),
+ function (x) {
+ x at xmin <- floor( x at xmin)
+ x at xmax <- ceiling( x at xmax)
+ x at ymin <- floor( x at ymin)
+ x at ymax <- ceiling( x at ymax)
+ return(x)
+ }
+)
+
+setMethod("ceiling", signature(x='Extent'),
+ function (x) {
+ x at xmin <- ceiling( x at xmin)
+ x at xmax <- floor( x at xmax)
+ x at ymin <- ceiling( x at ymin)
+ x at ymax <- floor( x at ymax)
+ return(x)
+ }
+)
+
diff --git a/R/rowMinMax.R b/R/rowMinMax.R
new file mode 100644
index 0000000..69a5c1b
--- /dev/null
+++ b/R/rowMinMax.R
@@ -0,0 +1,19 @@
+
+.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)
+}
+
+
diff --git a/R/rowSums.R b/R/rowSums.R
new file mode 100644
index 0000000..03e3da4
--- /dev/null
+++ b/R/rowSums.R
@@ -0,0 +1,97 @@
+# 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(as.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(as.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)
+ }
+ }
+ }
+)
diff --git a/R/sampleAlong.R b/R/sampleAlong.R
new file mode 100644
index 0000000..13ba994
--- /dev/null
+++ b/R/sampleAlong.R
@@ -0,0 +1,103 @@
+# 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)
+ }
+
+}
+
+
+
diff --git a/R/sampleInt.R b/R/sampleInt.R
new file mode 100644
index 0000000..b17a3e5
--- /dev/null
+++ b/R/sampleInt.R
@@ -0,0 +1,54 @@
+# 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 )
+}
diff --git a/R/sampleRandom.R b/R/sampleRandom.R
new file mode 100644
index 0000000..6ebb42e
--- /dev/null
+++ b/R/sampleRandom.R
@@ -0,0 +1,204 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("sampleRandom")) {
+ setGeneric("sampleRandom", function(x, size, ...)
+ standardGeneric("sampleRandom"))
+}
+
+
+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 <- SpatialPointsDataFrame(XY, data=data.frame(x), proj4string=projection(r, asText=FALSE))
+
+ } else if (removeCells) {
+ x <- x[,-1,drop=FALSE]
+ }
+
+ } else {
+ colnames(x) <- layn
+ }
+ }
+
+ return(x)
+}
+)
+
+
diff --git a/R/sampleRegular.R b/R/sampleRegular.R
new file mode 100644
index 0000000..1782ea0
--- /dev/null
+++ b/R/sampleRegular.R
@@ -0,0 +1,246 @@
+# Author: Robert J. Hijmans
+# Date : November 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("sampleRegular")) {
+ setGeneric("sampleRegular", function(x, size, ...)
+ standardGeneric("sampleRegular"))
+}
+
+
+setMethod('sampleRegular', signature(x='Raster'),
+function( x, size, ext=NULL, cells=FALSE, xy=FALSE, asRaster=FALSE, sp=FALSE, useGDAL=FALSE, ...) {
+
+ stopifnot(hasValues(x))
+
+ 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 at ymax-0.5 *yr)
+ lastrow <- rowFromY(x, ext at ymin+0.5*yr)
+ firstcol <- colFromX(x, ext at xmin+0.5*xr)
+ lastcol <- colFromX(x, ext at 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)
+ }
+
+
+ if (fromDisk(x) & useGDAL) {
+
+ 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 at 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 at data@gain != 1 | xx at data@offset != 0) {
+ vv <- vv * xx at data@gain + xx at data@offset
+ }
+ if (xx at file@nodatavalue < 0) {
+ vv[vv <= xx at file@nodatavalue] <- NA
+ } else {
+ vv[vv == xx at file@nodatavalue] <- NA
+ }
+ v[, i] <- vv
+ }
+
+ } else {
+
+ band <- bandnr(x)
+ con <- rgdal::GDAL.open(x at 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 at data@gain != 1 | x at data@offset != 0) {
+ v <- v * x at data@gain + x at data@offset
+ }
+
+ if (.naChanged(x)) {
+ if (x at file@nodatavalue < 0) {
+ v[v <= x at file@nodatavalue] <- NA
+ } else {
+ v[v == x at 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))
+ m <- .xyValues(x, xy)
+
+ } 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))
+ m <- .cellValues(x, cell)
+
+ 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
+ }
+ m <- cbind(m, .cellValues(x, cell))
+ colnames(m)[nstart:(nstart+nl-1)] <- names(x)
+
+ if (sp) {
+ m <- SpatialPointsDataFrame(xyFromCell(x, cell), data.frame(m), proj4string=crs(x))
+ }
+
+ return(m)
+ }
+}
+
+)
diff --git a/R/sampleStratified.R b/R/sampleStratified.R
new file mode 100644
index 0000000..eae4ee0
--- /dev/null
+++ b/R/sampleStratified.R
@@ -0,0 +1,127 @@
+# Author: Robert J. Hijmans
+# Date : June 2012
+# Version 2.0
+# Licence GPL v3
+
+
+if (!isGeneric("sampleStratified")) {
+ setGeneric("sampleStratified", function(x, size, ...)
+ standardGeneric("sampleStratified"))
+}
+
+
+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])
+ }
+ }
+ if (xy) {
+ pts <- xyFromCell(x, res[,1])
+ res <- cbind(res[,1,drop=FALSE], pts, res[,2,drop=FALSE])
+ }
+
+ if (sp) {
+ if (!xy) {
+ pts <- xyFromCell(x, res[,1])
+ }
+ res <- SpatialPointsDataFrame(pts, data.frame(res), proj4string=projection(x, asText=FALSE))
+ }
+ return(res)
+}
+)
+
+
+
+
diff --git a/R/scale.R b/R/scale.R
new file mode 100644
index 0000000..8b20e7c
--- /dev/null
+++ b/R/scale.R
@@ -0,0 +1,44 @@
+# 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
+ }
+)
+
+
+
diff --git a/R/scalebar.R b/R/scalebar.R
new file mode 100644
index 0000000..25c12c7
--- /dev/null
+++ b/R/scalebar.R
@@ -0,0 +1,144 @@
+# 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 at extent@ymax - 0.5 * (object at extent@ymax - object at 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,...)
+ }
+ }
+}
diff --git a/R/select.R b/R/select.R
new file mode 100644
index 0000000..728f1d7
--- /dev/null
+++ b/R/select.R
@@ -0,0 +1,134 @@
+# 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 at proj4string <- x at proj4string
+ int <- intersect(extent(e), extent(x))
+ if (is.null(int)) {
+ return( NULL )
+ }
+
+ if (inherits(x, 'SpatialPolygons')) {
+ stopifnot(requireNamespace("rgeos"))
+ 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')) {
+ stopifnot(requireNamespace("rgeos"))
+ 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(over(x, e)))
+ if (length(i) > 0) {
+ x <- x[i,]
+ 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(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(over(x, e)))
+ if (length(i) > 0) {
+ x <- x[i,]
+ if (draw) {
+ points(x, col=col, cex=size)
+ }
+ } else {
+ x <- NULL
+ }
+ }
+ x
+ }
+)
+
+
diff --git a/R/setCV.R b/R/setCV.R
new file mode 100644
index 0000000..cf3aa37
--- /dev/null
+++ b/R/setCV.R
@@ -0,0 +1,30 @@
+
+.setCV <- function(x, v, col) {
+ stopifnot(length(v) == (length(col)+1))
+ v <- as.numeric(v)
+ x at legend@values <- v
+ x at legend@color <- col
+ x at 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 at legend@values <- v
+ x at legend@color <- col
+ x
+}
+
diff --git a/R/setExtent.R b/R/setExtent.R
new file mode 100644
index 0000000..e8e580c
--- /dev/null
+++ b/R/setExtent.R
@@ -0,0 +1,67 @@
+# 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 at extent <- bb
+ if (nlayers(x) > 0) {
+ for (i in 1:nlayers(x)) {
+ x at layers[[i]]@extent <- bb
+ }
+ }
+ return(x)
+ }
+
+
+ if (keepres) {
+
+ newobj <- clearValues(x)
+ xrs <- xres(newobj)
+ yrs <- yres(newobj)
+ newobj at extent <- bb
+ nc <- as.integer(round( (newobj at extent@xmax - newobj at extent@xmin) / xrs ))
+ if (nc < 1) {
+ stop( "xmin and xmax are less than one cell apart" )
+ } else {
+ newobj at ncols <- nc
+ }
+ nr <- as.integer(round( (newobj at extent@ymax - newobj at extent@ymin) / yrs ) )
+ if (nr < 1) {
+ stop( "ymin and ymax are less than one cell apart" )
+ } else {
+ newobj at nrows <- nr
+ }
+ newobj at extent@xmax <- newobj at extent@xmin + newobj at ncols * xrs
+ newobj at extent@ymax <- newobj at extent@ymin + newobj at nrows * yrs
+
+ if ((x at ncols == newobj at ncols) & (x at nrows == newobj at nrows)) {
+ x at extent <- newobj at extent
+ return(x)
+ } else {
+ return(newobj)
+ }
+
+ } else if (class(x) != "BasicRaster") {
+ x at extent <- bb
+ return(x)
+ }
+
+}
+
diff --git a/R/setFileExt.R b/R/setFileExt.R
new file mode 100644
index 0000000..3a5f01c
--- /dev/null
+++ b/R/setFileExt.R
@@ -0,0 +1,49 @@
+# 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)
+}
+
\ No newline at end of file
diff --git a/R/setMinMax.R b/R/setMinMax.R
new file mode 100644
index 0000000..170be07
--- /dev/null
+++ b/R/setMinMax.R
@@ -0,0 +1,108 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric('setMinMax')) {
+ setGeneric('setMinMax', function(x)
+ standardGeneric('setMinMax'))
+ }
+
+
+
+setMethod('setMinMax', signature(x='RasterLayer'),
+function(x) {
+ w <- getOption('warn')
+ on.exit(options('warn' = w))
+ options('warn'=-1)
+
+ if ( inMemory(x) ) {
+ x at data@min <- min(x at data@values, na.rm=TRUE)
+ x at data@max <- max(x at data@values, na.rm=TRUE)
+ } else {
+ if (! fromDisk(x)) {
+ stop('no values associated with this RasterLayer')
+ }
+ x at data@min <- Inf
+ x at 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 at data@min <- min(x at data@min, min(v, na.rm=TRUE))
+ x at data@max <- max(x at data@max, max(v, na.rm=TRUE))
+ }
+ x <- readStop(x)
+ }
+
+# if (datatype == 'logical') {
+# x at data@min <- as.logical(x at data@min)
+# x at data@max <- as.logical(x at data@max)
+# }
+
+ x at 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 at data@min <- as.vector(rge[1,])
+ x at 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 at data@min <- minmax[1,]
+ x at data@max <- minmax[2,]
+ }
+# if (datatype == 'logical') {
+# x at data@min <- as.logical(x at data@min)
+# x at data@max <- as.logical(x at data@max)
+# }
+
+ x at data@haveminmax <- TRUE
+ return(x)
+}
+)
+
+
+setMethod('setMinMax', signature(x='RasterStack'),
+ function(x) {
+ for (i in 1:nlayers(x)) {
+ x at layers[[i]] <- setMinMax(x at layers[[i]])
+ }
+ return(x)
+ }
+)
diff --git a/R/setValues.R b/R/setValues.R
new file mode 100644
index 0000000..7b2806e
--- /dev/null
+++ b/R/setValues.R
@@ -0,0 +1,256 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric('setValues')) {
+ setGeneric('setValues', function(x, values, ...)
+ standardGeneric('setValues'))
+}
+
+
+
+setMethod('setValues', signature(x='RasterLayer'),
+function(x, values, ...) {
+
+ if (is.matrix(values)) {
+ if (ncol(values) == x at ncols & nrow(values) == x at 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')
+ }
+ }
+
+ if (!is.vector(values)) {
+ if (is.factor(values)) {
+ levs <- levels(values)
+ values <- as.integer(values)
+ x at data@isfactor <- TRUE
+ x at data@attributes <- list(data.frame(ID=1:length(levs), VALUE=levs))
+ } else {
+ stop('values must be a vector')
+ }
+ }
+ if (!(is.numeric(values) | is.integer(values) | is.logical(values))) {
+ stop('values must be numeric, integer, logical or factor') }
+
+
+ if (length(values) == 1) {
+ values <- rep(values, ncell(x))
+ }
+
+ if (length(values) == ncell(x)) {
+ x at data@inmemory <- TRUE
+ x at data@fromdisk <- FALSE
+ x at file@name <- ""
+ x at file@driver <- ""
+ x at 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'),
+ 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 at file@name <- ""
+ x at file@driver <- ""
+ x at data@inmemory <- TRUE
+ x at data@fromdisk <- FALSE
+ x at data@nlayers <- ncol(values)
+ cn <- colnames(values)
+ if (!is.null(cn)) {
+ names(x) <- cn
+ }
+ x at data@values <- values
+ x <- setMinMax(x)
+
+ } else {
+ stop("the size of 'values' is not correct")
+ }
+
+ } else {
+ nlx <- nlayers(x)
+ if (nlx==0) {
+ x at 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 at data@values <- cbind(x at data@values, values)
+ x at data@nlayers <- as.integer(x at data@nlayers + 1)
+ } else {
+ x at data@values[,layer] <- values
+ }
+ rge <- range(values, na.rm=TRUE)
+ x at data@min[layer] <- rge[1]
+ x at data@max[layer] <- rge[2]
+ } else {
+
+ if (canProcessInMemory(x)) {
+ if (hasValues(x)) {
+ x <- readAll(x)
+ x at file@name <- ""
+ x at file@driver <- ""
+ x at data@inmemory <- TRUE
+ x at data@fromdisk <- FALSE
+ } else {
+ x at data@values <- matrix(NA, nrow=ncell(x), ncol=nlx)
+ x at data@min <- rep(Inf, nlx)
+ x at data@max <- rep(-Inf, nlx)
+ x at data@haveminmax <- TRUE
+ x at data@inmemory <- TRUE
+ }
+ if (bind) {
+ x at data@values <- cbind(x at data@values, values)
+ x at data@nlayers <- as.integer(x at data@nlayers + 1)
+ } else {
+ x at data@values[,layer] <- values
+ }
+ rge <- range(values, na.rm=TRUE)
+ x at data@min[layer] <- rge[1]
+ x at data@max[layer] <- rge[2]
+
+ } else {
+
+ tr <- blockSize(x)
+ pb <- pbCreate(tr$n, label='setValues',)
+ r <- brick(x)
+ nc <- ncol(x)
+ if (bind) {
+ r at data@nlayers <- as.integer(r at 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 at index) == length(values))
+ } else {
+ stopifnot(is.vector(index))
+ stopifnot(length(index) == length(values))
+ stopifnot(all(index > 0 | index <= ncell(x)))
+ x at index <- index
+ }
+ x at data@inmemory <- TRUE
+ x at data@fromdisk <- FALSE
+ x at file@name <- ""
+ x at file@driver <- ""
+ x at data@values <- values
+ x <- setMinMax(x)
+ return(x)
+ }
+)
+
diff --git a/R/setZ.R b/R/setZ.R
new file mode 100644
index 0000000..c2fd3e1
--- /dev/null
+++ b/R/setZ.R
@@ -0,0 +1,32 @@
+# Robert J. Hijmans
+# June 2011
+# Version 1.0
+# Licence GPL v3
+
+
+
+setZ <- function(x, z, name='time') {
+ if (is.null(z)) {
+ x at z <- list()
+ return(x)
+ }
+ if (is.list(z)) {
+ z <- unlist(z)
+ }
+ stopifnot(length(z) == nlayers(x))
+ z <- list(z)
+ names(z) <- name[1]
+ x at z <- z
+ x
+}
+
+
+getZ <- function(x) {
+ if (length(x at z) == 0) {
+ return(NULL)
+ } else {
+ return(x at z[[1]])
+ }
+}
+
+
diff --git a/R/shift.R b/R/shift.R
new file mode 100644
index 0000000..79888cf
--- /dev/null
+++ b/R/shift.R
@@ -0,0 +1,74 @@
+# Author: Robert J. Hijmans
+# Date : January 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("shift")) {
+ setGeneric("shift", function(object, ...)
+ standardGeneric("shift"))
+}
+
+
+setMethod('shift', signature(object='Raster'),
+ function(object, x=0, y=0, filename='', ...) {
+ x <- as.numeric(x[1])
+ y <- as.numeric(y[1])
+ stopifnot(!is.na(x) | !is.na(y))
+ e <- object at extent
+ e at xmin <- e at xmin + x
+ e at ymin <- e at ymin + y
+ e at xmax <- e at xmax + x
+ e at ymax <- e at ymax + y
+ object at extent <- e
+ if (filename != '') {
+ object <- writeRaster(object, filename=filename, ...)
+ }
+ if (inherits(object, 'RasterStack')) {
+ object at layers <- sapply(object at layers, function(x){ extent(x) <- e; x})
+ }
+ return(object)
+ }
+)
+
+
+
+setMethod('shift', signature(object='SpatialPolygons'),
+ function(object, x=0, y=0, ...) {
+ a <- data.frame(geom(object))
+ a$x <- a$x + x
+ a$y <- a$y + y
+ a <- as(a, 'SpatialPolygons')
+ crs(a) <- crs(object)
+ if (inherits(object, 'SpatialPolygonsDataFrame')) {
+ a <- SpatialPolygonsDataFrame(a, object at data, match.ID = FALSE)
+ }
+ return(a)
+ }
+)
+
+
+
+setMethod('shift', signature(object='SpatialLines'),
+ function(object, x=0, y=0, ...) {
+ a <- data.frame(geom(object))
+ a$x <- a$x + x
+ a$y <- a$y + y
+ a <- as(a, 'SpatialLines')
+ crs(a) <- crs(object)
+ if (inherits(object, 'SpatialLinesDataFrame')) {
+ a <- SpatialLinesDataFrame(a, object at data, match.ID = FALSE)
+ }
+ return(a)
+ }
+)
+
+
+setMethod('shift', signature(object='SpatialPoints'),
+ function(object, x=0, y=0, ...) {
+ object at coords[,1] <- object at coords[,1] + x
+ object at coords[,2] <- object at coords[,2] + y
+ return(object)
+ }
+)
+
diff --git a/R/show.R b/R/show.R
new file mode 100644
index 0000000..11abd15
--- /dev/null
+++ b/R/show.R
@@ -0,0 +1,300 @@
+# 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 at extent@xmin, ', ', object at extent@xmax, ', ', object at extent@ymin, ', ', object at extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="")
+ cat('coord. ref. :' , projection(object, TRUE), '\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 at extent@xmin, ', ', object at extent@xmax, ', ', object at extent@ymin, ', ', object at extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="")
+ cat('coord. ref. :' , projection(object, TRUE), '\n')
+
+
+ if (hasValues(object)) {
+ fd <- object at data@fromdisk
+ if (fd) {
+ cat('data source :', filename(object), '\n')
+ } else {
+ cat('data source : in memory\n')
+ }
+ cat('names :', names(object), '\n')
+ if (object at data@haveminmax) {
+ cat('values : ', minValue(object), ', ', maxValue(object), ' (min, max)\n', sep="")
+ }
+ }
+
+
+ if (is.factor(object)) {
+
+ x <- object at 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 at z)
+ if (is.null(name)) name <- 'z-value'
+ name <- paste(sprintf("%-12s", name), ':', sep='')
+ cat(name, as.character(z[1]), '\n')
+ }
+
+ if (object at file@driver == 'netcdf') {
+ z <- attr(object at data, 'zvar')
+ if (!is.null(z)) { cat('zvar :', z, '\n') }
+ z <- attr(object at 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 at extent@xmin, ', ', object at extent@xmax, ', ', object at extent@ymin, ', ', object at extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="")
+ cat ('coord. ref. :' , projection(object, TRUE), '\n')
+
+ ln <- names(object)
+ if (nl > mnr) {
+ ln <- c(ln[1:mnr], '...')
+ }
+
+ if (hasValues(object)) {
+ fd <- object at data@fromdisk
+ if (fd) {
+ cat('data source :', filename(object), '\n')
+ } else {
+ cat('data source : in memory\n')
+ }
+
+ if (object at 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 at z)
+ if (is.null(name)) name <- 'z-value'
+ name <- paste(sprintf("%-12s", 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 at file@driver == 'netcdf') {
+ z <- attr(object at data, 'zvar')
+ if (!is.null(z)) { cat('varname :', z, '\n') }
+ z <- attr(object at 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 at extent@xmin, ', ', object at extent@xmax, ', ', object at extent@ymin, ', ', object at extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="")
+ cat ('coord. ref. :' , projection(object, TRUE), '\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 at 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="" )
+ }
+)
diff --git a/R/shp.R b/R/shp.R
new file mode 100644
index 0000000..cfd9cc3
--- /dev/null
+++ b/R/shp.R
@@ -0,0 +1,74 @@
+# 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 <- SpatialPolygonsDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE)
+ } else if (inherits(x, 'SpatialLines')) {
+ x <- SpatialLinesDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE)
+ } else if (inherits(x, 'SpatialPoints')) {
+ x <- 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, ...)
+ }
+)
+
+
diff --git a/R/simplifyPols.R b/R/simplifyPols.R
new file mode 100644
index 0000000..9cdf835
--- /dev/null
+++ b/R/simplifyPols.R
@@ -0,0 +1,26 @@
+
+
+.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')
+ proj4string(out) <- proj4string(p)
+ if (.hasSlot(p, 'data')) {
+ out <- SpatialPolygonsDataFrame(out, p at data)
+ }
+ out
+}
+
diff --git a/R/slopeAspect.R b/R/slopeAspect.R
new file mode 100644
index 0000000..759f905
--- /dev/null
+++ b/R/slopeAspect.R
@@ -0,0 +1,107 @@
+# 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)
+}
+
diff --git a/R/speasy.R b/R/speasy.R
new file mode 100644
index 0000000..dcf5bbc
--- /dev/null
+++ b/R/speasy.R
@@ -0,0 +1,58 @@
+# 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=NA) {
+ x <- c(list(x), list(...))
+ x <- rapply(x, Line, how='replace')
+ x <- lapply(1:length(x), function(i) Lines(x[[i]], as.character(i)))
+ x <- SpatialLines(x)
+
+ if (!is.null(attr)) {
+ if (nrow(attr) == length(x)) {
+ x <- 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=NA) {
+ x <- c(list(x), list(...))
+ x <- rapply(x, Polygon, how='replace')
+
+ x <- lapply(1:length(x), function(i) {
+ if (length(x[[i]]) == 1) {
+ Polygons(x[i], as.character(i))
+ } else {
+ Polygons(x[[i]], as.character(i))
+ }
+ })
+
+ x <- SpatialPolygons(x)
+ if (!is.null(attr)) {
+ if (nrow(attr) == length(x)) {
+ x <- 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
+}
diff --git a/R/spplot.R b/R/spplot.R
new file mode 100644
index 0000000..8d669c0
--- /dev/null
+++ b/R/spplot.R
@@ -0,0 +1,56 @@
+# 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) {
+ obj[obj < zlim[1] | obj > zlim[2]] <- NA
+ }
+ }
+ obj <- as(obj, 'SpatialGridDataFrame')
+ #obj at data <- obj at data[, ncol(obj at 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 <- SpatialPointsDataFrame(obj, data.frame(ID=1:length(obj)))
+ spplot(obj, ...)
+})
+
+setMethod('spplot', signature(obj='SpatialPolygons'),
+function(obj, ...) {
+ obj <- SpatialPolygonsDataFrame(obj, data.frame(ID=1:length(obj)))
+ spplot(obj, ...)
+})
+
+setMethod('spplot', signature(obj='SpatialLines'),
+function(obj, ...) {
+ obj <- SpatialLinesDataFrame(obj, data.frame(ID=1:length(obj)))
+ spplot(obj, ...)
+})
+
+
+setMethod("lines", signature(x='SpatialPolygons'),
+function(x, ...) {
+ x <- as(x, 'SpatialLines')
+ lines(x, ...)
+}
+)
+
diff --git a/R/stack.R b/R/stack.R
new file mode 100644
index 0000000..397dddc
--- /dev/null
+++ b/R/stack.R
@@ -0,0 +1,245 @@
+# 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) {
+
+ rlist <- c(x, list(...))
+
+ if ( varname != "") {
+ if (length(rlist) == 1) {
+ return(.stackCDF(x, varname=varname, bands=bands))
+ } else {
+ s <- stack(sapply(rlist, function(x) raster(x, varname=varname, bands=bands)))
+ }
+
+ } 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 at nrows <- x[[1]]@nrows
+ s at ncols <- x[[1]]@ncols
+ s at extent <- x[[1]]@extent
+ s at crs <- x[[1]]@crs
+ return(s)
+ }
+ warning('RasterLayer objects without cell values were removed')
+ x <- x[hd]
+ }
+ if (length(x) > 1) {
+ compareRaster(x)
+ }
+ s <- methods::new("RasterStack")
+ s at nrows <- x[[1]]@nrows
+ s at ncols <- x[[1]]@ncols
+ s at extent <- x[[1]]@extent
+ s at crs <- x[[1]]@crs
+ s at 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 at nrows <- r at nrows
+ x at ncols <- r at ncols
+ x at extent <- r at extent
+ x at crs <- r at crs
+ if(rotated(r)) {
+ x at rotated = r at rotated
+ x at rotation = r at 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')
+ }
+)
diff --git a/R/stackApply.R b/R/stackApply.R
new file mode 100644
index 0000000..b97229b
--- /dev/null
+++ b/R/stackApply.R
@@ -0,0 +1,104 @@
+# 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 at data@nlayers <- nlout
+ } else {
+ out <- raster(x)
+ }
+ names(out) <- layernames
+ filename <- trim(filename)
+
+ rowcalc <- FALSE
+ fun <- .makeTextFun(fun)
+ if (class(fun) == '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==uin[i], drop=FALSE], na.rm=na.rm))
+ } else {
+ v <- lapply(uin, function(i, ...) apply(a[, ind==uin[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)
+}
+
+
+
diff --git a/R/stackFile.R b/R/stackFile.R
new file mode 100644
index 0000000..d63f1fc
--- /dev/null
+++ b/R/stackFile.R
@@ -0,0 +1,56 @@
+# 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 at 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 at filename <- stackfile
+ return(s)
+}
+
+stackSave <- function(x, filename) {
+ filename <- trim(filename)
+ if (filename == "") {
+ stop('Provide a non empty filename.')
+ }
+
+ info <- t( sapply(x at layers, function(i) c(i at file@name, i at file@nbands, i at 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 at filename <- filename
+ return(x)
+}
+
diff --git a/R/stackQuick.R b/R/stackQuick.R
new file mode 100644
index 0000000..a5fa577
--- /dev/null
+++ b/R/stackQuick.R
@@ -0,0 +1,123 @@
+# 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 at data@haveminmax <- FALSE
+ r at file@nbands <- nbands[1]
+ r at data@band <- band[1]
+
+ ln <- extension(basename(unlist(files)), '')
+ s <- stack(r)
+ s at layers <- sapply(1:length(files),
+ function(i){
+ r at file@name <- files[[i]]
+ r at file@nbands <- nbands[i]
+ r at data@band <- band[i]
+ r at 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 at 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 at layers <- sapply( bands, function(i) {
+ r at data@values <- b at data@values[,i]
+ r at data@names <- ln[i]
+ r at data@min <- mn[i]
+ r at data@max <- mx[i]
+ r
+ })
+ } else {
+ s at layers <- sapply(bands, function(i){
+ r at data@values <- b at data@values[,i]
+ r at data@names <- ln[i]
+ r
+ })
+ }
+ }
+ return(s)
+
+ }
+
+
+
+ r <- raster(b, bands[1])
+ s <- stack(r)
+ if (length(bands) > 1) {
+
+ if (havemnmx) {
+ s at layers <- sapply(bands, function(i){
+ r at data@band <- i
+ r at data@names <- ln[i]
+ r at data@min <- mn[i]
+ r at data@max <- mx[i]
+ r
+ })
+ } else {
+ s at layers <- sapply(bands, function(i){
+ r at data@band <- i
+ r at data@names <- ln[i]
+ r
+ })
+ }
+ }
+ s
+}
diff --git a/R/stackSelect.R b/R/stackSelect.R
new file mode 100644
index 0000000..6b277e9
--- /dev/null
+++ b/R/stackSelect.R
@@ -0,0 +1,84 @@
+# 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 at 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)
+} )
+
diff --git a/R/stretch.R b/R/stretch.R
new file mode 100644
index 0000000..7f21514
--- /dev/null
+++ b/R/stretch.R
@@ -0,0 +1,95 @@
+# 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
+}
+
+
+# This one works for multilayer objects
+# Linear stretch between min and max values
+stretch <- function(x, minv=0, maxv=255, minq=0, maxq=1, filename='', ...) {
+ minq <- max(0,minq)
+ maxq <- min(1,maxq)
+ stopifnot(minq < maxq)
+ maxv <- maxv[1]
+ minv <- minv[1]
+ stopifnot(maxv > minv)
+ nl <- nlayers(x)
+ q <- quantile(x, c(minq, maxq), na.rm=TRUE)
+
+ if (nl == 1) {
+ out <- raster(x)
+ if (canProcessInMemory(out)) {
+ x <- getValues(x)
+ x <- (maxv*(x-q[1]))/(q[2]-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, ...)
+ mult <- maxv / (q[2]-q[1])
+ for (i in 1:tr$n) {
+ v <- getValues(x, tr$row[i], tr$nrows[i])
+ v <- mult*(v-q[1])
+ v[v < 0] <- 0
+ v[v > maxv] <- maxv
+ out <- writeValues(out, v, tr$row[i])
+ }
+ out <- writeStop(out)
+ }
+ } else {
+ out <- brick(x, values=FALSE)
+ mxrnge <- maxv/(q[,2]-q[,1])
+ fun <- function(x) mxrnge*(x-q[,1])
+ if (canProcessInMemory(out)) {
+ x <- getValues(x)
+ x <- t(apply(x, 1, fun))
+ x[x < 0] <- 0
+ 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(apply(v, 1, fun))
+ v[v < 0] <- 0
+ v[v > maxv] <- maxv
+ out <- writeValues(out, v, tr$row[1])
+ }
+ out <- writeStop(out)
+ }
+ }
+ return(out)
+}
+
diff --git a/R/subs.R b/R/subs.R
new file mode 100644
index 0000000..ca70684
--- /dev/null
+++ b/R/subs.R
@@ -0,0 +1,173 @@
+# 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)
+
+ y <- y[ , c(by, which)]
+
+ 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') {
+ w <- getOption('warn')
+ options('warn'=-1)
+ tmp <- as.numeric(y[,i])
+ options('warn'= w)
+ 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
+
+ filename <- trim(filename)
+
+ if (canProcessInMemory(x, 3)) {
+ if (any(hasfactor)) {
+ out at data@isfactor <- hasfactor
+ out at 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 at data@isfactor <- TRUE
+ out at data@attributes <- levs
+ }
+ out <- writeStop(out)
+ return(out)
+ }
+ }
+)
+
+
+
diff --git a/R/subset.R b/R/subset.R
new file mode 100644
index 0000000..586408d
--- /dev/null
+++ b/R/subset.R
@@ -0,0 +1,134 @@
+# Authors: Robert J. Hijmans
+# Date : August 2009
+# Version 1.0
+# Licence GPL v3
+
+
+
+if (!isGeneric('subset')) {
+ setGeneric('subset', function(x, ...)
+ standardGeneric('subset'))
+}
+
+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(subset) == 1 & drop) {
+ x <- x at layers[[subset]]
+ } else {
+ x at layers <- x at layers[subset]
+ if (length(x at z)>0) {
+ x at z <- lapply(x at z, function(x) x[subset])
+ }
+ }
+ 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)
+ }
+
+
+
+ #if (nl==1) {return(x)} # this does not drop
+
+ # probably not needed any more, due to removing
+ # the filename function below
+ #varname <- attr(x at data, "zvar")
+ #if (is.null(varname)) {
+ # varname <- ""
+ #}
+
+ # these values may have been changed
+ nav <- NAvalue(x)
+ e <- extent(x)
+
+ 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)
+ }
+ extent(x) <- e
+ NAvalue(x) <- nav
+ return(x)
+ }
+
+ if (hasValues(x)) {
+ x at data@values <- x at data@values[, subset, drop=FALSE]
+ x at data@min <- x at data@min[subset]
+ x at data@max <- x at data@max[subset]
+ }
+ x at data@names <- x at data@names[subset]
+ if (length(x at z) > 0) {
+ x at z[[1]] <- x at z[[1]][subset]
+ }
+ x at data@nlayers <- as.integer(length(subset))
+ f <- is.factor(x)
+ if (any(f)) {
+ x at data@attributes <- x at data@attributes[subset]
+ x at data@isfactor <- x at data@isfactor[subset]
+ }
+ }
+ if (filename != '') {
+ x <- writeRaster(x, filename, ...)
+ }
+ x
+} )
+
+
diff --git a/R/summary-methods.R b/R/summary-methods.R
new file mode 100644
index 0000000..e4db650
--- /dev/null
+++ b/R/summary-methods.R
@@ -0,0 +1,98 @@
+# 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)
+ }
+)
+
+
diff --git a/R/summary.R b/R/summary.R
new file mode 100644
index 0000000..4aeb3a5
--- /dev/null
+++ b/R/summary.R
@@ -0,0 +1,79 @@
+# 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( object at data@values, na.rm=TRUE) )
+ sm <- c(sm, sum(is.na( object at data@values) ))
+
+ } else if ( fromDisk(object) ) {
+ if (ncell(object) > maxsamp) {
+ v <- sampleRandom(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=''))
+ nas <- round(sum(is.na(v)) * ncell(object) / maxsamp)
+ } 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) ) {
+
+ sm <- apply(object at data@values, 2, quantile, na.rm=TRUE)
+ nas <- apply(is.na(object at 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)
+ }
+)
+
diff --git a/R/symdif.R b/R/symdif.R
new file mode 100644
index 0000000..f9a9a66
--- /dev/null
+++ b/R/symdif.R
@@ -0,0 +1,37 @@
+# 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, ...) {
+ stopifnot(requireNamespace("rgeos"))
+
+ haswarned <- FALSE
+
+ yy <- list(y, ...)
+ for (y in yy) {
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ if (!haswarned) {
+ warning('non identical CRS')
+ haswarned <- TRUE
+ }
+ y at proj4string <- x at proj4string
+ }
+ if (rgeos::gIntersects(x, y)) {
+ part1 <- erase(x, y)
+ part2 <- erase(y, x)
+ x <- bind(part1, part2)
+ }
+ }
+ x
+}
+)
+
diff --git a/R/terrain.R b/R/terrain.R
new file mode 100644
index 0000000..6e2414b
--- /dev/null
+++ b/R/terrain.R
@@ -0,0 +1,143 @@
+# Author: Robert J. Hijmans
+# Date : February 2011
+# Version 1.0
+# Licence GPL v3
+
+
+terrain <- 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 <- .Call('terrain', as.double(values(x)), as.integer(dim(out)), rs, un, nopt, lonlat, y, NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('terrain', as.double(v), as.integer(c(tr$nrows[1]+1, nc)), rs, un, nopt, lonlat, y, NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('terrain', as.double(v), as.integer(c(tr$nrows[i]+2, nc)), rs, un, nopt, lonlat, y, NAOK=TRUE, PACKAGE='raster')
+ 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 <- .Call('terrain', as.double(v), as.integer(c(tr$nrows[i]+1, nc)), rs, un, nopt, lonlat, y, NAOK=TRUE, PACKAGE='raster')
+ 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')
+
+
\ No newline at end of file
diff --git a/R/text.R b/R/text.R
new file mode 100644
index 0000000..5b29b2d
--- /dev/null
+++ b/R/text.R
@@ -0,0 +1,133 @@
+# Author: Robert J. Hijmans
+# Date : August 2010
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("text")) {
+ setGeneric("text", function(x, ...)
+ standardGeneric("text"))
+}
+
+
+.haloText <- function(x, y=NULL, labels, col='black', hc='white', hw=0.1, ... ) {
+# with minor modifications from
+#From: Greg Snow <Greg.Snow <at> imail.org>
+#Subject: Re: Text Contrast in a Plot
+#Newsgroups: gmane.comp.lang.r.general
+#Date: 2009-04-24 21:23:25 GMT
+
+ xy <- xy.coords(x,y)
+ xo <- hw * strwidth('A')
+ yo <- hw * 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 at data[, labels]
+ }
+ } else {
+ if (length(x)> 1) {
+ labels <- 1:length(x)
+ }
+ }
+ labels <- as.character(labels)
+ }
+
+ xy <- coordinates(x)
+ 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 at data[, labels]
+ }
+ } else {
+ if (length(x)> 1) {
+ labels <- 1:length(x)
+ }
+ }
+ labels <- as.character(labels)
+ }
+
+ xy <- coordinates(x)
+ if (halo) {
+ .haloText(xy[,1], xy[,2], labels, ...)
+ } else {
+ text(xy[,1], xy[,2], labels, ...)
+ }
+ }
+)
+
diff --git a/R/tmpFile.R b/R/tmpFile.R
new file mode 100644
index 0000000..b13ba9a
--- /dev/null
+++ b/R/tmpFile.R
@@ -0,0 +1,140 @@
+# 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")
+
+ dif[is.na(dif)] <- h + 1
+ f <- f[dif > h]
+ if (length(f) > 1) {
+ 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)
+}
+
diff --git a/R/tmppath.R b/R/tmppath.R
new file mode 100644
index 0000000..30dbea2
--- /dev/null
+++ b/R/tmppath.R
@@ -0,0 +1,24 @@
+# Author: Shaun Walbridge
+# prevent directory colisions on multiuser machines by generating a unique dir
+
+.tmppath <- function() {
+
+# default temp files now inside the session tempdir. Therefore no need to add username etc.
+ return( file.path(tempdir(), 'raster', '/') )
+
+
+# when Sys.info is NULL, use this default
+ extension <- 'user'
+ s <- Sys.info()
+ if (!is.null(s)) {
+ # get userid from system, to generate temporary directory name
+ user <- s[["user"]]
+ if (!is.null(user)) {
+ extension <- user
+ }
+ }
+# d <- paste(dirname(tempdir()), '/R_raster_tmp/', extension, '/', sep="")
+ d <- paste(dirname(tempdir()), '/R_raster_', extension, '/', sep="")
+ return(d)
+}
+
diff --git a/R/transpose.R b/R/transpose.R
new file mode 100644
index 0000000..d113146
--- /dev/null
+++ b/R/transpose.R
@@ -0,0 +1,80 @@
+# Author: Robert J. Hijmans
+# Date : December 2010
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("t")) {
+ setGeneric("t", function(x)
+ standardGeneric("t"))
+}
+
+
+setMethod('t', signature(x='RasterLayer'),
+ function(x) {
+ r <- raster(x)
+ e <- eold <- extent(r)
+ e at xmin <- eold at ymin
+ e at xmax <- eold at ymax
+ e at ymin <- eold at xmin
+ e at ymax <- eold at 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 at 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 at xmin <- eold at ymin
+ e at xmax <- eold at ymax
+ e at ymin <- eold at xmin
+ e at ymax <- eold at 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 at 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)
+ }
+ }
+)
+
diff --git a/R/trim.R b/R/trim.R
new file mode 100644
index 0000000..b3b0a09
--- /dev/null
+++ b/R/trim.R
@@ -0,0 +1,113 @@
+# Author: Robert J. Hijmans
+# Date : December 2009
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("trim")) {
+ setGeneric("trim", function(x, ...)
+ standardGeneric("trim"))
+}
+
+
+setMethod('trim', signature(x='character'),
+ function(x, ...) {
+ 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"
+
+setMethod('trim', signature(x='Raster'),
+function(x, padding=0, values=NA, filename='', ...) {
+
+
+ filename <- trim(filename)
+
+ 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:1) {
+ 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:1) {
+ 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, ...) )
+}
+)
+
diff --git a/R/union.R b/R/union.R
new file mode 100644
index 0000000..49e745f
--- /dev/null
+++ b/R/union.R
@@ -0,0 +1,32 @@
+# Author: Robert J. Hijmans
+# Date : December 2011
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("union")) {
+ setGeneric("union", function(x, y)
+ standardGeneric("union"))
+}
+
+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 at xmin <- min(e at xmin, e2 at xmin)
+ e at xmax <- max(e at xmax, e2 at xmax)
+ e at ymin <- min(e at ymin, e2 at ymin)
+ e at ymax <- max(e at ymax, e2 at ymax)
+ }
+ return(e)
+}
+
diff --git a/R/union_sp.R b/R/union_sp.R
new file mode 100644
index 0000000..46aec04
--- /dev/null
+++ b/R/union_sp.R
@@ -0,0 +1,94 @@
+# Author: Robert J. Hijmans
+# Date : November 2011
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("union")) {
+ setGeneric("union", function(x, y)
+ standardGeneric("union"))
+}
+
+
+setMethod('union', signature(x='SpatialPolygons', y='SpatialPolygons'),
+function(x, y) {
+
+ stopifnot(requireNamespace("rgeos"))
+
+ x <- spChFIDs(x, as.character(1:length(x)))
+ y <- spChFIDs(y, as.character(1:length(y)))
+
+ if (! identical(proj4string(x), proj4string(y)) ) {
+ warning('non identical CRS')
+ y at proj4string <- x at proj4string
+ }
+
+ 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 at data), colnames(y at data)))
+ colnames(x at data) <- nms[1:ncol(x at data)]
+ colnames(y at data) <- nms[(ncol(x at 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]]
+ }
+ }
+
+ x
+}
+)
+
+
+
+
+setMethod('union', signature(x='SpatialPolygons', y='missing'),
+function(x, y) {
+ stopifnot(requireNamespace("rgeos"))
+ n <- length(x)
+ if (n < 2) {
+ return(x)
+ }
+ if (.hasSlot(x, 'data')) {
+ x <- as(x, 'SpatialPolygons')
+ }
+
+ x <- spChFIDs(x, as.character(1:length(x)))
+ x <- 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 at data[!is.na(u at data)] <- 1
+ u at data[is.na(u at data)] <- 0
+ u$count <- rowSums(u at data)
+
+ u
+}
+)
+
+
diff --git a/R/unique.R b/R/unique.R
new file mode 100644
index 0000000..5d7cc0d
--- /dev/null
+++ b/R/unique.R
@@ -0,0 +1,95 @@
+# Author: Robert J. Hijmans
+# Date : December 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("unique")) {
+ setGeneric("unique", function(x, incomparables=FALSE, ...)
+ standardGeneric("unique"))
+}
+
+
+setMethod('unique', signature(x='RasterLayer', incomparables='missing'),
+function(x, incomparables=FALSE, ...) {
+
+
+ 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 at data@values)
+ return(sort(x))
+ } else {
+ u1 <- vector()
+ u2 <- vector()
+
+ tr <- blockSize(x, n=2)
+ pb <- pbCreate(tr$n, label='unique', ...)
+
+ for (i in 1:tr$n) {
+ u1 <- unique( c(u1, getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i])) )
+ if (length(u1) > 10000 ) {
+ u2 <- unique(c(u1, u2))
+ u1 <- vector()
+ }
+ pbStep(pb, i)
+ }
+ pbClose(pb)
+ return(sort(unique(c(u1, u2))))
+ }
+}
+)
+
+
+setMethod('unique', signature(x='RasterStackBrick', incomparables='missing'),
+function(x, incomparables=FALSE, ...) {
+
+
+ if (! inMemory(x) ) {
+ if (canProcessInMemory(x, 2)) {
+ x <- readAll(x)
+ }
+ }
+
+ if ( inMemory(x) ) {
+
+ x <- unique(getValues(x))
+ if (is.list(x)) {
+ for (i in 1:length(x)) {
+ x[[i]] <- sort(x[[i]])
+ }
+ } else {
+ xx <- vector(length=ncol(x), mode='list')
+ for (i in 1:ncol(x)) {
+ xx[[i]] <- sort(x[,i])
+ }
+ }
+ return(x)
+
+ } else {
+ nl <- nlayers(x)
+ un <- list(length=nl, mode='list')
+
+ tr <- blockSize(x, n=2)
+ pb <- pbCreate(tr$n, label='unique', ...)
+
+ 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))
+ pbStep(pb, i)
+ }
+ pbClose(pb)
+ return(un)
+ }
+}
+)
+
diff --git a/R/unstack.R b/R/unstack.R
new file mode 100644
index 0000000..37916f6
--- /dev/null
+++ b/R/unstack.R
@@ -0,0 +1,26 @@
+# 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 at layers)
+} )
+
+
+setMethod("unstack", signature(x='RasterBrick'),
+function(x) {
+ if (nlayers(x) == 0) {
+ list()
+ } else {
+ lapply(1:nlayers(x), function(i) raster(x, i))
+ }
+} )
+
diff --git a/R/update.R b/R/update.R
new file mode 100644
index 0000000..c2cd0aa
--- /dev/null
+++ b/R/update.R
@@ -0,0 +1,553 @@
+# 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 at file@driver
+ if (.isNativeDriver(driver)) {
+ stopifnot(object at 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 at file@datanotation
+ dtype <- substr(datatype, 1, 3)
+ v <- .checkData(object, v, cell, dtype)
+
+ setminmax <- FALSE
+ if (object at 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 at file@datanotation
+ dtype <- substr(datatype, 1, 3)
+ v <- .checkData(object, v, cell, dtype)
+
+ setminmax <- FALSE
+ if (object at data@haveminmax) {
+ setminmax <- FALSE
+ if (object at data@haveminmax) {
+ object <- .updateMinMax(object, v, cell, band)
+ setminmax <- object[[2]]
+ object <- object[[1]]
+ }
+ }
+
+ driver <- object at 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 at 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 at data@min
+ maxv <- object at 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 at file@nodatavalue)
+ } else {
+ v[] <- as.numeric(v)
+ }
+
+ if (is.matrix(v)) {
+ for (r in 1:nrow(v)) {
+ pos <- (cell-1) * object at file@dsize
+ seek(object at file@con, pos, rw='w')
+ writeBin(v[r,], object at file@con, size=object at file@dsize )
+ cell <- cell + object at ncols
+ }
+
+ } else {
+ if (length(cell) == 1) {
+ pos <- (cell-1) * object at file@dsize
+ seek(object at file@con, pos, rw='w')
+ writeBin(v, object at file@con, size=object at file@dsize )
+ } else {
+ for (i in 1:length(cell)) {
+ pos <- (cell[i]-1) * object at file@dsize
+ seek(object at file@con, pos, rw='w')
+ writeBin(v[i], object at file@con, size=object at file@dsize )
+ }
+ }
+ }
+
+ object at data@min <- minv
+ object at data@max <- maxv
+ object at data@haveminmax <- TRUE
+ object <- writeStop(object)
+ if (object at data@min == Inf) {
+ object at 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 at file@toptobottom)
+
+ bandorder <- object at file@bandorder
+
+ getoff <- function(object, cell) {
+ if (bandorder == 'BIL') {
+ rc <- rowColFromCell(object, cell) - 1
+ off <- ((nbands(object) * (rc[1]) + (band-1)) * object at ncols + rc[2] ) * object at file@dsize
+ } else if (bandorder == 'BIP') {
+ off <- (nbands(object) * (cell-1) + band-1) * object at file@dsize
+ } else if (bandorder == 'BSQ') {
+ off <- (ncell(object) * (band-1) + (cell-1)) * object at file@dsize
+ } else {
+ stop("unknown band order")
+ }
+ return(off)
+ }
+
+ minv <- object at data@min
+ maxv <- object at 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 at 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 at file@con, pos, rw='w')
+ writeBin(v[r,c], object at file@con, size=object at file@dsize )
+ }
+ cell <- cell + object at ncols
+ }
+ } else {
+ for (r in 1:nrow(v)) {
+ pos <- getoff(object, cell)
+ seek(object at file@con, pos, rw='w')
+ writeBin(v[r,], object at file@con, size=object at file@dsize )
+ cell <- cell + object at ncols
+ }
+ }
+
+ } else {
+ if (length(cell) == 1) {
+ if (bandorder == 'BSQ') {
+ pos <- getoff(object, cell)
+ seek(object at file@con, pos, rw='w')
+ writeBin(v, object at file@con, size=object at file@dsize )
+ } else if (bandorder == 'BIP') {
+ for (i in 1:length(v)) {
+ pos <- getoff(object, cell+i-1)
+ seek(object at file@con, pos, rw='w')
+ writeBin(v[i], object at file@con, size=object at 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 at file@con, pos, rw='w')
+ writeBin(v, object at file@con, size=object at file@dsize )
+ } else {
+ pos <- getoff(object, cellFromRowCol(object, rows[1], cols[1]))
+ seek(object at file@con, pos, rw='w')
+ nc <- object at ncols - cols[1]
+ writeBin(v[1:nc], object at file@con, size=object at file@dsize )
+ v <- v[-(1:nc)]
+ if (nr > 2) {
+ nc <- object at ncols
+ for (i in 3:(nr-1)) {
+ pos <- getoff(object, cellFromRowCol(object, rows[i], 1))
+ seek(object at file@con, pos, rw='w')
+ writeBin(v[1:nc], object at file@con, size=object at file@dsize )
+ v <- v[-(1:nc)]
+ }
+ if (length(v) > 0) {
+ pos <- getoff(object, cellFromRowCol(object, rows[nr], 1))
+ seek(object at file@con, pos, rw='w')
+ writeBin(v, object at file@con, size=object at file@dsize )
+ }
+ }
+ }
+ }
+ } else {
+ for (i in 1:length(cell)) {
+ pos <- getoff(object, cell[i])
+ seek(object at file@con, pos, rw='w')
+ writeBin(v[i], object at file@con, size=object at file@dsize )
+ }
+ }
+ }
+
+ object at data@min <- minv
+ object at data@max <- maxv
+ object at data@haveminmax <- TRUE
+ object <- writeStop(object)
+ if (object at data@min[band] == Inf) {
+ object at 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 at file@name, write=TRUE)
+ on.exit( ncdf4::nc_close(nc) )
+
+ zvar <- object at 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 at 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 at data@level, band), count=c(length(cols), 1, 1, 1)) )
+ }
+ } else {
+ offset <- c(cols[1], rows[1])
+ ncols <- object at 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 at 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 at 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 at 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 at 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 at 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 at 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 at ncols
+ rgdal::putRasterData(gdal, t(matrix(v[1:n], ncol=object at 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 at data@min, object at 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 at data@min[band]) {
+ newmin <- TRUE
+ }
+ if (maxv > object at data@max[band]) {
+ newmax <- TRUE
+ }
+ }
+ if (newmin & newmax) {
+ object at data@min[band] <- minv
+ object at 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 at data@min[band]) {
+ lostmin <- FALSE
+ } else {
+ lostmin <- TRUE
+ }
+ if (oldmax < object at data@max[band]) {
+ lostmax <- FALSE
+ } else {
+ lostmax <- TRUE
+ }
+ } else {
+ lostmin <- FALSE
+ lostmax <- FALSE
+ }
+
+ if (! (lostmin | lostmax) ) {
+ if (newmin | newmax) {
+ object at data@min <- min(object at data@min[band], minv)
+ object at data@max <- max(object at data@max[band], maxv)
+ setminmax <- TRUE
+ }
+ } else if ((lostmin & newmin) & (! lostmax)) {
+ object at data@min <- min(object at data@min[band], minv)
+ setminmax <- TRUE
+ } else if ((lostmax & newmax) & (! lostmin)) {
+ object at data@max <- max(object at data@max[band], maxv)
+ setminmax <- TRUE
+ } else {
+ object at data@min[band] <- Inf
+ object at data@max[band] <- -Inf
+ object at data@haveminmax <- FALSE
+ setminmax <- TRUE
+ }
+ }
+ return(list(object, setminmax))
+}
diff --git a/R/validCell.R b/R/validCell.R
new file mode 100644
index 0000000..0574eaa
--- /dev/null
+++ b/R/validCell.R
@@ -0,0 +1,26 @@
+# 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 at nrows] <- TRUE
+ return(valid)
+}
+
+validCol <- function(object, colnr) {
+ colnr <- round(colnr)
+ valid <- rep(FALSE, times=length(colnr))
+ valid[colnr > 0 & colnr <= object at ncols] <- TRUE
+ return(valid)
+}
diff --git a/R/values.R b/R/values.R
new file mode 100644
index 0000000..cefb14e
--- /dev/null
+++ b/R/values.R
@@ -0,0 +1,40 @@
+# Author: Robert J. Hijmans
+# Date : October 2010
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("values")) {
+ setGeneric("values", function(x, ...)
+ standardGeneric("values"))
+}
+
+setMethod('values', signature(x='Raster'),
+function(x, ...) {
+ getValues(x, ...)
+})
+
+
+if (!isGeneric('values<-')) {
+ setGeneric('values<-', function(x, value)
+ standardGeneric('values<-'))
+ }
+
+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)
+} )
diff --git a/R/weighted.mean.R b/R/weighted.mean.R
new file mode 100644
index 0000000..8cb588a
--- /dev/null
+++ b/R/weighted.mean.R
@@ -0,0 +1,71 @@
+# Author: Robert J. Hijmans
+# Date : April 2012
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric("weighted.mean")) {
+ setGeneric("weighted.mean", function(x, w, ...)
+ standardGeneric("weighted.mean"))
+}
+
+
+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)
+ }
+)
+
diff --git a/R/which.R b/R/which.R
new file mode 100644
index 0000000..de5f67a
--- /dev/null
+++ b/R/which.R
@@ -0,0 +1,66 @@
+# 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 at 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)
+ }
+ }
+}
+)
+
diff --git a/R/which.max.R b/R/which.max.R
new file mode 100644
index 0000000..d591c1a
--- /dev/null
+++ b/R/which.max.R
@@ -0,0 +1,125 @@
+# Author: Robert J. Hijmans
+# Date : June 2013
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric("which.max")) {
+ setGeneric("which.max", function(x)
+ standardGeneric("which.max"))
+}
+
+
+if (!isGeneric("which.min")) {
+ setGeneric("which.min", function(x)
+ standardGeneric("which.min"))
+}
+
+
+
+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)
+ }
+ }
+)
+
+
+
+
+
diff --git a/R/whiches.max.R b/R/whiches.max.R
new file mode 100644
index 0000000..0c72d83
--- /dev/null
+++ b/R/whiches.max.R
@@ -0,0 +1,120 @@
+# 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))
+}
+
+
+if (!isGeneric("whiches.max")) {
+ setGeneric("whiches.max", function(x, ...)
+ standardGeneric("whiches.max"))
+}
+
+
+if (!isGeneric("whicheses.min")) {
+ setGeneric("whiches.min", function(x, ...)
+ standardGeneric("whiches.min"))
+}
+
+
+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)
+ }
+ }
+)
+
diff --git a/R/writeAllAscii.R b/R/writeAllAscii.R
new file mode 100644
index 0000000..30eac72
--- /dev/null
+++ b/R/writeAllAscii.R
@@ -0,0 +1,49 @@
+# 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 at file@nodatavalue) ) {
+ x at 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 at 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 at file@name, append = TRUE, quote = FALSE, sep = " ", eol = "\n", dec = ".", row.names = FALSE, col.names = FALSE)
+
+ if (prj) {
+ crs <- crs(x, asText=T)
+ if (!is.na(crs)) {
+ if (.requireRgdal(FALSE)) {
+ writeLines(rgdal::showWKT(crs), extension(filename, 'prj') )
+ }
+ }
+ }
+
+ return( .stopAsciiWriting(x) )
+
+}
+
+
\ No newline at end of file
diff --git a/R/writeAllGDAL.R b/R/writeAllGDAL.R
new file mode 100644
index 0000000..8fe8cb8
--- /dev/null
+++ b/R/writeAllGDAL.R
@@ -0,0 +1,31 @@
+# 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 at 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)
+}
+
diff --git a/R/writeAllRaster.R b/R/writeAllRaster.R
new file mode 100644
index 0000000..5817802
--- /dev/null
+++ b/R/writeAllRaster.R
@@ -0,0 +1,89 @@
+# Author: Robert J. Hijmans
+# Date : June 2008
+# Version 0.9
+# Licence GPL v3
+
+..writeRasterAll <- function(x, filename, NAflag, filetype, ... ) {
+
+ x at file@driver <- filetype
+ filename <- trim(filename)
+ fnamevals <- .setFileExtensionValues(filename, filetype)
+ fnamehdr <- .setFileExtensionHeader(filename, filetype)
+ if (filetype == 'raster') {
+ filename <- fnamehdr
+ } else {
+ filename <- fnamevals
+ }
+ x at 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 at data@values) | is.infinite(x at data@values)
+ if (any(na)) {
+ x at 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 at 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 at data@values[x at data@values < 0] <- NA
+ if (datatype == 'INT4U') {
+ x at data@values[is.na(x at data@values)] <- NAflag
+ #i <- x at data@values > 2147483647 & !is.na( x at data@values )
+ #x at data@values[i] <- 2147483647 - x at data@values[i]
+ } else {
+ x at data@values[is.na(x at data@values)] <- NAflag
+ }
+ } else {
+ x at data@values[is.na(x at data@values)] <- NAflag
+ }
+ x at data@values <- as.integer(round( x at data@values ))
+ x at data@min <- round(x at data@min)
+ x at data@max <- round(x at data@max)
+
+ } else if ( dtype =='FLT') {
+ x at data@values <- as.numeric(x at data@values)
+ if (filetype != 'raster') {
+ x at data@values[is.na(x at data@values)] <- NAflag
+ }
+
+
+ } else if ( dtype =='LOG') {
+ x at data@values <- as.integer(x at data@values)
+ x at data@values[is.na(x at data@values)] <- as.integer(x at file@nodatavalue)
+ }
+
+
+ dsize <- dataSize(x at file@datanotation)
+ filecon <- file(fnamevals, "wb")
+ writeBin(x at data@values , filecon, size = dsize )
+ close(filecon)
+
+ x at file@nodatavalue <- NAflag
+ hdr(x, filetype)
+
+ return(raster(filename, native=TRUE))
+}
+
+
\ No newline at end of file
diff --git a/R/writeRaster.R b/R/writeRaster.R
new file mode 100644
index 0000000..43a064b
--- /dev/null
+++ b/R/writeRaster.R
@@ -0,0 +1,237 @@
+# Author: Robert J. Hijmans
+# Date: September 2009
+# Version 1.0
+# Licence GPL v3
+
+if (!isGeneric('writeRaster')) {
+ setGeneric('writeRaster', function(x, filename, ...)
+ standardGeneric('writeRaster'))
+}
+
+
+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))
+ }
+
+
+ if (! inMemory(x) ) {
+ if ( toupper(x at 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 at history <- x at history, silent=TRUE)
+ levels(out) <- levels(x)
+ out at legend@colortable <- colortable(x)
+ out <- .startRasterWriting(out, filename, format=filetype, ...)
+ out <- writeValues(out, values(x), 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, getValues(x))
+ 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))
+ }
+
+ 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)) {
+ out <- writeValues(out, getValues(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) ) {
+
+ if (filetype=='CDF') {
+ b <- brick(x, values=FALSE)
+ b at z <- x at z
+ b <- .startWriteCDF(b, filename=filename, ...)
+ x <- .writeValuesBrickCDF(b, values(x) )
+ x <- .stopWriteCDF(x)
+ } 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 at z <- x at 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))
+ }
+}
+)
+
diff --git a/R/writeStartStop.R b/R/writeStartStop.R
new file mode 100644
index 0000000..23517da
--- /dev/null
+++ b/R/writeStartStop.R
@@ -0,0 +1,123 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric('writeStart')) {
+ setGeneric('writeStart', function(x, filename, ...)
+ standardGeneric('writeStart'))
+}
+
+if (!isGeneric('writeStop')) {
+ setGeneric('writeStop', function(x)
+ standardGeneric('writeStop'))
+}
+
+
+
+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 <- crs(x, asText=T)
+ if (!is.na(crs)) {
+ if (.requireRgdal(FALSE)) {
+ writeLines(rgdal::showWKT(crs(x, asText=TRUE)), 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 <- crs(x, asText=T)
+ if (!is.na(crs)) {
+ if (.requireRgdal(FALSE)) {
+ writeLines(rgdal::showWKT(crs), extension(filename, 'prj') )
+ }
+ }
+ }
+
+ return(x)
+})
+
+
+setMethod('writeStop', signature(x='RasterLayer'),
+ function(x) {
+ driver <- x at 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 at 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) )
+ }
+ }
+)
+
diff --git a/R/writeStartStopAscii.R b/R/writeStartStopAscii.R
new file mode 100644
index 0000000..b1d0d4d
--- /dev/null
+++ b/R/writeStartStopAscii.R
@@ -0,0 +1,66 @@
+# 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 at file@name <- filename
+ x at file@driver <- 'ascii'
+
+ overwrite <- .overwrite(...)
+ dtype <- .shortDataType(.datatype(...))
+ x at file@datanotation = .datatype(...)
+ dtype <- .shortDataType(x at file@datanotation)
+ attr(x at file, "dtype") <- dtype
+
+
+ if (!missing(NAflag)) {
+ x at file@nodatavalue <- NAflag
+ } else if (!is.finite( x at file@nodatavalue) ) {
+ x at 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 at file@nodatavalue, "\n", file = thefile)
+ close(thefile) #close connection
+
+ return(x)
+
+}
+
+
+.stopAsciiWriting <- function(x) {
+ x at data@haveminmax <- TRUE
+ if (x at file@dtype == "INT") {
+ x at data@min <- round(x at data@min)
+ x at data@max <- round(x at data@max)
+# } else if ( x at file@dtype =='LOG' ) {
+# raster at data@min <- as.logical(raster at data@min)
+# raster at data@max <- as.logical(raster at data@max)
+ }
+
+ return( raster( x at file@name ) )
+
+}
+
+
\ No newline at end of file
diff --git a/R/writeStartStopGDAL.R b/R/writeStartStopGDAL.R
new file mode 100644
index 0000000..92911d2
--- /dev/null
+++ b/R/writeStartStopGDAL.R
@@ -0,0 +1,77 @@
+# 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 at file, "transient") <- temp[[1]]
+ x at file@nodatavalue <- temp[[2]]
+ attr(x at file, "options") <- temp[[3]]
+ attr(x at file, "stats") <- setStatistics
+
+ x at data@min <- rep(Inf, nlayers(x))
+ x at data@max <- rep(-Inf, nlayers(x))
+ x at data@haveminmax <- FALSE
+
+ x at file@datanotation <- .getRasterDType(temp[[4]])
+ x at file@driver <- 'gdal'
+ x at data@fromdisk <- TRUE
+ x at file@name <- filename
+ return(x)
+}
+
+
+.stopGDALwriting <- function(x, stat=cbind(NA,NA)) {
+
+ nl <- nlayers(x)
+
+ statistics <- cbind(x at data@min, x at data@max)
+ if (substr(x at file@datanotation, 1, 1) != 'F') {
+ statistics <- round(statistics)
+ }
+
+
+ if (isTRUE( attr(x at 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 at file@transient, i)
+ rgdal::GDALcall(b, "SetStatistics", as.double(statistics[i,]))
+ }
+ }
+
+ if(x at file@options[1] != "") {
+ rgdal::saveDataset(x at file@transient, x at file@name, options=x at file@options)
+ } else {
+ rgdal::saveDataset(x at file@transient, x at file@name)
+ }
+
+ rgdal::GDAL.close(x at file@transient)
+
+ if (nl > 1) {
+ out <- brick(x at file@name)
+ } else {
+ out <- raster(x at file@name)
+ }
+
+ if (! out at data@haveminmax ) {
+ out at data@min <- statistics[, 1]
+ out at data@max <- statistics[, 2]
+ out at data@haveminmax <- TRUE
+ }
+
+ return(out)
+}
+
+
diff --git a/R/writeStartStopRaster.R b/R/writeStartStopRaster.R
new file mode 100644
index 0000000..8bc0ea6
--- /dev/null
+++ b/R/writeStartStopRaster.R
@@ -0,0 +1,153 @@
+# 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 at file@nodatavalue <- NAflag
+ }
+
+ if (datatype == 'INT4U') {
+ x at file@nodatavalue <- min(x at 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 at file, "con") <- file(fnamevals, "r+b")
+ } else {
+ attr(x at file, "con") <- file(fnamevals, "wb")
+ }
+ attr(x at file, "dsize") <- dataSize(x at file@datanotation)
+ attr(x at file, "dtype") <- .shortDataType(x at file@datanotation)
+
+ x at data@min <- rep(Inf, nlayers(x))
+ x at data@max <- rep(-Inf, nlayers(x))
+ x at data@haveminmax <- FALSE
+ x at file@driver <- filetype
+ x at 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 at file@bandorder <- bandorder
+ x at file@byteorder <- .Platform$endian
+
+ return(x)
+}
+
+
+
+.stopRasterWriting <- function(x) {
+ close(x at file@con)
+# fnamevals <- .setFileExtensionValues(x at file@name)
+# attr(x at file, "con") <- file(fnamevals, "rb")
+
+ x at data@haveminmax <- TRUE
+ if (x at file@dtype == "INT") {
+ x at data@min <- round(x at data@min)
+ x at data@max <- round(x at data@max)
+ } else if ( x at file@dtype =='LOG' ) {
+# x at data@min <- as.logical(x at data@min)
+# x at data@max <- as.logical(x at data@max)
+ }
+
+ #x at data@min[!is.finite(x at data@min)] <- NA
+ #x at data@max[!is.finite(x at data@max)] <- NA
+
+ hdr(x, .driver(x))
+ filename <- .setFileExtensionValues(filename(x), x at file@driver)
+
+ if (inherits(x, 'RasterBrick')) {
+ r <- brick(filename, native=TRUE)
+ } else {
+ r <- raster(filename, native=TRUE)
+ }
+
+ if (! r at data@haveminmax) {
+ r at data@min <- x at data@min
+ r at data@max <- x at data@max
+ r at data@haveminmax <- TRUE
+ }
+
+ h <- .addHeader()
+ if (h != '') {
+ try( hdr(r, h), silent=TRUE )
+ }
+
+ return(r)
+}
+
+
\ No newline at end of file
diff --git a/R/writeValues.R b/R/writeValues.R
new file mode 100644
index 0000000..0ff0b46
--- /dev/null
+++ b/R/writeValues.R
@@ -0,0 +1,223 @@
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 1.0
+# Licence GPL v3
+
+
+if (!isGeneric('writeValues')) {
+ setGeneric('writeValues', function(x, v, start)
+ standardGeneric('writeValues'))
+}
+
+
+setMethod('writeValues', signature(x='RasterLayer', v='vector'),
+ function(x, v, start) {
+
+ v[is.infinite(v)] <- NA
+
+ datanotation <- x at 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 at data@min <- min(x at data@min, rsd)
+ x at data@max <- max(x at data@max, rsd)
+ }
+
+ driver <- x at file@driver
+
+ if ( driver == 'gdal' ) {
+ off <- c(start-1, 0)
+ v[is.na(v)] <- x at file@nodatavalue
+ v <- matrix(v, nrow=x at ncols)
+ gd <- rgdal::putRasterData(x at file@transient, v, band=1, offset=off)
+
+ } else if ( driver %in% .nativeDrivers() ) {
+ if (x at file@dtype == "FLT" ) {
+ # v may be integers, while the filetype is FLT
+ v <- as.numeric( v )
+ if (driver != 'raster') {
+ v[is.na(v)] <- x at file@nodatavalue
+ }
+
+ } else {
+ v[is.na(v)] <- as.integer(x at file@nodatavalue)
+ v <- as.integer(v)
+ }
+
+ start <- (start-1) * x at ncols * x at file@dsize
+ seek(x at file@con, start, rw='w')
+# print(v)
+ writeBin(v, x at file@con, size=x at file@dsize )
+
+ } else if ( driver == 'netcdf') {
+
+ x <- .writeValuesCDF(x, v, start)
+
+ } else if ( driver == 'big.matrix') {
+
+ b <- attr(x at 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 at file@dtype == 'INT') {
+ options(scipen=10)
+ v <- round(v)
+ }
+
+ v[is.na(v)] <- x at file@nodatavalue
+
+ if (x at 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 at 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 at data@min <- pmin(x at data@min, rng[1,])
+ x at data@max <- pmax(x at data@max, rng[2,])
+ options('warn'= w)
+
+ driver <- x at file@driver
+ if ( driver %in% .nativeDrivers() ) {
+
+ #if (!is.matrix(v)) v <- matrix(v, ncol=1)
+
+ if (x at file@dtype == "INT") {
+ v[is.na(v)] <- x at file@nodatavalue
+ dm <- dim(v)
+ v <- as.integer(round(v))
+ dim(v) <- dm
+ } else if ( x at file@dtype =='LOG' ) {
+ v[v != 1] <- 0
+ v[is.na(v)] <- x at file@nodatavalue
+ dm <- dim(v)
+ v <- as.integer(round(v))
+ dim(v) <- dm
+ } else { # if (!is.numeric(v)) {
+ v[] <- as.numeric( v )
+ }
+
+
+ if (x at file@bandorder=='BIL') {
+
+ start <- (start-1) * x at ncols * x at file@dsize * nlayers(x)
+ seek(x at file@con, start, rw='w')
+
+ loop <- nrow(v) / x at ncols
+ start <- 1
+ for (i in 1:loop) {
+ end <- start + x at ncols - 1
+ writeBin(as.vector(v[start:end,]), x at file@con, size=x at file@dsize )
+ start <- end + 1
+ }
+
+ } else if (x at file@bandorder=='BIP') {
+
+ start <- (start-1) * x at ncols * x at file@dsize * nlayers(x)
+ seek(x at file@con, start, rw='w')
+ writeBin(as.vector(t(v)), x at file@con, size=x at file@dsize )
+
+ } else if (x at file@bandorder=='BSQ') {
+
+ start <- (start-1) * x at ncols * x at file@dsize
+ nc <- ncell(x) * x at file@dsize
+ for (i in 1:ncol(v)) {
+ pos <- start + nc * (i-1)
+ seek(x at file@con, pos, rw='w')
+ writeBin(v[,i], x at file@con, size=x at file@dsize )
+ }
+ } else {
+ stop('unknown band order')
+ }
+
+ } else if ( driver == 'netcdf') {
+
+ x <- .writeValuesBrickCDF(x, v, start)
+
+ } else if ( driver == 'big.matrix') {
+
+ b <- attr(x at 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 at file@datanotation == 'INT1U') {
+ v[v < 0] <- NA
+ }
+
+ v[is.na(v)] <- x at file@nodatavalue
+ for (i in 1:nlayers(x)) {
+ vv <- matrix(v[,i], nrow=ncol(x))
+ gd <- rgdal::putRasterData(x at 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 at file@transient, region.dim=reg, offset=off)))
+}
+
diff --git a/R/xyCell.R b/R/xyCell.R
new file mode 100644
index 0000000..2f87139
--- /dev/null
+++ b/R/xyCell.R
@@ -0,0 +1,151 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 1.0
+# Licence GPL v3
+
+
+yFromRow <- function(object, row=1:nrow(object)) {
+ if (rotated(object)) {
+ stop('this function is not supported for rotated rasters')
+ }
+ row <- round(row)
+ row[row < 1 | row > object at 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))
+}
+
+
+
+xFromCol <- function(object, col=1:ncol(object)) {
+ if (rotated(object)) {
+ stop('this function is not supported for rotated rasters')
+ }
+ col <- round(col)
+ col[col < 1 | col > object at ncols] <- NA
+ 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)
+ }
+
+
+cellFromXY <- function(object, xy) {
+ if (inherits(xy, 'SpatialPoints')) {
+ xy <- coordinates(xy)
+ 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 at rotation@transfun(xy, inv=TRUE)
+ cell <- (cr[,2]-1) * object at ncols + cr[,1]
+ } else {
+ cell <- .doCellFromXY(
+ object at ncols, object at nrows,
+ object at extent@xmin, object at extent@xmax,
+ object at extent@ymin, object at extent@ymax,
+ x, y)
+ }
+ return(cell)
+}
+
+
+colFromX <- function ( object, x ) {
+ if (inherits(x, 'Spatial')) {
+ x <- x at 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 at ncols
+ colnr[ x < xmin(object) | x > xmax(object) ] <- NA
+ return(as.vector(colnr))
+}
+
+
+rowFromY <- function ( object, y ) {
+ if (inherits(y, 'Spatial')) {
+ y <- y at 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 at nrows
+ rownr[y > ymax(object) | y < ymin(object)] <- NA
+ return(as.vector(rownr))
+}
+
+
+xyFromCell <- function(object, cell, spatial=FALSE) {
+ if (rotated(object)) {
+ xy <- object at rotation@transfun(
+ cbind(x=colFromCell(object, cell), y=rowFromCell(object, cell))
+ )
+
+ } else {
+ e <- object at extent
+ xy <- .doXYFromCell(
+ object at ncols, object at nrows,
+ e at xmin, e at xmax, e at ymin, e at ymax, cell
+ )
+ dimnames(xy) <- list(NULL, c("x", "y"))
+ }
+
+ if (spatial) {
+ xy <- 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), ...)
+ }
+)
+
+
+yFromCell <- function(object, cell) {
+ if (rotated(object)) {
+ xy <- xyFromCell(object, cell)
+ return(xy[,2])
+ } else {
+ rows <- rowFromCell(object, cell)
+ return( .yFromRow(object, rows) )
+ }
+}
+
+xFromCell <- function(object, cell) {
+ if (rotated(object)) {
+ xy <- xyFromCell(object, cell)
+ return(xy[,1])
+ } else {
+ cols <- colFromCell(object, cell)
+ return( .xFromCol(object, cols) )
+ }
+}
+
diff --git a/R/xyMinMax.R b/R/xyMinMax.R
new file mode 100644
index 0000000..9d496f7
--- /dev/null
+++ b/R/xyMinMax.R
@@ -0,0 +1,88 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+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"))
+}
+
+
+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 at xmin)
+})
+
+setMethod('xmax', signature(x='Extent'),
+function(x) {
+ return(x at xmax)
+})
+
+setMethod('ymin', signature(x='Extent'),
+function(x) {
+ return(x at ymin)
+})
+
+setMethod('ymax', signature(x='Extent'),
+function(x) {
+ return(x at 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)
+})
+
+
diff --git a/R/xyResolution.R b/R/xyResolution.R
new file mode 100644
index 0000000..82ec856
--- /dev/null
+++ b/R/xyResolution.R
@@ -0,0 +1,53 @@
+# Author: Robert J. Hijmans
+# Date : October 2008
+# Version 0.9
+# Licence GPL v3
+
+if (!isGeneric("xres")) {
+ setGeneric("xres", function(x)
+ standardGeneric("xres"))
+}
+
+if (!isGeneric("yres")) {
+ setGeneric("yres", function(x)
+ standardGeneric("yres"))
+}
+
+if (!isGeneric("res")) {
+ setGeneric("res", function(x)
+ standardGeneric("res"))
+}
+
+
+setMethod('xres', signature(x='BasicRaster'),
+function(x) {
+ if (rotated(x)) {
+ return(x at rotation@geotrans[3])
+ } else {
+ e <- x at extent
+ return ( (e at xmax - e at xmin) / x at ncols )
+ }
+} )
+
+setMethod('yres', signature(x='BasicRaster'),
+function(x) {
+ if (rotated(x)) {
+ return(x at rotation@geotrans[5])
+ } else {
+ e <- x at extent
+ return ( (e at ymax - e at ymin) / x at nrows )
+ }
+} )
+
+setMethod('res', signature(x='BasicRaster'),
+function(x) {
+ if (rotated(x)) {
+ return(x at rotation@geotrans[c(3,5)])
+ } else {
+ e <- x at extent
+ xr <- (e at xmax - e at xmin) / x at ncols
+ yr <- (e at ymax - e at ymin) / x at nrows
+ return( c(xr, yr) )
+ }
+} )
+
diff --git a/R/xyValuesBuffer.R b/R/xyValuesBuffer.R
new file mode 100644
index 0000000..6bede38
--- /dev/null
+++ b/R/xyValuesBuffer.R
@@ -0,0 +1,225 @@
+# 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)
+ 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)) {
+ 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')) {
+ cv <- unlist(lapply(cv, fun2), use.names = FALSE)
+ } else {
+ np <- length(cv)
+ cv <- lapply(cv, function(x) {apply(x,2,fun2)})
+ cv <- matrix(unlist(cv, use.names = FALSE), nrow=np, byrow=TRUE)
+ colnames(cv) <- nms
+ }
+ }
+ return(cv)
+}
+
+
+
+
diff --git a/R/zApply.R b/R/zApply.R
new file mode 100644
index 0000000..e2fc975
--- /dev/null
+++ b/R/zApply.R
@@ -0,0 +1,20 @@
+# 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
+}
+
+
diff --git a/R/zonal.R b/R/zonal.R
new file mode 100644
index 0000000..eee123e
--- /dev/null
+++ b/R/zonal.R
@@ -0,0 +1,341 @@
+# Author: Robert J. Hijmans
+# Date : March 2009
+# Version 0.9
+# Licence GPL v3
+
+
+if (!isGeneric("zonal")) {
+ setGeneric("zonal", function(x, z, ...)
+ standardGeneric("zonal"))
+}
+
+
+
+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) != 'character') {
+ stop("RasterLayers cannot be processed in memory.\n You can use fun='sum', 'mean', 'stats::sd', 'min', 'max', or 'count' but not a function")
+ }
+ if (! fun %in% c('sum', 'mean', 'stats::sd', 'min', 'max', 'count')) {
+ stop("fun can be 'sum', 'mean', 'stats::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 == 'stats::sd') {
+ func1 <- func2 <- sum
+ counts <- TRUE
+ if (fun == 'stats::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, 'stats::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) != 'character') {
+ stop("RasterLayers cannot be processed in memory.\n You can use fun='sum', 'mean', 'stats::sd', 'min', 'max', or 'count' but not a function")
+ }
+ if (! fun %in% c('sum', 'mean', 'stats::sd', 'min', 'max', 'count')) {
+ stop("fun can be 'sum', 'mean', 'stats::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 == 'stats::sd') {
+ func1 <- func2 <- sum
+ counts <- TRUE
+ if (fun == 'stats::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, 'stats::sd')
+
+
diff --git a/R/zoom.R b/R/zoom.R
new file mode 100644
index 0000000..f2cd193
--- /dev/null
+++ b/R/zoom.R
@@ -0,0 +1,72 @@
+# R function for the raster package
+# Author: Robert J. Hijmans
+# Date : September 2009
+# Version 0.9
+# Licence GPL v3
+
+
+
+if (!isGeneric("zoom")) {
+ setGeneric("zoom", function(x, ...)
+ standardGeneric("zoom"))
+}
+
+
+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) {
+ 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) {
+ dev.new()
+ }
+ sp::plot(x, xlim=c(ext at xmin, ext at xmax), ylim=c(ext at ymin, ext at 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) {
+ dev.new()
+ }
+ plot(0, xlim=c(ext at xmin, ext at xmax), ylim=c(ext at ymin, ext at ymax), type='n', ...)
+ return(invisible(ext))
+}
+)
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..ec0fc52
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,13 @@
+
+.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))
+}
+
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..81f1e21
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/debian/README.test b/debian/README.test
deleted file mode 100644
index 55a9142..0000000
--- a/debian/README.test
+++ /dev/null
@@ -1,8 +0,0 @@
-Notes on how this package can be tested.
-────────────────────────────────────────
-
-To run the unit tests provided by the package you can do
-
- sh run-unit-test
-
-in this directory.
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index 725bed9..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,6 +0,0 @@
-r-cran-raster (2.5-8-1) unstable; urgency=low
-
- * Initial release (closes: #829580)
- * Fixed license
-
- -- Andreas Tille <tille at debian.org> Mon, 04 Jul 2016 14:25:35 +0200
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index ec63514..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-9
diff --git a/debian/control b/debian/control
deleted file mode 100644
index 168d80a..0000000
--- a/debian/control
+++ /dev/null
@@ -1,27 +0,0 @@
-Source: r-cran-raster
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-Uploaders: Andreas Tille <tille at debian.org>
-Section: gnu-r
-Priority: optional
-Build-Depends: debhelper (>= 9),
- cdbs,
- r-base-dev,
- r-cran-rcpp,
- r-cran-sp
-Standards-Version: 3.9.8
-Vcs-Browser: https://anonscm.debian.org/viewvc/debian-med/trunk/packages/R/r-cran-raster/trunk/
-Vcs-Svn: svn://anonscm.debian.org/debian-med/trunk/packages/R/r-cran-raster/trunk/
-Homepage: https://cran.r-project.org/web/packages/raster
-
-Package: r-cran-raster
-Architecture: any
-Depends: ${shlibs:Depends},
- ${misc:Depends},
- ${R:Depends},
- r-cran-rcpp,
- r-cran-sp
-Description: GNU R geographic data analysis and modeling
- This GNU R package provides functions for reading, writing,
- manipulating, analyzing and modeling of gridded spatial data. The
- package implements basic and high-level functions. Processing of very
- large files is supported.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index 5362b41..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,60 +0,0 @@
-Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Name: raster
-Upstream-Contact: Robert J. Hijmans <r.hijmans at gmail.com>
-Source: https://cran.r-project.org/web/packages/raster
-
-Files: *
-Copyright: 2006-2016 Robert J. Hijmans, Jacob van Etten, Joe Cheng,
- Matteo Mattiuzzi, Michael Sumner, Jonathan A. Greenberg,
- Oscar Perpinan Lamigueiro, Andrew Bevan,
- Etienne B. Racine, Ashton Shortridge
-License: GPL-3+
-
-Files: src/geodesic.*
-Copyright: 2008-2016 Charles Karney <charles at karney.com>
-License: MIT
- Permission is hereby granted, free of charge, to any person
- obtaining a copy of this software and associated documentation
- files (the "Software"), to deal in the Software without
- restriction, including without limitation the rights to use, copy,
- modify, merge, publish, distribute, sublicense, and/or sell copies
- of the Software, and to permit persons to whom the Software is
- furnished to do so, subject to the following conditions:
- .
- The above copyright notice and this permission notice shall be
- included in all copies or substantial portions of the Software.
- .
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
- DEALINGS IN THE SOFTWARE.
-Comment: This is a C implementation of the geodesic algorithms described in
- * C. F. F. Karney,
- * Algorithms for geodesics,
- * J. Geodesy <b>87</b>, 43--55 (2013);
- * https://dx.doi.org/10.1007/s00190-012-0578-z
- * Addenda: http://geographiclib.sf.net/geod-addenda.html
- *
- * http://geographiclib.sourceforge.net/
-
-Files: debian/*
-Copyright: 2016 Andreas Tille <tille at debian.org>
-License: GPL-3+
-
-License: GPL-3+
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 3 of the License, or
- (at your option) any later version.
- .
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- .
- On Debian systems, the complete text of the GNU General Public
- License can be found in `/usr/share/common-licenses/GPL-3'.
diff --git a/debian/docs b/debian/docs
deleted file mode 100644
index 9a4f4f8..0000000
--- a/debian/docs
+++ /dev/null
@@ -1,2 +0,0 @@
-debian/README.test
-debian/tests/run-unit-test
diff --git a/debian/examples b/debian/examples
deleted file mode 100644
index 18244c8..0000000
--- a/debian/examples
+++ /dev/null
@@ -1 +0,0 @@
-vignettes
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 2fbba2d..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,3 +0,0 @@
-#!/usr/bin/make -f
-
-include /usr/share/R/debian/r-cran.mk
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/debian/tests/control b/debian/tests/control
deleted file mode 100644
index d2aa55a..0000000
--- a/debian/tests/control
+++ /dev/null
@@ -1,3 +0,0 @@
-Tests: run-unit-test
-Depends: @
-Restrictions: allow-stderr
diff --git a/debian/tests/run-unit-test b/debian/tests/run-unit-test
deleted file mode 100644
index 9785b93..0000000
--- a/debian/tests/run-unit-test
+++ /dev/null
@@ -1,19 +0,0 @@
-#!/bin/sh -e
-oname=raster
-pkg=r-cran-`echo $oname | tr '[A-Z]' '[a-z]'`
-
-if [ "$ADTTMP" = "" ] ; then
- ADTTMP=`mktemp -d /tmp/${pkg}-test.XXXXXX`
- trap "rm -rf $ADTTMP" 0 INT QUIT ABRT PIPE TERM
-fi
-cd $ADTTMP
-cp /usr/share/doc/$pkg/examples/vignettes/* $ADTTMP
-find . -name "*.gz" -exec gunzip \{\} \;
-for rnw in `ls *.[rRS]nw` ; do
-rfile=`echo $rnw | sed 's/\.[rRS]nw/.R/'`
-R --no-save <<EOT
- Stangle("$rnw")
- source("$rfile", echo=TRUE)
-EOT
- echo "$rnw passed"
-done
diff --git a/debian/watch b/debian/watch
deleted file mode 100644
index c33f26a..0000000
--- a/debian/watch
+++ /dev/null
@@ -1,2 +0,0 @@
-version=3
-http://cran.r-project.org/src/contrib/raster_([-\d.]*)\.tar\.gz
diff --git a/inst/doc/Raster.R b/inst/doc/Raster.R
new file mode 100644
index 0000000..149d988
--- /dev/null
+++ b/inst/doc/Raster.R
@@ -0,0 +1,366 @@
+### R code from vignette source 'Raster.Rnw'
+### Encoding: ISO8859-1
+
+###################################################
+### code chunk number 1: foo
+###################################################
+options(width = 60)
+foo <- packageDescription("raster")
+
+
+###################################################
+### code chunk number 2: raster-1a
+###################################################
+library(raster)
+# RasterLayer with the default parameters
+x <- raster()
+x
+
+# With other parameters
+x <- raster(ncol=36, nrow=18, xmn=-1000, xmx=1000, ymn=-100, ymx=900)
+# that can be changed
+res(x)
+
+# change resolution
+res(x) <- 100
+res(x)
+ncol(x)
+# change the numer of columns (affects resolution)
+ncol(x) <- 18
+ncol(x)
+res(x)
+
+# set the coordinate reference system (CRS) (define the projection)
+projection(x) <- "+proj=utm +zone=48 +datum=WGS84"
+x
+
+
+###################################################
+### code chunk number 3: raster-1b
+###################################################
+r <- raster(ncol=10, nrow=10)
+ncell(r)
+hasValues(r)
+
+# use the 'values' function
+# e.g.,
+values(r) <- 1:ncell(r)
+# or
+set.seed(0)
+values(r) <- runif(ncell(r))
+
+hasValues(r)
+inMemory(r)
+values(r)[1:10]
+
+plot(r, main='Raster with 100 cells')
+
+
+###################################################
+### code chunk number 4: raster-1c
+###################################################
+hasValues(r)
+res(r)
+dim(r)
+xmax(r)
+
+# change the maximum x coordinate of the extent (bounding box) of the RasterLayer
+xmax(r) <- 0
+
+hasValues(r)
+res(r)
+dim(r)
+
+ncol(r) <- 6
+hasValues(r)
+res(r)
+dim(r)
+xmax(r)
+
+
+###################################################
+### code chunk number 5: raster-2a
+###################################################
+# get the name of an example file installed with the package
+# do not use this construction of your own files
+filename <- system.file("external/test.grd", package="raster")
+
+filename
+r <- raster(filename)
+filename(r)
+hasValues(r)
+inMemory(r)
+plot(r, main='RasterLayer from file')
+
+
+###################################################
+### code chunk number 6: raster-2b
+###################################################
+# create three identical RasterLayer objects
+r1 <- r2 <- r3 <- raster(nrow=10, ncol=10)
+# Assign random cell values
+values(r1) <- runif(ncell(r1))
+values(r2) <- runif(ncell(r2))
+values(r3) <- runif(ncell(r3))
+
+# combine three RasterLayer objects into a RasterStack
+s <- stack(r1, r2, r3)
+s
+nlayers(s)
+
+# combine three RasterLayer objects into a RasterBrick
+b1 <- brick(r1, r2, r3)
+# equivalent to:
+b2 <- brick(s)
+
+# create a RasterBrick from file
+filename <- system.file("external/rlogo.grd", package="raster")
+filename
+b <- brick(filename)
+b
+nlayers(b)
+
+# extract a single RasterLayer
+r <- raster(b, layer=2)
+# equivalent to creating it from disk
+r <- raster(filename, band=2)
+
+
+###################################################
+### code chunk number 7: raster-3a
+###################################################
+# create an empty RasterLayer
+r <- raster(ncol=10, nrow=10)
+# assign values to cells
+values(r) <- 1:ncell(r)
+s <- r + 10
+s <- sqrt(s)
+s <- s * r + 5
+r[] <- runif(ncell(r))
+r <- round(r)
+r <- r == 1
+
+
+###################################################
+### code chunk number 8: raster-3b
+###################################################
+s[r] <- -0.5
+s[!r] <- 5
+s[s == 5] <- 15
+
+
+###################################################
+### code chunk number 9: raster-3c
+###################################################
+r <- raster(ncol=5, nrow=5)
+r[] <- 1
+s <- stack(r, r+1)
+q <- stack(r, r+2, r+4, r+6)
+x <- r + s + q
+x
+
+
+###################################################
+### code chunk number 10: raster-3d
+###################################################
+a <- mean(r,s,10)
+b <- sum(r,s)
+st <- stack(r, s, a, b)
+sst <- sum(st)
+sst
+
+
+###################################################
+### code chunk number 11: raster-3e
+###################################################
+cellStats(st, 'sum')
+cellStats(sst, 'sum')
+
+
+###################################################
+### code chunk number 12: raster-5
+###################################################
+r <- raster()
+r[] <- 1:ncell(r)
+ra <- aggregate(r, 10)
+r1 <- crop(r, extent(-180,0,0,30))
+r2 <- crop(r, extent(-10,180,-20,10))
+m <- merge(r1, r2, filename='test.grd', overwrite=TRUE)
+plot(m)
+
+
+###################################################
+### code chunk number 13: raster-6
+###################################################
+r <- raster(ncol=3, nrow=2)
+r[] <- 1:ncell(r)
+getValues(r)
+s <- calc(r, fun=function(x){ x[x < 4] <- NA; return(x)} )
+as.matrix(s)
+t <- overlay(r, s, fun=function(x, y){ x / (2 * sqrt(y)) + 5 } )
+as.matrix(t)
+u <- mask(r, t)
+as.matrix(u)
+v = u==s
+as.matrix(v)
+w <- cover(t, r)
+as.matrix(w)
+x <- reclassify(w, c(0,2,1, 2,5,2, 4,10,3))
+as.matrix(x)
+y <- subs(x, data.frame(id=c(2,3), v=c(40,50)))
+as.matrix(y)
+
+
+###################################################
+### code chunk number 14: raster-7
+###################################################
+r <- raster(nrow=45, ncol=90)
+r[] <- round(runif(ncell(r))*3)
+a <- area(r)
+zonal(a, r, 'sum')
+
+
+###################################################
+### code chunk number 15: raster-10
+###################################################
+r <- raster(ncol=36, nrow=18)
+r[] <- runif(ncell(r))
+cellStats(r, mean)
+s = r
+s[] <- round(runif(ncell(r)) * 5)
+zonal(r, s, 'mean')
+freq(s)
+freq(s, value=3)
+crosstab(r*3, s)
+
+
+###################################################
+### code chunk number 16: raster-20a
+###################################################
+b <- brick(system.file("external/rlogo.grd", package="raster"))
+plot(b)
+
+
+###################################################
+### code chunk number 17: raster-20b
+###################################################
+plotRGB(b, r=1, g=2, b=3)
+
+
+###################################################
+### code chunk number 18: raster-15
+###################################################
+library(raster)
+r <- raster(ncol=36, nrow=18)
+ncol(r)
+nrow(r)
+ncell(r)
+rowFromCell(r, 100)
+colFromCell(r, 100)
+cellFromRowCol(r,5,5)
+xyFromCell(r, 100)
+cellFromXY(r, c(0,0))
+colFromX(r, 0)
+rowFromY(r, 0)
+
+
+###################################################
+### code chunk number 19: raster-20
+###################################################
+r <- raster(system.file("external/test.grd", package="raster"))
+v <- getValues(r, 50)
+v[35:39]
+getValuesBlock(r, 50, 1, 35, 5)
+
+
+###################################################
+### code chunk number 20: raster-21
+###################################################
+cells <- cellFromRowCol(r, 50, 35:39)
+cells
+extract(r, cells)
+xy = xyFromCell(r, cells)
+xy
+extract(r, xy)
+
+
+###################################################
+### code chunk number 21: raster-32
+###################################################
+r[cells]
+r[1:4]
+filename(r)
+r[2:3] <- 10
+r[1:4]
+filename(r)
+
+
+###################################################
+### code chunk number 22: raster-33
+###################################################
+r[1]
+r[2,2]
+r[1,]
+r[,2]
+r[1:3,1:3]
+
+# keep the matrix structure
+r[1:3,1:3, drop=FALSE]
+
+
+###################################################
+### code chunk number 23: raster-119
+###################################################
+rasterOptions()
+
+
+###################################################
+### code chunk number 24: raster-120
+###################################################
+r1 <- raster(ncol=36, nrow=18)
+r2 <- r1
+r1[] <- runif(ncell(r1))
+r2[] <- runif(ncell(r1))
+s <- stack(r1, r2)
+sgdf <- as(s, 'SpatialGridDataFrame')
+newr2 <- raster(sgdf, 2)
+news <- stack(sgdf)
+
+
+###################################################
+### code chunk number 25: raster-132
+###################################################
+setClass ('myRaster',
+ contains = 'RasterLayer',
+ representation (
+ important = 'data.frame',
+ essential = 'character'
+ ) ,
+ prototype (
+ important = data.frame(),
+ essential = ''
+ )
+)
+
+r = raster(nrow=10, ncol=10)
+
+m <- as(r, 'myRaster')
+m at important <- data.frame(id=1:10, value=runif(10))
+m at essential <- 'my own slot'
+m[] <- 1:ncell(m)
+
+
+###################################################
+### code chunk number 26: raster-133
+###################################################
+setMethod ('show' , 'myRaster',
+ function(object) {
+ callNextMethod(object) # call show(RasterLayer)
+ cat('essential:', object at essential, '\n')
+ cat('important information:\n')
+ print( object at important)
+ })
+
+m
+
+
diff --git a/inst/doc/Raster.Rnw b/inst/doc/Raster.Rnw
new file mode 100644
index 0000000..f8241c6
--- /dev/null
+++ b/inst/doc/Raster.Rnw
@@ -0,0 +1,566 @@
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage{hanging}
+\usepackage[utf8]{inputenc}
+\usepackage{hyperref}
+
+%\VignetteIndexEntry{Introduction to the raster package}
+
+\newcommand{\R}{{\normalfont\textsf{R }}{}}
+\newcommand{\NA}{{\normalfont\textsf{NA }}{}}
+
+\DeclareGraphicsExtensions{.png,.pdf,.jpg}
+
+\begin{document}
+
+\SweaveOpts{png=TRUE, pdf=FALSE}
+
+\SweaveOpts{resolution=100}
+\SweaveOpts{keep.source=TRUE}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(width = 60)
+foo <- packageDescription("raster")
+@
+
+\title{Introduction to the 'raster' package\\(version \Sexpr{foo$Version})}
+
+\author{Robert J. Hijmans}
+\maketitle
+
+
+\section{Introduction}
+
+This vignette describes the \R package '\verb at raster@'. A raster is a spatial (geographic) data structure that divides a region into rectangles called 'cells' (or 'pixels') that can store one or more values for each of these cells. Such a data structure is also referred to as a 'grid' and is often contrasted with 'vector' data that is used to represent points, lines, and polygons.
+
+The \verb at raster@ package has functions for creating, reading, manipulating, and writing raster data. The package provides, among other things, general raster data manipulation functions that can easily be used to develop more specific functions. For example, there are functions to read a chunk of raster values from a file or to convert cell numbers to coordinates and back. The package also implements raster algebra and most functions for raster data manipulation that are common in Geogr [...]
+
+A notable feature of the \verb at raster@ package is that it can work with raster datasets that are stored on disk and are too large to be loaded into memory (RAM). The package can work with large files because the objects it creates from these files only contain information about the structure of the data, such as the number of rows and columns, the spatial extent, and the filename, but it does not attempt to read all the cell values in memory. In computations with these objects, data is p [...]
+
+To understand what is covered in this vignette, you must understand the basics of the \R language. There is a multitude of on-line and other resources that can help you to get acquainted with it. The \verb at raster@ package does not operate in isolation. For example, for vector type data it uses classes defined in the \verb at sp@ package. See the vignette and help pages of that package or Bivand {\it et al}. (2008). Bivand {\it et al}., provide an introduction to the use of \R for handling s [...]
+
+In the next section, some general aspects of the design of the '\verb at raster@' package are discussed, notably the structure of the main classes, and what they represent. The use of the package is illustrated in subsequent sections. \verb at raster@ has a large number of functions, not all of them are discussed here, and those that are discussed are mentioned only briefly. See the help files of the package for more information on individual functions and {\bf help("raster-package")} for an i [...]
+
+
+\section{Classes}
+
+The package is built around a number of 'S4' classes of which the \verb at RasterLayer@, \verb at RasterBrick@, and \verb at RasterStack@ classes are the most important. See Chambers (2009) for a detailed discussion of the use of S4 classes in \R. When discussing methods that can operate on all three of these objects, they are referred to as 'Raster*' objects.
+
+\subsection{RasterLayer}
+
+A \verb at RasterLayer@ object represents single-layer (variable) raster data. A \verb at RasterLayer@ object always stores a number of fundamental parameters that describe it. These include the number of columns and rows, the coordinates of its spatial extent ('bounding box'), and the coordinate reference system (the 'map projection'). In addition, a \verb at RasterLayer@ can store information about the file in which the raster cell values are stored (if there is such a file). A \verb at RasterLaye [...]
+
+\subsection{RasterStack and RasterBrick}
+
+It is quite common to analyze raster data using single-layer objects. However, in many cases multi-variable raster data sets are used. The \verb at raster@ package has two classes for multi-layer data the \verb at RasterStack@ and the \verb at RasterBrick@. The principal difference between these two classes is that a \verb at RasterBrick@ can only be linked to a single (multi-layer) file. In contrast, a \verb at RasterStack@ can be formed from separate files and/or from a few layers ('bands') from a si [...]
+
+In fact, a \verb at RasterStack@ is a collection of \verb at RasterLayer@ objects with the same spatial extent and resolution. In essence it is a list of \verb at RasterLayer@ objects. A \verb at RasterStack@ can easily be formed form a collection of files in different locations and these can be mixed with \verb at RasterLayer@ objects that only exist in memory.
+
+A \verb at RasterBrick@ is truly a multilayered object, and processing a \verb at RasterBrick@ can be more efficient than processing a \verb at RasterStack@ representing the same data. However, it can only refer to a single file. A typical example of such a file would be a multi-band satellite image or the output of a global climate model (with e.g., a time series of temperature values for each day of the year for each raster cell). Methods that operate on \verb at RasterStack@ and \verb at RasterBri [...]
+
+
+\subsection{Other classes}
+
+Below is some more detail, you do not need to read or understand this section to use the \verb at raster@ package.
+
+The three classes described above inherit from the \verb at Raster@ class (that means they are derived from this more basic 'parent' class by adding something to that class) which itself inherits from the \verb at BasicRaster@ class. The \verb at BasicRaster@ only has a few properties (referred to as 'slots' in S4 speak): the number of columns and rows, the coordinate reference system (which itself is an object of class \verb at CRS@, which is defined in package '\verb at sp@') and the spatial extent, [...]
+
+An object of class \verb at Extent@ has four slots: xmin, xmax, ymin, and ymax. These represent the minimum and maximum x and y coordinates of the of the Raster object. These would be, for example, -180, 180, -90, and 90, for a global raster with longitude/latitude coordinates. Note that raster uses the coordinates of the extremes (corners) of the entire raster (unlike some files/programs that use the coordinates of the center of extreme cells).
+
+\verb at Raster@ is a virtual class. This means that it cannot be instantiated (you cannot create objects from this class). It was created to allow the definition of methods for that class. These methods will be dispatched when called with a descendent of the class (i.e. when the method is called with a \verb at RasterLayer@, \verb at RasterBrick@ or \verb at RasterStack@ object as argument). This allows for efficient code writing because many methods are the same for any of these three classes, a [...]
+
+\verb at RasterStackBrick@ is a class union of the \verb at RasterStack@ and \verb at RasterBrick@ class. This is a also a virtual class. It allows defining methods (functions) that apply to both \verb at RasterStack@ and \verb at RasterBrick@ objects.
+
+
+\section{Creating Raster* objects}
+
+A \verb at RasterLayer@ can easily be created from scratch using the function {\bf raster}. The default settings will create a global raster data structure with a longitude/latitude coordinate reference system and 1 by 1 degree cells. You can change these settings by providing additional arguments such as {\bf xmin}, {\bf nrow}, {\bf ncol}, and/or {\bf crs}, to the function. You can also change these parameters after creating the object. If you set the projection, this is only to properly d [...]
+
+Here is an example of creating and changing a \verb at RasterLayer@ object 'r' from scratch.
+<<raster-1a>>=
+library(raster)
+# RasterLayer with the default parameters
+x <- raster()
+x
+
+# With other parameters
+x <- raster(ncol=36, nrow=18, xmn=-1000, xmx=1000, ymn=-100, ymx=900)
+# that can be changed
+res(x)
+
+# change resolution
+res(x) <- 100
+res(x)
+ncol(x)
+# change the numer of columns (affects resolution)
+ncol(x) <- 18
+ncol(x)
+res(x)
+
+# set the coordinate reference system (CRS) (define the projection)
+projection(x) <- "+proj=utm +zone=48 +datum=WGS84"
+x
+@
+
+The objects 'x' created in the example above only consist of a 'skeleton', that is, we have defined the number of rows and columns, and where the raster is located in geographic space, but there are no cell-values associated with it. Setting and accessing values is illustrated below.
+
+<<raster-1b, fig=TRUE , echo=TRUE>>=
+r <- raster(ncol=10, nrow=10)
+ncell(r)
+hasValues(r)
+
+# use the 'values' function
+# e.g.,
+values(r) <- 1:ncell(r)
+# or
+set.seed(0)
+values(r) <- runif(ncell(r))
+
+hasValues(r)
+inMemory(r)
+values(r)[1:10]
+
+plot(r, main='Raster with 100 cells')
+@
+
+In some cases, for example when you change the number of columns or rows, you will lose the values associated with the \verb at RasterLayer@ if there were any (or the link to a file if there was one). The same applies, in most cases, if you change the resolution directly (as this can affect the number of rows or columns). Values are not lost when changing the extent as this change adjusts the resolution, but does not change the number of rows or columns.
+
+<<raster-1c, echo=TRUE>>=
+hasValues(r)
+res(r)
+dim(r)
+xmax(r)
+
+# change the maximum x coordinate of the extent (bounding box) of the RasterLayer
+xmax(r) <- 0
+
+hasValues(r)
+res(r)
+dim(r)
+
+ncol(r) <- 6
+hasValues(r)
+res(r)
+dim(r)
+xmax(r)
+@
+
+The function {\bf raster} also allows you to create a \verb at RasterLayer@ from another object, including another \verb at RasterLayer@, \verb at RasterStack@ and \verb at RasterBrick@ , as well as from a \verb at SpatialPixels*@ and \verb at SpatialGrid*@ object (defined in the \verb at sp@ package), an \verb at Extent@ object, a matrix, an 'im' object (SpatStat), and 'asc' and 'kasc' objects (adehabitat).
+
+It is more common, however, to create a \verb at RasterLayer@ object from a file. The raster package can use raster files in several formats, including some 'natively' supported formats and other formats via the \verb at rgdal@ package. Supported formats for reading include GeoTIFF, ESRI, ENVI, and ERDAS. Most formats supported for reading can also be written to. Here is an example using the 'Meuse' dataset (taken from the \verb at sp@ package), using a file in the native 'raster-file' format:
+
+<<raster-2a, fig=TRUE , echo=TRUE>>=
+# get the name of an example file installed with the package
+# do not use this construction of your own files
+filename <- system.file("external/test.grd", package="raster")
+
+filename
+r <- raster(filename)
+filename(r)
+hasValues(r)
+inMemory(r)
+plot(r, main='RasterLayer from file')
+@
+
+Multi-layer objects can be created in memory (from \verb at RasterLayer@ objects) or from files.
+
+<<raster-2b>>=
+# create three identical RasterLayer objects
+r1 <- r2 <- r3 <- raster(nrow=10, ncol=10)
+# Assign random cell values
+values(r1) <- runif(ncell(r1))
+values(r2) <- runif(ncell(r2))
+values(r3) <- runif(ncell(r3))
+
+# combine three RasterLayer objects into a RasterStack
+s <- stack(r1, r2, r3)
+s
+nlayers(s)
+
+# combine three RasterLayer objects into a RasterBrick
+b1 <- brick(r1, r2, r3)
+# equivalent to:
+b2 <- brick(s)
+
+# create a RasterBrick from file
+filename <- system.file("external/rlogo.grd", package="raster")
+filename
+b <- brick(filename)
+b
+nlayers(b)
+
+# extract a single RasterLayer
+r <- raster(b, layer=2)
+# equivalent to creating it from disk
+r <- raster(filename, band=2)
+@
+
+
+\section{Raster algebra}
+
+Many generic functions that allow for simple and elegant raster algebra have been implemented for \verb at Raster*@ objects, including the normal algebraic operators such as {\bf +, -, *, /}, logical operators such as {\bf >, >=, <, ==, !} and functions such as {\bf abs, round, ceiling, floor, trunc, sqrt, log, log10, exp, cos, sin, max, min, range, prod, sum, any, all}. In these functions you can mix \verb at Raster@ objects with numbers, as long as the first argument is a \verb at Raster@ object.
+
+<<raster-3a>>=
+# create an empty RasterLayer
+r <- raster(ncol=10, nrow=10)
+# assign values to cells
+values(r) <- 1:ncell(r)
+s <- r + 10
+s <- sqrt(s)
+s <- s * r + 5
+r[] <- runif(ncell(r))
+r <- round(r)
+r <- r == 1
+@
+
+You can also use replacement functions:
+<<raster-3b>>=
+s[r] <- -0.5
+s[!r] <- 5
+s[s == 5] <- 15
+@
+
+If you use multiple \verb at Raster*@ objects (in functions where this is relevant, such as range), these must have the same resolution and origin. The origin of a \verb at Raster*@ object is the point closest to (0, 0) that you could get if you moved from a corners of a \verb at Raster*@ object towards that point in steps of the \verb at x@ and \verb at y@ resolution. Normally these objects would also have the same extent, but if they do not, the returned object covers the spatial intersection of the [...]
+
+
+When you use multiple multi-layer objects with different numbers or layers, the 'shorter' objects are 'recycled'. For example, if you multuply a 4-layer object (a1, a2, a3, a4) with a 2-layer object (b1, b2), the result is a four-layer object (a1b1, a2b2, a3b1, a3b2).
+
+<<raster-3c>>=
+r <- raster(ncol=5, nrow=5)
+r[] <- 1
+s <- stack(r, r+1)
+q <- stack(r, r+2, r+4, r+6)
+x <- r + s + q
+x
+@
+
+
+Summary functions {\bf (min, max, mean, prod, sum, Median, cv, range, any, all)} always return a \verb at RasterLayer@ object. Perhaps this is not obvious when using functions like {\bf min, sum or mean}.
+
+<<raster-3d>>=
+a <- mean(r,s,10)
+b <- sum(r,s)
+st <- stack(r, s, a, b)
+sst <- sum(st)
+sst
+@
+
+Use {\bf cellStats} if instead of a \verb at RasterLayer@ you want a single number summarizing the cell values of each layer.
+<<raster-3e>>=
+cellStats(st, 'sum')
+cellStats(sst, 'sum')
+@
+
+
+
+\section{'High-level' functions}
+
+Several 'high level' functions have been implemented for \verb at RasterLayer@ objects. 'High level' functions refer to functions that you would normally find in a GIS program that supports raster data. Here we briefly discuss some of these functions. All these functions work for raster datasets that cannot be loaded into memory. See the help files for more detailed descriptions of each function.
+
+The high-level functions have some arguments in common. The first argument is typically 'x' or 'object' and can be a \verb at RasterLayer@, or, in most cases, a \verb at RasterStack@ or \verb at RasterBrick@. It is followed by one or more arguments specific to the function (either additional \verb at RasterLayer@ objects or other arguments), followed by a filename="" and "..." arguments.
+
+The default filename is an empty character "". If you do not specify a filename, the default action for the function is to return a \verb at Raster@ object that only exists in memory. However, if the function deems that the \verb at Raster@ object to be created would be too large to hold memory it is written to a temporary file instead.
+
+The "..." argument allows for setting additional arguments that are relevant when writing values to a file: the file format, datatype (e.g. integer or real values), and a to indicate whether existing files should be overwritten.
+
+
+\subsection{Modifying a Raster* object}
+
+There are several functions that deal with modifying the spatial extent of \verb at Raster*@ objects. The {\bf crop} function lets you take a geographic subset of a larger \verb at Raster@ object. You can crop a \verb at Raster*@ by providing an extent object or another spatial object from which an extent can be extracted (objects from classes deriving from Raster and from Spatial in the sp package). An easy way to get an extent object is to plot a \verb at RasterLayer@ and then use {\bf drawExtent} [...]
+
+{\bf trim} crops a \verb at RasterLayer@ by removing the outer rows and columns that only contain \NA values. In contrast, {\bf extend} adds new rows and/or columns with \NA values. The purpose of this could be to create a new \verb at RasterLayer@ with the same Extent of another larger \verb at RasterLayer@ such that the can be used together in other functions.
+
+The {\bf merge} function lets you merge 2 or more \verb at Raster*@ objects into a single new object. The input objects must have the same resolution and origin (such that their cells neatly fit into a single larger raster). If this is not the case you can first adjust one of the \verb at Raster*@ objects with use {\bf (dis)aggregate} or {\bf resample}.
+
+{\bf aggregate} and {\bf disaggregate} allow for changing the resolution (cell size) of a \verb at Raster*@ object. In the case of {\bf aggregate}, you need to specify a function determining what to do with the grouped cell values (e.g. {\bf mean}). It is possible to specify different (dis)aggregation factors in the x and y direction. {\bf aggregate} and {\bf disaggregate} are the best functions when adjusting cells size only, with an integer step (e.g. each side 2 times smaller or larger), [...]
+
+For example, you may need nearly the same cell size, while shifting the cell centers. In those cases, the {\bf resample} function can be used. It can do either nearest neighbor assignments (for categorical data) or bilinear interpolation (for numerical data). Simple linear shifts of a Raster object can be accomplished with the {\bf shift} function or with the {\bf extent} function. {\bf resample} should not be used to create a Raster* object with much larger resolution. If such adjustmen [...]
+
+With the {\bf projectRaster} function you can transform values of \verb at Raster*@ object to a new object with a different coordinate reference system.
+
+Here are some simple examples:
+<<raster-5, fig=TRUE , echo=TRUE>>=
+r <- raster()
+r[] <- 1:ncell(r)
+ra <- aggregate(r, 10)
+r1 <- crop(r, extent(-180,0,0,30))
+r2 <- crop(r, extent(-10,180,-20,10))
+m <- merge(r1, r2, filename='test.grd', overwrite=TRUE)
+plot(m)
+@
+
+{\bf flip} lets you flip the data (reverse order) in horizontal or vertical direction -- typically to correct for a 'communication problem' between different R packages or a misinterpreted file. {\bf rotate} lets you rotate longitude/latitude rasters that have longitudes from 0 to 360 degrees (often used by climatologists) to the standard -180 to 180 degrees system. With {\bf t} you can rotate a \verb at Raster*@ object 90 degrees.
+
+
+\subsection{Overlay}
+The {\bf overlay} function can be used as an alternative to the raster algebra discussed above. Overlay, like the funcitons discussed in the following subsections provide either easy to use short-hand, or more efficient computation for large (file based) objects.
+
+With {\bf overlay} you can combine multiple Raster objects (e.g. multiply them). The related function {\bf mask} removes all values from one layer that are \NA in another layer, and {\bf cover} combines two layers by taking the values of the first layer except where these are \NA.
+
+
+\subsection{Calc}
+
+{\bf calc} allows you to do a computation for a single \verb at Raster@ object by providing a function. If you supply a \verb at RasterLayer@, another \verb at RasterLayer@ is returned. If you provide a multi-layer object you get a (single layer) \verb at RasterLayer@ if you use a summary type function (e.g. {\bf sum}) but a \verb at RasterBrick@ if multiple layers are returned. {\bf stackApply} computes summary type layers for subsets of a \verb at RasterStack@ or \verb at RasterBrick@.
+
+
+\subsection{Reclassify}
+You can use {\bf cut} or {\bf reclassify} to replace ranges of values with single values, or {\bf subs} to substitute (replace) single values with other values.
+
+<<raster-6>>=
+r <- raster(ncol=3, nrow=2)
+r[] <- 1:ncell(r)
+getValues(r)
+s <- calc(r, fun=function(x){ x[x < 4] <- NA; return(x)} )
+as.matrix(s)
+t <- overlay(r, s, fun=function(x, y){ x / (2 * sqrt(y)) + 5 } )
+as.matrix(t)
+u <- mask(r, t)
+as.matrix(u)
+v = u==s
+as.matrix(v)
+w <- cover(t, r)
+as.matrix(w)
+x <- reclassify(w, c(0,2,1, 2,5,2, 4,10,3))
+as.matrix(x)
+y <- subs(x, data.frame(id=c(2,3), v=c(40,50)))
+as.matrix(y)
+@
+
+
+\subsection{Focal functions}
+
+The {\bf focal} function currently only works for (single layer) RasterLayer objects. It uses values in a neighborhood of cells around a focal cell, and computes a value that is stored in the focal cell of the output RasterLayer. The neighborhood is a user-defined a matrix of weights and could approximate any shape by giving some cells zero weight. It is possible to only compute new values for cells that are \NA in the input RasterLayer.
+
+
+\subsection{Distance}
+
+There are a number of distance related functions. {\bf distance} computes the shortest distance to cells that are not \NA. {\bf pointDistance} computes the shortest distance to any point in a set of points. {\bf gridDistance} computes the distance when following grid cells that can be traversed (e.g. excluding water bodies). {\bf direction} computes the direction towards (or from) the nearest cell that is not \NA. {\bf adjacency} determines which cells are adjacent to other cells, and {\ [...]
+
+\subsection{Spatial configuration}
+Function {\bf clump} identifies groups of cells that are connected. {\bf boundaries} identifies edges, that is, transitions between cell values. {\bf area} computes the size of each grid cell (for unprojected rasters), this may be useful to, e.g. compute the area covered by a certain class on a longitude/latitude raster.
+
+<<raster-7>>=
+r <- raster(nrow=45, ncol=90)
+r[] <- round(runif(ncell(r))*3)
+a <- area(r)
+zonal(a, r, 'sum')
+@
+
+
+\subsection{Predictions}
+The package has two functions to make model predictions to (potentially very large) rasters. {\bf predict} takes a multilayer raster and a fitted model as arguments. Fitted models can be of various classes, including glm, gam, randomforest, and brt. Function {\bf interpolate} is similar but is for models that use coordinates as predictor variables, for example in kriging and spline interpolation.
+
+
+\subsection{Vector to raster conversion}
+
+The raster packages supports point, line, and polygon to raster conversion with the {\bf rasterize} function. For vector type data (points, lines, polygons), objects of Spatial* classes defined in the \verb at sp@ package are used; but points can also be represented by a two-column matrix (x and y).
+
+Point to raster conversion is often done with the purpose to analyze the point data. For example to count the number of distinct species (represented by point observations) that occur in each raster cell. {\bf rasterize} takes a \verb at Raster*@ object to set the spatial extent and resolution, and a function to determine how to summarize the points (or an attribute of each point) by cell.
+
+Polygon to raster conversion is typically done to create a \verb at RasterLayer@ that can act as a mask, i.e. to set to \NA a set of cells of a \verb at Raster@ object, or to summarize values on a raster by zone. For example a country polygon is transferred to a raster that is then used to set all the cells outside that country to \NA; whereas polygons representing administrative regions such as states can be transferred to a raster to summarize raster values by region.
+
+It is also possible to convert the values of a \verb at RasterLayer@ to points or polygons, using {\bf rasterToPoints} and {\bf rasterToPolygons}. Both functions only return values for cells that are not \NA. Unlike {\bf rasterToPolygons}, {\bf rasterToPoints} is reasonably efficient and allows you to provide a function to subset the output before it is produced (which can be necessary for very large rasters as the point object is created in memory).
+
+
+\section{Summarizing functions}
+
+When used with a \verb at Raster*@ object as first argument, normal summary statistics functions such as min, max and mean return a RasterLayer. You can use cellStats if, instead, you want to obtain a summary for all cells of a single \verb at Raster*@ object. You can use {\bf freq} to make a frequency table, or to count the number of cells with a specified value. Use {\bf zonal} to summarize a \verb at Raster*@ object using zones (areas with the same integer number) defined in a \verb at RasterLaye [...]
+
+<<raster-10>>=
+r <- raster(ncol=36, nrow=18)
+r[] <- runif(ncell(r))
+cellStats(r, mean)
+s = r
+s[] <- round(runif(ncell(r)) * 5)
+zonal(r, s, 'mean')
+freq(s)
+freq(s, value=3)
+crosstab(r*3, s)
+@
+
+
+\section{Plotting}
+Several generic functions have been implemented for Raster* objects to create maps and other plot types. Use 'plot' to create a map of a Raster* object. When plot is used with a \verb at RasterLayer@, it calls the function 'rasterImage' (but, by default, adds a legend; using code from fields::image.plot). It is also possible to directly call {\bf image}. You can zoom in using 'zoom' and clicking on the map twice (to indicate where to zoom to). With {\bf click} it is possible to interactivel [...]
+
+After plotting a \verb at RasterLayer@ you can add vector type spatial data (points, lines, polygons). You can do this with functions points, lines, polygons if you are using the basic R data structures or plot(object, add=TRUE) if you are using Spatial* objects as defined in the sp package. When plot is used with a multi-layer Raster* object, all layers are plotted (up to 16), unless the layers desired are indicated with an additional argument. You can also plot Raster* objects with spplot [...]
+
+Multi-layer Raster objects can be plotted as individual layers
+<<raster-20a, fig=TRUE , echo=TRUE>>=
+b <- brick(system.file("external/rlogo.grd", package="raster"))
+plot(b)
+@
+
+They can also be combined into a single image, by assigning individual layers to one of the three color channels (red, green and blue):
+<<raster-20b, fig=TRUE , echo=TRUE>>=
+plotRGB(b, r=1, g=2, b=3)
+@
+
+You can also use the a number of other plotting functions with a \verb at Raster@ object as argument, including {\bf hist, persp, contour}, and {\bf density}. See the help files for more info.
+
+
+
+\section{Writing files}
+
+\subsection{File format}
+
+Raster can read most, and write several raster file formats, via the \verb at rgdal@ package. However, it directly reads and writes a native 'rasterfile' format. A rasterfile consists of two files: a binary sequential data file and a text header file. The header file is of the "windows .ini" type. When reading, you do not have to specify the file format, but you do need to do that when writing (except when using the default native format). This file format is also used in DIVA-GIS (\url{htt [...]
+
+
+
+\section{Helper functons}
+
+The cell number is an important concept in the raster package. Raster data can be thought of as a matrix, but in a \verb at RasterLayer@ it is more commonly treated as a vector. Cells are numbered from the upper left cell to the upper right cell and then continuing on the left side of the next row, and so on until the last cell at the lower-right side of the raster. There are several helper functions to determine the column or row number from a cell and vice versa, and to determine the cell [...]
+
+<<raster-15>>=
+library(raster)
+r <- raster(ncol=36, nrow=18)
+ncol(r)
+nrow(r)
+ncell(r)
+rowFromCell(r, 100)
+colFromCell(r, 100)
+cellFromRowCol(r,5,5)
+xyFromCell(r, 100)
+cellFromXY(r, c(0,0))
+colFromX(r, 0)
+rowFromY(r, 0)
+@
+
+
+\section{Accessing cell values}
+
+Cell values can be accessed with several methods. Use {\bf getValues} to get all values or a single row; and {\bf getValuesBlock} to read a block (rectangle) of cell values.
+
+<<raster-20>>=
+r <- raster(system.file("external/test.grd", package="raster"))
+v <- getValues(r, 50)
+v[35:39]
+getValuesBlock(r, 50, 1, 35, 5)
+@
+
+
+You can also read values using cell numbers or coordinates (xy) using the {\bf extract} method.
+<<raster-21>>=
+cells <- cellFromRowCol(r, 50, 35:39)
+cells
+extract(r, cells)
+xy = xyFromCell(r, cells)
+xy
+extract(r, xy)
+@
+
+
+You can also extract values using SpatialPolygons* or SpatialLines*. The default approach for extracting raster values with polygons is that a polygon has to cover the center of a cell, for the cell to be included. However, you can use argument "weights=TRUE" in which case you get, apart from the cell values, the percentage of each cell that is covered by the polygon, so that you can apply, e.g., a "50\% area covered" threshold, or compute an area-weighted average.
+
+In the case of lines, any cell that is crossed by a line is included. For lines and points, a cell that is only 'touched' is included when it is below or to the right (or both) of the line segment/point (except for the bottom row and right-most column).
+
+In addition, you can use standard \R indexing to access values, or to replace values (assign new values to cells) in a \verb at Raster@ object. If you replace a value in a \verb at Raster@ object based on a file, the connection to that file is lost (because it now is different from that file). Setting raster values for very large files will be very slow with this approach as each time a new (temporary) file, with all the values, is written to disk. If you want to overwrite values in an existin [...]
+
+<<raster-32>>=
+r[cells]
+r[1:4]
+filename(r)
+r[2:3] <- 10
+r[1:4]
+filename(r)
+@
+
+Note that in the above examples values are retrieved using cell numbers. That is, a raster is represented as a (one-dimensional) vector. Values can also be inspected using a (two-dimensional) matrix notation. As for \R matrices, the first index represents the row number, the second the column number.
+
+<<raster-33>>=
+r[1]
+r[2,2]
+r[1,]
+r[,2]
+r[1:3,1:3]
+
+# keep the matrix structure
+r[1:3,1:3, drop=FALSE]
+@
+
+Accessing values through this type of indexing should be avoided inside functions as it is less efficient than accessing values via functions like {\bf getValues}.
+
+
+
+\section{Session options}
+
+There is a number of session options that influence reading and writing files. These can be set in a session, with \verb at rasterOptions@, and saved to make them persistent in between sessions. But you probably should not change the default values unless you have pressing need to do so. You can, for example, set the directory where temporary files are written, and set your preferred default file format and data type. Some of these settings can be overwritten by arguments to functions where [...]
+
+<<raster-119>>=
+rasterOptions()
+@
+
+
+\section{Coercion to objects of other classes}
+
+Although the raster package defines its own set of classes, it is easy to coerce objects of these classes to objects of the 'spatial' family defined in the sp package. This allows for using functions defined by sp (e.g. spplot) and for using other packages that expect spatial* objects. To create a Raster object from variable n in a SpatialGrid* x use \verb at raster(x, n)@ or \verb at stack(x)@ or \verb at brick(x)@. Vice versa use \verb at as( , )@
+
+You can also convert objects of class "im" (spatstat) and "asc" (adehabitat) to a \verb at RasterLayer@ and "kasc" (adehabitat) to a \verb at RasterStack@ or Brick using the \verb at raster(x)@, \verb at stack(x)@ or \verb at brick(x)@ function.
+
+<<raster-120>>=
+r1 <- raster(ncol=36, nrow=18)
+r2 <- r1
+r1[] <- runif(ncell(r1))
+r2[] <- runif(ncell(r1))
+s <- stack(r1, r2)
+sgdf <- as(s, 'SpatialGridDataFrame')
+newr2 <- raster(sgdf, 2)
+news <- stack(sgdf)
+@
+
+
+\section{Extending raster objects}
+
+It is straightforward to build on the Raster* objects using the S4 inheritance mechanism. Say you need objects that behave like a \verb at RasterLayer@, but have some additional properties that you need to use in your own functions (S4 methods). See Chambers (2009) and the help pages of the Methods package for more info. Below is an example:
+
+<<raster-132>>=
+setClass ('myRaster',
+ contains = 'RasterLayer',
+ representation (
+ important = 'data.frame',
+ essential = 'character'
+ ) ,
+ prototype (
+ important = data.frame(),
+ essential = ''
+ )
+)
+
+r = raster(nrow=10, ncol=10)
+
+m <- as(r, 'myRaster')
+m at important <- data.frame(id=1:10, value=runif(10))
+m at essential <- 'my own slot'
+m[] <- 1:ncell(m)
+@
+
+<<raster-133>>=
+setMethod ('show' , 'myRaster',
+ function(object) {
+ callNextMethod(object) # call show(RasterLayer)
+ cat('essential:', object at essential, '\n')
+ cat('important information:\n')
+ print( object at important)
+ })
+
+m
+@
+
+
+
+\section{References}
+
+\begin{hangparas}{3em}{1}
+
+\noindent Bivand, R.S., E.J. Pebesma and V. Gomez-Rubio, 2008. Applied Spatial Data Analysis with \R. Springer. 378p.
+
+\noindent Chambers, J.M., 2009. Software for Data Analysis: Programming with \R. Springer. 498p.
+
+\end{hangparas}
+
+
+\end{document}
diff --git a/inst/doc/Raster.pdf b/inst/doc/Raster.pdf
new file mode 100644
index 0000000..7e69806
Binary files /dev/null and b/inst/doc/Raster.pdf differ
diff --git a/inst/doc/functions.R b/inst/doc/functions.R
new file mode 100644
index 0000000..02fd6dc
--- /dev/null
+++ b/inst/doc/functions.R
@@ -0,0 +1,343 @@
+### R code from vignette source 'functions.Rnw'
+### Encoding: ISO8859-1
+
+###################################################
+### code chunk number 1: code-1
+###################################################
+library(raster)
+r <- raster(ncol=10, nrow=10)
+r[] <- 1:100
+r
+
+
+###################################################
+### code chunk number 2: code-2
+###################################################
+f1 <- function(x, a) {
+ x at data@values <- x at data@values + a
+ return(x)
+}
+s <- f1(r, 5)
+s
+
+
+###################################################
+### code chunk number 3: code-3
+###################################################
+f2 <- function(x, a) {
+ v <- getValues(x)
+ v <- v + a
+ x <- setValues(x, v)
+ return(x)
+}
+s <- f2(r, 5)
+s
+
+
+###################################################
+### code chunk number 4: code-4
+###################################################
+f3 <- function(x, a, filename) {
+ out <- raster(x)
+ out <- writeStart(out, filename, overwrite=TRUE)
+ for (r in 1:nrow(out)) {
+ v <- getValues(x, r)
+ v <- v + a
+ out <- writeValues(out, v, r)
+ }
+ out <- writeStop(out)
+ return(out)
+}
+s <- f3(r, 5, filename='test')
+s
+
+
+###################################################
+### code chunk number 5: code-5
+###################################################
+f4 <- function(x, a, filename) {
+ out <- raster(x)
+ bs <- blockSize(out)
+ out <- writeStart(out, filename, overwrite=TRUE)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ }
+ out <- writeStop(out)
+ return(out)
+}
+s <- f4(r, 5, filename='test.grd')
+blockSize(s)
+
+
+###################################################
+### code chunk number 6: code-6
+###################################################
+f5 <- function(x, a, filename='') {
+ out <- raster(x)
+ small <- canProcessInMemory(out, 3)
+ filename <- trim(filename)
+
+ if (!small & filename == '') {
+ filename <- rasterTmpFile()
+ }
+
+ todisk <- FALSE
+ if (filename != '') {
+ out <- writeStart(out, filename, overwrite=TRUE)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ }
+
+ for (r in 1:nrow(out)) {
+ v <- getValues(x, r)
+ v <- v + a
+ if (todisk) {
+ out <- writeValues(out, v, r)
+ } else {
+ vv[,r] <- v
+ }
+ }
+ if (todisk) {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ return(out)
+}
+s <- f5(r, 5)
+
+
+###################################################
+### code chunk number 7: code-7
+###################################################
+f6 <- function(x, a, filename='') {
+ out <- raster(x)
+ small <- canProcessInMemory(out, 3)
+ filename <- trim(filename)
+
+ if (! small & filename == '') {
+ filename <- rasterTmpFile()
+ }
+ if (filename != '') {
+ out <- writeStart(out, filename, overwrite=TRUE)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ todisk <- FALSE
+ }
+
+ bs <- blockSize(r)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ if (todisk) {
+ out <- writeValues(out, v, bs$row[i])
+ } else {
+ cols <- bs$row[i]:(bs$row[i]+bs$nrows[i]-1)
+ vv[,cols] <- matrix(v, nrow=ncol(out))
+ }
+ }
+ if (todisk) {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ return(out)
+}
+
+s <- f6(r, 5)
+
+
+###################################################
+### code chunk number 8: code-8
+###################################################
+f7 <- function(x, a, filename='') {
+
+ out <- raster(x)
+ filename <- trim(filename)
+
+ if (canProcessInMemory(out, 3)) {
+ v <- getValues(x) + a
+ out <- setValues(out, v)
+ if (filename != '') {
+ out <- writeRaster(out, filename, overwrite=TRUE)
+ }
+ } else {
+ if (filename == '') {
+ filename <- rasterTmpFile()
+ }
+ out <- writeStart(out, filename)
+
+ bs <- blockSize(r)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ }
+ out <- writeStop(out)
+ }
+ return(out)
+}
+
+s <- f7(r, 5)
+
+
+###################################################
+### code chunk number 9: code-9
+###################################################
+f8 <- function(x, a, filename='', ...) {
+ out <- raster(x)
+ big <- ! canProcessInMemory(out, 3)
+ filename <- trim(filename)
+ if (big & filename == '') {
+ filename <- rasterTmpFile()
+ }
+ if (filename != '') {
+ out <- writeStart(out, filename, ...)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ todisk <- FALSE
+ }
+
+ bs <- blockSize(x)
+ pb <- pbCreate(bs$n, ...)
+
+ if (todisk) {
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ pbStep(pb, i)
+ }
+ out <- writeStop(out)
+ } else {
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ cols <- bs$row[i]:(bs$row[i]+bs$nrows[i]-1)
+ vv[,cols] <- matrix(v, nrow=out at ncols)
+ pbStep(pb, i)
+ }
+ out <- setValues(out, as.vector(vv))
+ }
+ pbClose(pb)
+ return(out)
+}
+
+s <- f8(r, 5, filename='test', overwrite=TRUE)
+
+if(require(rgdal)) { # only if rgdal is installed
+ s <- f8(r, 5, filename='test.tif', format='GTiff', overwrite=TRUE)
+}
+s
+
+
+###################################################
+### code chunk number 10: code-10
+###################################################
+if (!isGeneric("f9")) {
+ setGeneric("f9", function(x, ...)
+ standardGeneric("f9"))
+}
+
+
+setMethod('f9', signature(x='RasterLayer'),
+ function(x, filename='', ...) {
+ return(x)
+ }
+)
+
+s <- f9(r)
+
+
+###################################################
+### code chunk number 11: code-clus1
+###################################################
+clusfun <- function(x, filename="", ...) {
+
+ out <- raster(x)
+
+ cl <- getCluster()
+ on.exit( returnCluster() )
+
+ nodes <- length(cl)
+
+ bs <- blockSize(x, minblocks=nodes*4)
+ pb <- pbCreate(bs$n)
+
+ # the function to be used (simple example)
+ clFun <- function(i) {
+ v <- getValues(x, bs$row[i], bs$nrows[i])
+ for (i in 1:length(v)) {
+ v[i] <- v[i] / 100
+ }
+ return(v)
+ }
+
+ # get all nodes going
+ for (i in 1:nodes) {
+ sendCall(cl[[i]], clFun, i, tag=i)
+ }
+
+ filename <- trim(filename)
+ if (!canProcessInMemory(out) & filename == "") {
+ filename <- rasterTmpFile()
+ }
+
+ if (filename != "") {
+ out <- writeStart(out, filename=filename, ... )
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ }
+ for (i in 1:bs$n) {
+ # receive results from a node
+ d <- recvOneData(cl)
+
+ # error?
+ if (! d$value$success) {
+ stop('cluster error')
+ }
+
+ # which block is this?
+ b <- d$value$tag
+ cat('received block: ',b,'\n'); flush.console();
+
+ if (filename != "") {
+ out <- writeValues(out, d$value$value, bs$row[b])
+ } else {
+ cols <- bs$row[b]:(bs$row[b] + bs$nrows[b]-1)
+ vv[,cols] <- matrix(d$value$value, nrow=out at ncols)
+ }
+
+ # need to send more data?
+ ni <- nodes + i
+ if (ni <= bs$n) {
+ sendCall(cl[[d$node]], clFun, ni, tag=ni)
+ }
+ pbStep(pb)
+ }
+ if (filename != "") {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ pbClose(pb)
+
+ return(out)
+}
+
+
+###################################################
+### code chunk number 12: code-clus2
+###################################################
+r <- raster()
+# beginCluster()
+r[] <- ncell(r):1
+# x <- clusfun(r)
+# endCluster()
+
+
diff --git a/inst/doc/functions.Rnw b/inst/doc/functions.Rnw
new file mode 100644
index 0000000..b3c5804
--- /dev/null
+++ b/inst/doc/functions.Rnw
@@ -0,0 +1,416 @@
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage[utf8]{inputenc}
+\usepackage{hyperref}
+
+%\VignetteIndexEntry{Writing functions for large raster files}
+
+\newcommand{\R}{{\normalfont\textsf{R }}{}}
+
+\SweaveOpts{keep.source=TRUE}
+
+\begin{document}
+
+
+\title{Writing functions with the "raster" package}
+\author{Robert J. Hijmans}
+\maketitle
+
+
+\section{Introduction}
+
+The '\verb at raster@' package has a number of 'low-level' functions (e.g. to read and write files) that allow you to write your own 'high-level' functions. Here I explain how to use these low-level functions in developing 'memory-safe' high-level functions. With 'memory-safe' I refer to function that can process raster files that are too large to be loaded into memory. To understand the material discussed in this vignette you should be already somewhat familiar with the raster package. It [...]
+
+I should also note that if you are not sure, you probably do not need to read this vignette, or use the functions described herein. That is, the high-level functions in the raster package are already based on these techniques, and they are very flexible. It is likely that you can accomplish your goals with the functions already available in 'raster' and that you do not need to write your own.
+
+\section{How not to do it}
+
+Let's start with two simple example functions, f1 and f2, that are NOT memory safe. The purpose of these simple example functions is to add a numerical constant 'a' to all values of RasterLayer 'x'.
+
+To test the functions, we create a RasterLayer with 100 cells and values 1 to 100.
+<<code-1>>=
+library(raster)
+r <- raster(ncol=10, nrow=10)
+r[] <- 1:100
+r
+@
+
+Below is a simple function, f1, that we use to add 5 to all cell values of 'r'
+
+<<code-2>>=
+f1 <- function(x, a) {
+ x at data@values <- x at data@values + a
+ return(x)
+}
+s <- f1(r, 5)
+s
+@
+
+f1 is a really bad example. It looks efficient but it has several problems. First of all, the slot x at data@values may be empty, which is typically the case when a raster object is derived from a file on disk. But even if all values are in memory the returned object will be invalid. This is because the values of a multiple slots need to be adjusted when changing values. For example, the returned 'x' may still point to a file (now incorrectly, because the values no longer correspond to it). [...]
+
+<<code-3>>=
+f2 <- function(x, a) {
+ v <- getValues(x)
+ v <- v + a
+ x <- setValues(x, v)
+ return(x)
+}
+s <- f2(r, 5)
+s
+@
+
+f2 is much better than f1. Function {\bf getValues} gets the cell values whether they are on disk or in memory (and will return NA values if neither is the case). {\bf setValues} sets the values to the RasterLayer object assuring that other slots are updated as well.
+
+However, this function could fail when used with very large raster files, depending on the amount of RAM your computer has and that \R can access, because all values are read into memory at once. Processing data in chunks circumvents this problem.
+
+
+\section{Row by row}
+
+The next example shows how you can read, process, and write values row by row.
+
+<<code-4>>=
+f3 <- function(x, a, filename) {
+ out <- raster(x)
+ out <- writeStart(out, filename, overwrite=TRUE)
+ for (r in 1:nrow(out)) {
+ v <- getValues(x, r)
+ v <- v + a
+ out <- writeValues(out, v, r)
+ }
+ out <- writeStop(out)
+ return(out)
+}
+s <- f3(r, 5, filename='test')
+s
+@
+
+Note how, in the above example, first a new empty RasterLayer, 'out' is created using the {bf raster} function. 'out' has the same extent and resolution as 'x', but it does not have the values of 'x'.
+
+
+\section{Multiple rows at once}
+
+Row by row processing is easy to do but it can be a bit inefficient because there is some overhead associated with each read and write operation. An alternative is to read, calculate, and write by block; here defined as a number of rows (1 or more). The function {bf blockSize} is a helper function to determine appropriate block size (number of rows).
+
+<<code-5>>=
+f4 <- function(x, a, filename) {
+ out <- raster(x)
+ bs <- blockSize(out)
+ out <- writeStart(out, filename, overwrite=TRUE)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ }
+ out <- writeStop(out)
+ return(out)
+}
+s <- f4(r, 5, filename='test.grd')
+blockSize(s)
+@
+
+
+\section{Filename optional}
+
+In the above examples (functions f3 and f4) you must supply a filename. However, in the raster package that is never the case, it is always optional. If a filename is provided, values are written to disk. If no filename is provided the values are only written to disk if they cannot be stored in RAM. To determine whether the output needs to be written to disk, the function {\bf canProcessInMemory} is used. This function uses the size of the output raster to determine the total memory size [...]
+
+
+First an example for row by row processing:
+
+<<code-6>>=
+f5 <- function(x, a, filename='') {
+ out <- raster(x)
+ small <- canProcessInMemory(out, 3)
+ filename <- trim(filename)
+
+ if (!small & filename == '') {
+ filename <- rasterTmpFile()
+ }
+
+ todisk <- FALSE
+ if (filename != '') {
+ out <- writeStart(out, filename, overwrite=TRUE)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ }
+
+ for (r in 1:nrow(out)) {
+ v <- getValues(x, r)
+ v <- v + a
+ if (todisk) {
+ out <- writeValues(out, v, r)
+ } else {
+ vv[,r] <- v
+ }
+ }
+ if (todisk) {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ return(out)
+}
+s <- f5(r, 5)
+@
+
+
+Now, the same function, but looping over blocks of multiple rows, instead of a single row at a time (which can make a function very slow).
+
+<<code-7>>=
+f6 <- function(x, a, filename='') {
+ out <- raster(x)
+ small <- canProcessInMemory(out, 3)
+ filename <- trim(filename)
+
+ if (! small & filename == '') {
+ filename <- rasterTmpFile()
+ }
+ if (filename != '') {
+ out <- writeStart(out, filename, overwrite=TRUE)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ todisk <- FALSE
+ }
+
+ bs <- blockSize(r)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ if (todisk) {
+ out <- writeValues(out, v, bs$row[i])
+ } else {
+ cols <- bs$row[i]:(bs$row[i]+bs$nrows[i]-1)
+ vv[,cols] <- matrix(v, nrow=ncol(out))
+ }
+ }
+ if (todisk) {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ return(out)
+}
+
+s <- f6(r, 5)
+@
+
+
+The next example is an alternative implementation that you might prefer if you wanted to optimize speed when values can be processed in memory. Optimizing for that situation is generally not that important as it tends to be relatively fast in any case. Moreover, while the below example is fine, this may not be an ideal approach for more complex functions as you would have to implement some parts of your algorithm twice. If you are not careful, your function might then give different resu [...]
+
+<<code-8>>=
+f7 <- function(x, a, filename='') {
+
+ out <- raster(x)
+ filename <- trim(filename)
+
+ if (canProcessInMemory(out, 3)) {
+ v <- getValues(x) + a
+ out <- setValues(out, v)
+ if (filename != '') {
+ out <- writeRaster(out, filename, overwrite=TRUE)
+ }
+ } else {
+ if (filename == '') {
+ filename <- rasterTmpFile()
+ }
+ out <- writeStart(out, filename)
+
+ bs <- blockSize(r)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ }
+ out <- writeStop(out)
+ }
+ return(out)
+}
+
+s <- f7(r, 5)
+@
+
+
+\section{A complete function}
+
+Finally, let's add some useful bells and whistles. For example, you may want to specify a file format and data type, be able to overwrite an existing file, and use a progress bar. So far, default values have been used. If you use the below function, the dots '...' allow you to change these by providing additional arguments 'overwrite', 'format', and 'datatype'. (In all cases you can also set default values with the {\bf rasterOptions} function).
+
+
+<<code-9>>=
+f8 <- function(x, a, filename='', ...) {
+ out <- raster(x)
+ big <- ! canProcessInMemory(out, 3)
+ filename <- trim(filename)
+ if (big & filename == '') {
+ filename <- rasterTmpFile()
+ }
+ if (filename != '') {
+ out <- writeStart(out, filename, ...)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ todisk <- FALSE
+ }
+
+ bs <- blockSize(x)
+ pb <- pbCreate(bs$n, ...)
+
+ if (todisk) {
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ pbStep(pb, i)
+ }
+ out <- writeStop(out)
+ } else {
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ cols <- bs$row[i]:(bs$row[i]+bs$nrows[i]-1)
+ vv[,cols] <- matrix(v, nrow=out at ncols)
+ pbStep(pb, i)
+ }
+ out <- setValues(out, as.vector(vv))
+ }
+ pbClose(pb)
+ return(out)
+}
+
+s <- f8(r, 5, filename='test', overwrite=TRUE)
+
+if(require(rgdal)) { # only if rgdal is installed
+ s <- f8(r, 5, filename='test.tif', format='GTiff', overwrite=TRUE)
+}
+s
+@
+
+Note that most of the additional arguments are passed on to writeStart:
+
+\texttt{out <- writeStart(out, filename, ...)}
+
+Only the \texttt{progress=} argument goes to \texttt{pbCreate}
+
+
+\section{Debugging}
+
+Typically functions are developed and tested with small (RasterLayer) objects. But you also need to test your functions for the case it needs to write values to disk. You can use a very large raster for that, but then you may need to wait a long time each time you run it. Depending on how you design your function you may be able to test alternate forks in your function by providing a file name. But this would not necessarily work for function f7. You can force functions of that type to t [...]
+
+
+\section{Methods}
+
+The raster package is build with S4 classes and methods. If you are developing a package that builds on the raster package I would advise to also use S4 classes and methods. Thus, rather than using plain functions, define generic methods (where necessary) and implement them for a RasterLayer, as in the example below (the function does not do anything; replace 'return(x)' with something meaningful along the pattern explained above.
+
+<<code-10>>=
+if (!isGeneric("f9")) {
+ setGeneric("f9", function(x, ...)
+ standardGeneric("f9"))
+}
+
+
+setMethod('f9', signature(x='RasterLayer'),
+ function(x, filename='', ...) {
+ return(x)
+ }
+)
+
+s <- f9(r)
+@
+
+
+\section{Mutli-core functions}
+
+Below is an example of an implementation of a customized raster function that can use multiple processors (cores), via the snow package. This is still very much under development, but you can try it at your own risk.
+
+First we define a snow cluster enabled function. Below is a simple example:
+
+<<code-clus1>>=
+clusfun <- function(x, filename="", ...) {
+
+ out <- raster(x)
+
+ cl <- getCluster()
+ on.exit( returnCluster() )
+
+ nodes <- length(cl)
+
+ bs <- blockSize(x, minblocks=nodes*4)
+ pb <- pbCreate(bs$n)
+
+ # the function to be used (simple example)
+ clFun <- function(i) {
+ v <- getValues(x, bs$row[i], bs$nrows[i])
+ for (i in 1:length(v)) {
+ v[i] <- v[i] / 100
+ }
+ return(v)
+ }
+
+ # get all nodes going
+ for (i in 1:nodes) {
+ sendCall(cl[[i]], clFun, i, tag=i)
+ }
+
+ filename <- trim(filename)
+ if (!canProcessInMemory(out) & filename == "") {
+ filename <- rasterTmpFile()
+ }
+
+ if (filename != "") {
+ out <- writeStart(out, filename=filename, ... )
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ }
+ for (i in 1:bs$n) {
+ # receive results from a node
+ d <- recvOneData(cl)
+
+ # error?
+ if (! d$value$success) {
+ stop('cluster error')
+ }
+
+ # which block is this?
+ b <- d$value$tag
+ cat('received block: ',b,'\n'); flush.console();
+
+ if (filename != "") {
+ out <- writeValues(out, d$value$value, bs$row[b])
+ } else {
+ cols <- bs$row[b]:(bs$row[b] + bs$nrows[b]-1)
+ vv[,cols] <- matrix(d$value$value, nrow=out at ncols)
+ }
+
+ # need to send more data?
+ ni <- nodes + i
+ if (ni <= bs$n) {
+ sendCall(cl[[d$node]], clFun, ni, tag=ni)
+ }
+ pbStep(pb)
+ }
+ if (filename != "") {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ pbClose(pb)
+
+ return(out)
+}
+@
+
+To use snow with raster, you need to set up a cluster first, with 'beginCluster' (only once during a session). After that we can run the function:
+
+<<code-clus2>>=
+r <- raster()
+# beginCluster()
+r[] <- ncell(r):1
+# x <- clusfun(r)
+# endCluster()
+@
+
+\end{document}
diff --git a/inst/doc/functions.pdf b/inst/doc/functions.pdf
new file mode 100644
index 0000000..7b57cc0
Binary files /dev/null and b/inst/doc/functions.pdf differ
diff --git a/inst/doc/rasterfile.Rnw b/inst/doc/rasterfile.Rnw
new file mode 100644
index 0000000..e2bd46c
--- /dev/null
+++ b/inst/doc/rasterfile.Rnw
@@ -0,0 +1,141 @@
+\documentclass{article}
+
+
+%\VignetteIndexEntry{Description of the rasterfile format}
+
+\SweaveOpts{keep.source=TRUE}
+
+\begin{document}
+
+
+\title{The 'rasterfile' format}
+\author{Robert J. Hijmans}
+\maketitle
+
+
+\section{Introduction}
+
+The '\verb at raster@' package has a default 'native' file format called 'rasterfile'. This file format is used because it is simple, flexible and extensible and does not require rgdal, which may be difficult to install. The '\verb at raster@' package can read and write other formats via the '\verb at rgdal@' package.
+
+The rasterfile format is highly similar to many other formats used for raster data. It consists of two files. One file with sequential binary values (filename extention is '.gri'), and one header file (filename extension is '.grd'). The main source of variation between such file formats is in the header file, and the contents of the rasterfile header file are described here.
+
+The purpose is to standardize the format and help others to read and write files of the same format if they wish to do so. This vignette is aimed at software developers. The typical user of the '\verb at raster@' package does not need to be familiar with it.
+
+\section{ini files}
+
+The header ('.grd') file is organized as an '.ini' file. This is a simple database format that is subdivided in sections indicated with brackets '[]'. Within each section there are variables and their values seperated by the equal '=' sign.
+
+Thus, .ini files have a layout like this:
+
+[section1]
+var1=value
+
+var2=value
+
+[section2]
+
+var3=value
+
+var4=value
+
+
+Variables names must be unique within a section, but the same variable name could occur in multiple sections. This is not done for raster files (variable names are unique) such that section names could be ignored. The '\verb at raster@' package has a convenient function, {\bf readIniFile}, to read .ini files.
+
+
+\section{Sections}
+
+The rasterfile ini format has four sections (general, georeference, data, legend, description) that are discussed below
+
+\subsection{general}
+This section has two variables, 'creator' and 'created'. For example:
+
+[general]
+
+creator=R package 'raster'
+
+created= 2010-03-13 17:26:34
+
+These are metadata that are useful but not strictly required.
+
+\subsection{georeference}
+This section has the number of rows (nrows) and columns (ncols), and describes the spatial extent (bounding box) with four variables (xmin, xmax, ymin, ymax), and the coordinate reference system (projection). These variables are obviously required.
+
+The number of rows and columns are integers >= 1. The extent variables are numeric with xmin < xmax and ymin < ymax. The coordinates refer to the extremes of the outer cells (not to the centers of these cells).
+
+Resolution (cell size) is not specified (it should be derived value from the extent and the number of columns and rows).
+
+The coordinate reference system is specified with the variable 'projection'. Its value should be a string with the PROJ4 syntax. This value can be missing, but that is not recommended!
+
+[georeference]
+
+nrows=100
+
+ncols=100
+
+xmin=-180
+
+ymin=-90
+
+xmax=180
+
+ymax=90
+
+projection=+proj=longlat +datum=WGS84
+
+
+\subsection{data}
+This subsection has information about the file type as well as the cell values. Here is an example
+
+[data]
+
+datatype=FLT4S
+
+nodatavalue=-3.4e+38
+
+byteorder=little
+
+nbands=3
+
+bandorder=BIL
+
+minvalue=1:0:5
+
+maxvalue=255:200:255
+
+
+
+datatype is required. Its values must be one of 'LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT8S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S'.
+The first three letters indicate the type of number that is stored (logical, integer, or float). The fourth character determines how many bytes are used to store these. The last letter inidcates, if applicable, whether the values are singed or not (i.e. whether negative values are possible).
+
+nodatavalue is optional (but necessary if there are nodata (NA) values). It can be any value. But in the raster package the lowest possible value is used for signed integer and float data types and the highest integer is used for unsigned integer types (this is to avoid using 0 as the nodata value).
+
+byteorder is optional but recommended. It should be either 'big' or 'little'. If absent, the raster package assumes that the platform byte order is used.
+
+nbands is required. It indicates the number of layers (bands) stored in the file and hence its values should be an integer >= 1. If absent, the raster package assumes it is 1.
+
+bandorder is required if nbands > 1 and ignored when nbands=1. Values can be 'BIL' (band interleaved by line), 'BIP' (band interleaved by pixel) and 'BSQ' (band sequential). BIL is recommended for most cases.
+
+minvalue and maxvalue indicate the minimum or maximum value in the each layer (excluding NA). If there are mulitple layers, the value are seperated by a colon.
+
+If the values are integers representing a class (e.g. land cover types such as 'forest', 'urban', 'agriculture') four additional keys are required to indicate that these are categorical data and to provide three columns for a 'Raster Attribute Table'. In this case there are three variables (ID, landocver and code). ID refers to the actual cell value, the following are attributed linked to these values. rattypes describe the data type. ID and would normally be 'integer'. Other values allo [...]
+
+categorical=TRUE
+
+ratnames=ID:landcover:code
+
+rattypes=integer:character:numeric
+
+ratvalues=1:2:3:Pine:Oak:Meadow:12:25:30
+
+
+
+\subsection{description}
+
+This section only has the layer names. As above, these are separated by colons. Therefore, colons are not allowed in the layer names. If they occur, they could be replaced with at dot '.'.
+
+[description]
+
+layername=red:green:blue
+
+
+\end{document}
diff --git a/inst/doc/rasterfile.pdf b/inst/doc/rasterfile.pdf
new file mode 100644
index 0000000..c5aac36
Binary files /dev/null and b/inst/doc/rasterfile.pdf differ
diff --git a/inst/external/countries.csv b/inst/external/countries.csv
new file mode 100644
index 0000000..a5e1c1f
--- /dev/null
+++ b/inst/external/countries.csv
@@ -0,0 +1,257 @@
+"NAME","ISO3","ISO2","NAME_ISO","NAME_FAO","NAME_LOCAL","SOVEREIGN","UNREGION1","UNREGION2","CONTINENT"
+"Aruba","ABW","AW","ARUBA","Aruba","Aruba","Nederland","Caribbean","Americas","South America"
+"Afghanistan","AFG","AF","AFGHANISTAN","Afghanistan","Afghanestan","Afghanistan","Southern Asia","Asia","Asia"
+"Angola","AGO","AO","ANGOLA","Angola","Angola","Angola","Middle Africa","Africa","Africa"
+"Anguilla","AIA","AI","ANGUILLA","","Anguilla","United Kingdom","Caribbean","Americas","North America"
+"Åland","ALA","AX","ÅLAND ISLANDS","","Åland","Finland","Northern Europe","Europe","Europe"
+"Albania","ALB","AL","ALBANIA","Albania","Shqiperia","Albania","Southern Europe","Europe","Europe"
+"Andorra","AND","AD","ANDORRA","Andorra","Andorra","Andorra","Southern Europe","Europe","Europe"
+"United Arab Emirates","ARE","AE","UNITED ARAB EMIRATES","United Arab Emirates","Al Imarat al Arabiyah al Muttahidah","United Arab Emirates","Western Asia","Asia","Asia"
+"Argentina","ARG","AR","ARGENTINA","Argentina","Argentina","Argentina","South America","Americas","South America"
+"Armenia","ARM","AM","ARMENIA","Armenia","Hayastan","Armenia","Western Asia","Asia","Asia"
+"American Samoa","ASM","AS","AMERICAN SAMOA","American Samoa","American Samoa","United States","Polynesia","Oceania","Oceania"
+"Antarctica","ATA","AQ","ANTARCTICA","","Antarctica","","Antartica","Antartica","Antarctica"
+"French Southern Territories","ATF","TF","FRENCH SOUTHERN TERRITORIES","","Terres Australes et Antarctiques Françaises","France","","","Africa"
+"Antigua and Barbuda","ATG","AG","ANTIGUA AND BARBUDA","Antigua and Barbuda","Antigua and Barbuda","Antigua and Barbuda","Caribbean","Americas","North America"
+"Australia","AUS","AU","AUSTRALIA","Australia","Australia","Australia","Australia and New Zealand","Oceania","Oceania"
+"Austria","AUT","AT","AUSTRIA","Austria","Österreich","Austria","Western Europe","Europe","Europe"
+"Azerbaijan","AZE","AZ","AZERBAIJAN","Azerbaijan, Republic of","Azarbaycan","Azerbaijan","Western Asia","Asia","Asia"
+"Burundi","BDI","BI","BURUNDI","Burundi","Burundi","Burundi","Eastern Africa","Africa","Africa"
+"Belgium","BEL","BE","BELGIUM","Belgium","Belgique|Belgie|Belgien","Belgie","Western Europe","Europe","Europe"
+"Benin","BEN","BJ","BENIN","Benin","Benin","Benin","Western Africa","Africa","Africa"
+"Bonaire, Saint Eustatius and Saba","BES","AN","BONAIRE, SAINT EUSTATIUS AND SABA","","Bonaire, Saint Eustatius and Saba","Nederland","Caribbean","Americas","South America"
+"Burkina Faso","BFA","BF","BURKINA FASO","Burkina Faso","Burkina Faso","Burkina Faso","Western Africa","Africa","Africa"
+"Bangladesh","BGD","BD","BANGLADESH","Bangladesh","Bangladesh","Bangladesh","Southern Asia","Asia","Asia"
+"Bulgaria","BGR","BG","BULGARIA","Bulgaria","Bulgaria","Bulgaria","Eastern Europe","Europe","Europe"
+"Bahrain","BHR","BH","BAHRAIN","Bahrain","Al Bahrayn","Bahrain","Western Asia","Asia","Asia"
+"Bahamas","BHS","BS","BAHAMAS","Bahamas","Bahamas","Bahamas","Caribbean","Americas","North America"
+"Bosnia and Herzegovina","BIH","BA","BOSNIA AND HERZEGOVINA","Bosnia and Herzegovina","Bosna i Hercegovina","Bosnia and Herzegovina","Southern Europe","Europe","Europe"
+"Saint-Barthélemy","BLM","16","SAINT BARTHELEMY","","","","Caribbean","Americas","North America"
+"Belarus","BLR","BY","BELARUS","Belarus","Byelarus|Byelorussia","Belarus","Eastern Europe","Europe","Europe"
+"Belize","BLZ","BZ","BELIZE","Belize","Belize","Belize","Central America","Americas","North America"
+"Bermuda","BMU","BM","BERMUDA","Bermuda","Bermuda","United Kingdom","Northern America","Americas","North America"
+"Bolivia","BOL","BO","BOLIVIA","Bolivia","Bolivia","Bolivia","South America","Americas","South America"
+"Brazil","BRA","BR","BRAZIL","Brazil","Brasil","Brazil","South America","Americas","South America"
+"Barbados","BRB","BB","BARBADOS","Barbados","Barbados","Barbados","Caribbean","Americas","North America"
+"Brunei","BRN","BN","BRUNEI DARUSSALAM","Brunei Darussalam","Negara Brunei Darussalam","Brunei Darussalam","South-Eastern Asia","Asia","Asia"
+"Bhutan","BTN","BT","BHUTAN","Bhutan","Bhutan","Bhutan","Southern Asia","Asia","Asia"
+"Bouvet Island","BVT","BV","BOUVET ISLAND","","Bouvet Island","Norway","Antartica","Antartica","Antarctica"
+"Botswana","BWA","BW","BOTSWANA","Botswana","Botswana","Botswana","Southern Africa","Africa","Africa"
+"Central African Republic","CAF","CF","CENTRAL AFRICAN REPUBLIC","Central African Republic","Republique Centrafricaine","Central African Republic","Middle Africa","Africa","Africa"
+"Canada","CAN","CA","CANADA","Canada","Canada","Canada","Northern America","Americas","North America"
+"Cocos Islands","CCK","CC","COCOS (KEELING) ISLANDS","","Cocos (Keeling) Islands","Australia","South-Eastern Asia","Asia","Asia"
+"Switzerland","CHE","CH","SWITZERLAND","Switzerland","Schweiz|Suisse|Svizzera","Switzerland","Western Europe","Europe","Europe"
+"Chile","CHL","CL","CHILE","Chile","Chile","Chile","South America","Americas","South America"
+"China","CHN","CN","CHINA","China","Zhong Guo","China","Eastern Asia","Asia","Asia"
+"Côte d'Ivoire","CIV","CI","COTE D'IVOIRE","Côte d'Ivoire","Côte d'Ivoire","Côte d'Ivoire","Western Africa","Africa","Africa"
+"Cameroon","CMR","CM","CAMEROON","Cameroon","Cameroon","Cameroun","Middle Africa","Africa","Africa"
+"Democratic Republic of the Congo","COD","CD","CONGO, THE DEMOCRATIC REPUBLIC OF THE","Congo, Dem Republic of","République Démocratique du Congo|Zaire","The Democratic Republic of the Congo","Middle Africa","Africa","Africa"
+"Republic of Congo","COG","CG","CONGO","Congo, Republic of","République du Congo","Republic of Congo","Middle Africa","Africa","Africa"
+"Cook Islands","COK","CK","COOK ISLANDS","Cook Islands","Cook Islands","New Zealand","Polynesia","Oceania","Oceania"
+"Colombia","COL","CO","COLOMBIA","Colombia","Colombia","Colombia","South America","Americas","South America"
+"Comoros","COM","KM","COMOROS","Comoros","Comores","Comoros","Eastern Africa","Africa","Africa"
+"Cape Verde","CPV","CV","CAPE VERDE","Cape Verde","Cabo Verde","Cabo Verde","Western Africa","Africa","Africa"
+"Costa Rica","CRI","CR","COSTA RICA","Costa Rica","Costa Rica","Costa Rica","Central America","Americas","North America"
+"Cuba","CUB","CU","CUBA","Cuba","Cuba","Cuba","Caribbean","Americas","North America"
+"Curaçao","CUW","4","CURACAO","","Curaçao","","Caribbean","Americas","South America"
+"Christmas Island","CXR","CX","CHRISTMAS ISLAND","","Christmas Island","Australia","South-Eastern Asia","Asia","Asia"
+"Cayman Islands","CYM","KY","CAYMAN ISLANDS","Cayman Islands","Cayman Islands","United Kingdom","Caribbean","Americas","North America"
+"Cyprus","CYP","CY","CYPRUS","Cyprus","Kibris, Kypros","Cyprus","Western Asia","Asia","Asia"
+"Czech Republic","CZE","CZ","CZECH REPUBLIC","Czech Republic","Ceská republika","Czech Republic","Eastern Europe","Europe","Europe"
+"Germany","DEU","DE","GERMANY","Germany","Deutschland","Germany","Western Europe","Europe","Europe"
+"Djibouti","DJI","DJ","DJIBOUTI","Djibouti","Djibouti","Djibouti","Eastern Africa","Africa","Africa"
+"Dominica","DMA","DM","DOMINICA","Dominica","Dominica","Dominica","Caribbean","Americas","North America"
+"Denmark","DNK","DK","DENMARK","Denmark","Danmark","Denmark","Northern Europe","Europe","Europe"
+"Dominican Republic","DOM","DO","DOMINICAN REPUBLIC","Dominican Republic","República Dominicana","República Dominicana","Caribbean","Americas","North America"
+"Algeria","DZA","DZ","ALGERIA","Algeria","Al Jaza'ir","Algeria","Northern Africa","Africa","Africa"
+"Ecuador","ECU","EC","ECUADOR","Ecuador","Ecuador","Ecuador","South America","Americas","South America"
+"Egypt","EGY","EG","EGYPT","Egypt","Misr","Egypt","Northern Africa","Africa","Africa"
+"Eritrea","ERI","ER","ERITREA","Eritrea","Hagere Ertra","Eritrea","Eastern Africa","Africa","Africa"
+"Western Sahara","ESH","EH","WESTERN SAHARA","Western Sahara","Western Sahara","Western Sahara","Northern Africa","Africa","Africa"
+"Spain","ESP","ES","SPAIN","Spain","España","España","Southern Europe","Europe","Europe"
+"Estonia","EST","EE","ESTONIA","Estonia","Eesti Vabariik","Estonia","Northern Europe","Europe","Europe"
+"Ethiopia","ETH","ET","ETHIOPIA","Ethiopia","Ityop'iya","Ethiopia","Eastern Africa","Africa","Africa"
+"Finland","FIN","FI","FINLAND","Finland","Suomi|Suomen Tasavalta","Finland","Northern Europe","Europe","Europe"
+"Fiji","FJI","FJ","FIJI","Fiji Islands","Fiji","Fiji","Melanesia","Oceania","Oceania"
+"Falkland Islands","FLK","FK","FALKLAND ISLANDS (MALVINAS)","","Islas Malvinas","United Kingdom","South America","Americas","South America"
+"France","FRA","FR","FRANCE","France","France","France","Western Europe","Europe","Europe"
+"Faroe Islands","FRO","FO","FAROE ISLANDS","Faroe Islands","Føroyar","Denmark","Northern Europe","Europe","Europe"
+"Micronesia","FSM","FM","MICRONESIA, FEDERATED STATES OF","Micronesia,Fed States of","Micronesia","Micronesia","Micronesia","Oceania","Oceania"
+"Gabon","GAB","GA","GABON","Gabon","Gabon","Gabon","Middle Africa","Africa","Africa"
+"United Kingdom","GBR","GB","UNITED KINGDOM","United Kingdom","United Kingdom","United Kingdom","Northern Europe","Europe","Europe"
+"Georgia","GEO","GE","GEORGIA","Georgia","Sak'art'velo","Georgia","Western Asia","Asia","Asia"
+"Guernsey","GGY","GG","GUERNSEY","","Guernsey","United Kingdom","Western Europe","Europe","Europe"
+"Ghana","GHA","GH","GHANA","Ghana","Ghana","Ghana","Western Africa","Africa","Africa"
+"Gibraltar","GIB","GI","GIBRALTAR","","Gibraltar","United Kingdom","Southern Europe","Europe","Europe"
+"Guinea","GIN","GN","GUINEA","Guinea","Guinee","Guinea","Western Africa","Africa","Africa"
+"Guadeloupe","GLP","GP","GUADELOUPE","Guadeloupe","Guadeloupe","France","Caribbean","Americas","North America"
+"Gambia","GMB","GM","GAMBIA","Gambia","The Gambia","Gambia","Western Africa","Africa","Africa"
+"Guinea-Bissau","GNB","GW","GUINEA-BISSAU","Guinea-Bissau","Guiné-Bissau","Guinea-Bissau","Western Africa","Africa","Africa"
+"Equatorial Guinea","GNQ","GQ","EQUATORIAL GUINEA","Equatorial Guinea","Guinea Ecuatorial","Equatorial Guinea","Middle Africa","Africa","Africa"
+"Greece","GRC","GR","GREECE","Greece","Ellas or Ellada","Hellas","Southern Europe","Europe","Europe"
+"Grenada","GRD","GD","GRENADA","Grenada","Grenada","Grenada","Caribbean","Americas","North America"
+"Greenland","GRL","GL","GREENLAND","","Kalaallit Nunaat","Denmark","Northern America","Americas","North America"
+"Guatemala","GTM","GT","GUATEMALA","Guatemala","Guatemala","Guatemala","Central America","Americas","North America"
+"French Guiana","GUF","GF","FRENCH GUIANA","French Guiana","Guyane","France","South America","Americas","South America"
+"Guam","GUM","GU","GUAM","Guam","Guam","United States","Micronesia","Oceania","Asia"
+"Guyana","GUY","GY","GUYANA","Guyana","Guyana","Guyana","South America","Americas","South America"
+"Hong Kong","HKG","HK","HONG KONG","","Hong Kong","China","Eastern Asia","Asia","Asia"
+"Heard Island and McDonald Islands","HMD","HM","HEARD ISLAND AND MCDONALD ISLANDS","","Heard and Mc Donald","Australia","Antartica","Antartica","Antarctica"
+"Honduras","HND","HN","HONDURAS","Honduras","Honduras","Honduras","Central America","Americas","North America"
+"Croatia","HRV","HR","CROATIA","Croatia","Hrvatska","Croatia","Southern Europe","Europe","Europe"
+"Haiti","HTI","HT","HAITI","Haiti","Haiti","Haiti","Caribbean","Americas","North America"
+"Hungary","HUN","HU","HUNGARY","Hungary","Magyarorszag","Hungary","Eastern Europe","Europe","Europe"
+"Indonesia","IDN","ID","INDONESIA","Indonesia","Indonesia","Indonesia","South-Eastern Asia","Asia","Asia"
+"Isle of Man","IMN","IM","ISLE OF MAN","Isle of Man","Isle of Man","United Kingdom","Western Europe","Europe","Europe"
+"India","IND","IN","INDIA","India","Bharat","India","Southern Asia","Asia","Asia"
+"British Indian Ocean Territory","IOT","IO","BRITISH INDIAN OCEAN TERRITORY","","British Indian Ocean Territory","United Kingdom","Southern Asia","Asia","Asia"
+"Ireland","IRL","IE","IRELAND","Ireland","Éire","Ireland","Northern Europe","Europe","Europe"
+"Iran","IRN","IR","IRAN, ISLAMIC REPUBLIC OF","Iran, Islamic Rep of","Iran","Iran","Southern Asia","Asia","Asia"
+"Iraq","IRQ","IQ","IRAQ","Iraq","Iraq","Iraq","Western Asia","Asia","Asia"
+"Iceland","ISL","IS","ICELAND","Iceland","Lyoveldio Island","Iceland","Northern Europe","Europe","Europe"
+"Israel","ISR","IL","ISRAEL","Israel","Yisra'el","Israel","Western Asia","Asia","Asia"
+"Italy","ITA","IT","ITALY","Italy","Italia","Italy","Southern Europe","Europe","Europe"
+"Jamaica","JAM","JM","JAMAICA","Jamaica","Jamaica","Jamaica","Caribbean","Americas","North America"
+"Jersey","JEY","JE","JERSEY","","Jersey","United Kingdom","Western Europe","Europe","Europe"
+"Jordan","JOR","JO","JORDAN","Jordan","Al Urdun","Jordan","Western Asia","Asia","Asia"
+"Japan","JPN","JP","JAPAN","Japan","Nippon","Japan","Eastern Asia","Asia","Asia"
+"Kazakhstan","KAZ","KZ","KAZAKHSTAN","Kazakhstan","Qazaqstan","Kazakhstan","Central Asia","Asia","Asia"
+"Kenya","KEN","KE","KENYA","Kenya","Kenya","Kenya","Eastern Africa","Africa","Africa"
+"Kyrgyzstan","KGZ","KG","KYRGYZSTAN","Kyrgyzstan","Kyrgyz Respublikasy","Kyrgyzstan","Central Asia","Asia","Asia"
+"Cambodia","KHM","KH","CAMBODIA","Cambodia","Kampuchea","Cambodia","South-Eastern Asia","Asia","Asia"
+"Kiribati","KIR","KI","KIRIBATI","Kiribati","Kiribati|Kiribas","Kiribati","Micronesia","Oceania","Oceania"
+"Saint Kitts and Nevis","KNA","KN","SAINT KITTS AND NEVIS","Saint Kitts and Nevis","Saint Kitts and Nevis","Saint Kitts and Nevis","Caribbean","Americas","North America"
+"South Korea","KOR","KR","KOREA, REPUBLIC OF","Korea, Republic of","Han-guk","South Korea","Eastern Asia","Asia","Asia"
+"Kuwait","KWT","KW","KUWAIT","Kuwait","Al Kuwayt","Kuwait","Western Asia","Asia","Asia"
+"Laos","LAO","LA","LAO PEOPLE'S DEMOCRATIC REPUBLIC","Laos","Lao","Laos","South-Eastern Asia","Asia","Asia"
+"Lebanon","LBN","LB","LEBANON","Lebanon","Lubnan","Lebanon","Western Asia","Asia","Asia"
+"Liberia","LBR","LR","LIBERIA","Liberia","Liberia","Liberia","Western Africa","Africa","Africa"
+"Libya","LBY","LY","LIBYAN ARAB JAMAHIRIYA","Libyan Arab Jamahiriya","Libiyah","Libya","Northern Africa","Africa","Africa"
+"Saint Lucia","LCA","LC","SAINT LUCIA","Saint Lucia","Saint Lucia","Saint Lucia","Caribbean","Americas","North America"
+"Liechtenstein","LIE","LI","LIECHTENSTEIN","Liechtenstein","Liechtenstein","Liechtenstein","Western Europe","Europe","Europe"
+"Sri Lanka","LKA","LK","SRI LANKA","Sri Lanka","Sri Lanka","Sri Lanka","Southern Asia","Asia","Asia"
+"Lesotho","LSO","LS","LESOTHO","Lesotho","Lesotho","Lesotho","Southern Africa","Africa","Africa"
+"Lithuania","LTU","LT","LITHUANIA","Lithuania","Lietuva","Lithuania","Northern Europe","Europe","Europe"
+"Luxembourg","LUX","LU","LUXEMBOURG","Luxembourg","Luxembourg|Letzebuerg","Luxembourg","Western Europe","Europe","Europe"
+"Latvia","LVA","LV","LATVIA","Latvia","Latvija","Latvia","Northern Europe","Europe","Europe"
+"Macao","MAC","MO","MACAO","","Aomen","China","Eastern Asia","Asia","Asia"
+"Saint-Martin","MAF","10","SAINT MARTIN","","","","Caribbean","Americas","North America"
+"Morocco","MAR","MA","MOROCCO","Morocco","Al Maghrib","Morocco","Northern Africa","Africa","Africa"
+"Monaco","MCO","MC","MONACO","","Monaco","Monaco","Western Europe","Europe","Europe"
+"Moldova","MDA","MD","MOLDOVA, REPUBLIC OF","Moldova, Republic of","Moldova","Moldova","Eastern Europe","Europe","Europe"
+"Madagascar","MDG","MG","MADAGASCAR","Madagascar","Madagascar","Madagascar","Eastern Africa","Africa","Africa"
+"Maldives","MDV","MV","MALDIVES","Maldives","Dhivehi Raajje","Maldives","Southern Asia","Asia","Asia"
+"Mexico","MEX","MX","MEXICO","Mexico","México|Estados Unidos Mexicanos","México","Central America","Americas","North America"
+"Marshall Islands","MHL","MH","MARSHALL ISLANDS","Marshall Islands","Marshall Islands","Marshall Islands","Micronesia","Oceania","Oceania"
+"Macedonia","MKD","MK","MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF","Macedonia,The Fmr Yug Rp","Makedonija","Macedonia","Southern Europe","Europe","Europe"
+"Mali","MLI","ML","MALI","Mali","Mali","Mali","Western Africa","Africa","Africa"
+"Malta","MLT","MT","MALTA","Malta","Malta","Malta","Southern Europe","Europe","Europe"
+"Myanmar","MMR","MM","MYANMAR","Myanmar","Myanma Naingngandaw","Myanmar","South-Eastern Asia","Asia","Asia"
+"Montenegro","MNE","ME","MONTENEGRO","","Crna Gora","Montenegro","Southern Europe","Europe","Europe"
+"Mongolia","MNG","MN","MONGOLIA","Mongolia","Mongol Uls","Mongolia","Eastern Asia","Asia","Asia"
+"Northern Mariana Islands","MNP","MP","NORTHERN MARIANA ISLANDS","Northern Mariana Is","Northern Mariana Islands","United States","Micronesia","Oceania","Asia"
+"Mozambique","MOZ","MZ","MOZAMBIQUE","Mozambique","Mocambique","Mozambique","Eastern Africa","Africa","Africa"
+"Mauritania","MRT","MR","MAURITANIA","Mauritania","Muritaniyah","Mauritania","Western Africa","Africa","Africa"
+"Montserrat","MSR","MS","MONTSERRAT","Montserrat","Montserrat","United Kingdom","Caribbean","Americas","North America"
+"Martinique","MTQ","MQ","MARTINIQUE","Martinique","Martinique","France","Caribbean","Americas","North America"
+"Mauritius","MUS","MU","MAURITIUS","Mauritius","Mauritius","Mauritius","Eastern Africa","Africa","Africa"
+"Malawi","MWI","MW","MALAWI","Malawi","Malawi","Malawi","Eastern Africa","Africa","Africa"
+"Malaysia","MYS","MY","MALAYSIA","Malaysia","Malaysia","Malaysia","South-Eastern Asia","Asia","Asia"
+"Mayotte","MYT","YT","MAYOTTE","Mayotte","Mayotte","France","Eastern Africa","Africa","Africa"
+"Namibia","NAM","NA","NAMIBIA","Namibia","Namibia","Namibia","Southern Africa","Africa","Africa"
+"New Caledonia","NCL","NC","NEW CALEDONIA","New Caledonia","Nouvelle-Calédonie","France","Melanesia","Oceania","Oceania"
+"Niger","NER","NE","NIGER","Niger","Niger","Niger","Western Africa","Africa","Africa"
+"Norfolk Island","NFK","NF","NORFOLK ISLAND","","Norfolk Island","Australia","Australia and New Zealand","Oceania","Oceania"
+"Nigeria","NGA","NG","NIGERIA","Nigeria","Nigeria","Nigeria","Western Africa","Africa","Africa"
+"Nicaragua","NIC","NI","NICARAGUA","Nicaragua","Nicaragua","Nicaragua","Central America","Americas","North America"
+"Niue","NIU","NU","NIUE","Niue","Niue","New Zealand","Polynesia","Oceania","Oceania"
+"Netherlands","NLD","NL","NETHERLANDS","Netherlands","Nederland","Nederland","Western Europe","Europe","Europe"
+"Norway","NOR","NO","NORWAY","Norway","Norge","Norway","Northern Europe","Europe","Europe"
+"Nepal","NPL","NP","NEPAL","Nepal","Nepal","Nepal","Southern Asia","Asia","Asia"
+"Nauru","NRU","NR","NAURU","","Nauru","Nauru","Micronesia","Oceania","Oceania"
+"New Zealand","NZL","NZ","NEW ZEALAND","New Zealand","Aotearoa","New Zealand","Australia and New Zealand","Oceania","Oceania"
+"Oman","OMN","OM","OMAN","Oman","Saltanat Uman","Oman","Western Asia","Asia","Asia"
+"Pakistan","PAK","PK","PAKISTAN","Pakistan","Pakistan","Pakistan","Southern Asia","Asia","Asia"
+"Panama","PAN","PA","PANAMA","Panama","Panamá","Panamá","Central America","Americas","North America"
+"Pitcairn Islands","PCN","PN","PITCAIRN","","Pitcairn Island","United Kingdom","Polynesia","Oceania","Oceania"
+"Peru","PER","PE","PERU","Peru","Perú","Perú","South America","Americas","South America"
+"Philippines","PHL","PH","PHILIPPINES","Philippines","Pilipinas","Pilipinas","South-Eastern Asia","Asia","Asia"
+"Paracel Islands","PIS","6","","","","","South-Eastern Asia","Asia","Asia"
+"Palau","PLW","PW","PALAU","Palau","Belau","United States","Micronesia","Oceania","Asia"
+"Papua New Guinea","PNG","PG","PAPUA NEW GUINEA","Papua New Guinea","Papua Niu Gini","Papua New Guinea","Melanesia","Oceania","Oceania"
+"Poland","POL","PL","POLAND","Poland","Polska","Poland","Eastern Europe","Europe","Europe"
+"Puerto Rico","PRI","PR","PUERTO RICO","Puerto Rico","Puerto Rico","United States","Caribbean","Americas","North America"
+"North Korea","PRK","KP","KOREA, DEMOCRATIC PEOPLE'S REPUBLIC OF","Korea, Dem People's Rep","Choson","North Korea","Eastern Asia","Asia","Asia"
+"Portugal","PRT","PT","PORTUGAL","Portugal","Portugal","Portugal","Southern Europe","Europe","Europe"
+"Paraguay","PRY","PY","PARAGUAY","Paraguay","Paraguay","Paraguay","South America","Americas","South America"
+"Palestina","PSE","PS","PALESTINIAN TERRITORY, OCCUPIED","Palestine, Occupied Tr.","Filastin","Palestina","Western Asia","Asia","Asia"
+"French Polynesia","PYF","PF","FRENCH POLYNESIA","French Polynesia","Polynésie Française","France","Polynesia","Oceania","Oceania"
+"Qatar","QAT","QA","QATAR","Qatar","Dawlat Qatar","Qatar","Western Asia","Asia","Asia"
+"Reunion","REU","RE","REUNION","Réunion","Réunion|Ile de la Réunion","France","Eastern Africa","Africa","Africa"
+"Romania","ROU","RO","ROMANIA","Romania","Romania","Romania","Eastern Europe","Europe","Europe"
+"Russia","RUS","RU","RUSSIAN FEDERATION","Russian Federation","Rossiya","Russia","Eastern Europe","Europe","Europe"
+"Rwanda","RWA","RW","RWANDA","Rwanda","Rwanda","Rwanda","Eastern Africa","Africa","Africa"
+"Saudi Arabia","SAU","SA","SAUDI ARABIA","Saudi Arabia","Al Arabiyah as Suudiyah","Saudi Arabia","Western Asia","Asia","Asia"
+"Sudan","SDN","SD","SUDAN","Sudan","As-Sudan","Sudan","Northern Africa","Africa","Africa"
+"Senegal","SEN","SN","SENEGAL","Senegal","Senegal","Senegal","Western Africa","Africa","Africa"
+"Singapore","SGP","SG","SINGAPORE","Singapore","Singapore","Singapore","South-Eastern Asia","Asia","Asia"
+"South Georgia and the South Sandwich Islands","SGS","GS","SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS","","South Georgia and the South Sandwich Islands","United Kingdom","Antartica","Antartica","Antarctica"
+"Saint Helena","SHN","SH","SAINT HELENA","Saint Helena","Saint Helena","United Kingdom","Western Africa","Africa","Africa"
+"Svalbard and Jan Mayen","SJM","SJ","SVALBARD AND JAN MAYEN","","Svalbard and Jan Mayen","Norway","Northern Europe","Europe","Europe"
+"Solomon Islands","SLB","SB","SOLOMON ISLANDS","Solomon Islands","Solomon Islands","Solomon Islands","Melanesia","Oceania","Oceania"
+"Sierra Leone","SLE","SL","SIERRA LEONE","Sierra Leone","Sierra Leone","Sierra Leone","Western Africa","Africa","Africa"
+"El Salvador","SLV","SV","EL SALVADOR","El Salvador","El Salvador","El Salvador","Central America","Americas","North America"
+"San Marino","SMR","SM","SAN MARINO","San Marino","San Marino","San Marino","Southern Europe","Europe","Europe"
+"Somalia","SOM","SO","SOMALIA","Somalia","Somalia","Somalia","Eastern Africa","Africa","Africa"
+"Spratly islands","SP-","17","","","Spratly islands","Disputed (Pilipinas, China, Vietnam)","South-Eastern Asia","Asia","Asia"
+"Saint Pierre and Miquelon","SPM","PM","SAINT PIERRE AND MIQUELON","Saint Pierre & Miquelon","Saint-Pierre et Miquelon","France","Northern America","Americas","North America"
+"Serbia","SRB","RS","SERBIA","Serbia and Montenegro","Srbija","Serbia","Southern Europe","Europe","Europe"
+"South Sudan","SSD","7","SOUTH SUDAN","South Sudan","","","Middle Africa","Africa","Africa"
+"Sao Tome and Principe","STP","ST","SAO TOME AND PRINCIPE","Sao Tome and Principe","São Tomé and Príncipe","São Tomé and Príncipe","Middle Africa","Africa","Africa"
+"Suriname","SUR","SR","SURINAME","Suriname","Suriname","Suriname","South America","Americas","South America"
+"Slovakia","SVK","SK","SLOVAKIA","Slovakia","Slovensko","Slovakia","Eastern Europe","Europe","Europe"
+"Slovenia","SVN","SI","SLOVENIA","Slovenia","Slovenija|Republika Slovenija","Slovenia","Southern Europe","Europe","Europe"
+"Sweden","SWE","SE","SWEDEN","Sweden","Sverige","Sweden","Northern Europe","Europe","Europe"
+"Swaziland","SWZ","SZ","SWAZILAND","Swaziland","Swaziland","Swaziland","Southern Africa","Africa","Africa"
+"Sint Maarten","SXM","2","SINT MAARTEN","","Sint Maarten","","Caribbean","Americas","North America"
+"Seychelles","SYC","SC","SEYCHELLES","Seychelles","Seychelles","Seychelles","Eastern Africa","Africa","Africa"
+"Syria","SYR","SY","SYRIAN ARAB REPUBLIC","Syrian Arab Republic","Suriyah","Syria","Western Asia","Asia","Asia"
+"Turks and Caicos Islands","TCA","TC","TURKS AND CAICOS ISLANDS","Turks and Caicos Is","Turks and Caicos Islands","United Kingdom","Caribbean","Americas","North America"
+"Chad","TCD","TD","CHAD","Chad","Tchad","Chad","Middle Africa","Africa","Africa"
+"Togo","TGO","TG","TOGO","Togo","Togo|Republique Togolaise","Togo","Western Africa","Africa","Africa"
+"Thailand","THA","TH","THAILAND","Thailand","Prathet Thai","Thailand","South-Eastern Asia","Asia","Asia"
+"Tajikistan","TJK","TJ","TAJIKISTAN","Tajikistan","Jumhurii Tojikiston","Tajikistan","Central Asia","Asia","Asia"
+"Tokelau","TKL","TK","TOKELAU","","Tokelau","New Zealand","Polynesia","Oceania","Oceania"
+"Turkmenistan","TKM","TM","TURKMENISTAN","Turkmenistan","Turkmenistan","Turkmenistan","Central Asia","Asia","Asia"
+"East Timor","TLS","TL","TIMOR-LESTE","Timor-Leste","Timor-Leste","Timor-Leste","South-Eastern Asia","Asia","Asia"
+"Tonga","TON","TO","TONGA","Tonga","Tonga","Tonga","Polynesia","Oceania","Oceania"
+"Trinidad and Tobago","TTO","TT","TRINIDAD AND TOBAGO","Trinidad and Tobago","Trinidad and Tobago","Trinidad and Tobago","Caribbean","Americas","South America"
+"Tunisia","TUN","TN","TUNISIA","Tunisia","Tunis","Tunisia","Northern Africa","Africa","Africa"
+"Turkey","TUR","TR","TURKEY","Turkey","Turkiye","Turkey","Western Asia","Asia","Asia"
+"Tuvalu","TUV","TV","TUVALU","Tuvalu","Tuvalu","Tuvalu","Polynesia","Oceania","Oceania"
+"Taiwan","TWN","TW","TAIWAN, PROVINCE OF CHINA","","T'ai-wan","Taiwan","Eastern Asia","Asia","Asia"
+"Tanzania","TZA","TZ","TANZANIA, UNITED REPUBLIC OF","Tanzania, United Rep of","Tanzania","Tanzania","Eastern Africa","Africa","Africa"
+"Uganda","UGA","UG","UGANDA","Uganda","Uganda","Uganda","Eastern Africa","Africa","Africa"
+"Ukraine","UKR","UA","UKRAINE","Ukraine","Ukrayina","Ukraine","Eastern Europe","Europe","Europe"
+"United States Minor Outlying Islands","UMI","UM","UNITED STATES MINOR OUTLYING ISLANDS","","United States Minor Outlying Island","United States","","","Oceania"
+"Uruguay","URY","UY","URUGUAY","Uruguay","Uruguay|República Oriental del Uruguay","Uruguay","South America","Americas","South America"
+"United States","USA","US","UNITED STATES","United States of America","United States","United States","Northern America","Americas","North America"
+"Uzbekistan","UZB","UZ","UZBEKISTAN","Uzbekistan","Uzbekiston Respublikasi","Uzbekistan","Central Asia","Asia","Asia"
+"Vatican City","VAT","VA","HOLY SEE (VATICAN CITY STATE)","","Status Civitatis Vaticanæ","Vatican","Southern Europe","Europe","Europe"
+"Saint Vincent and the Grenadines","VCT","VC","SAINT VINCENT AND THE GRENADINES","Saint Vincent/Grenadines","Saint Vincent and the Grenadines","Saint Vincent and the Grenadines","Caribbean","Americas","North America"
+"Venezuela","VEN","VE","VENEZUELA","Venezuela,Bolivar Rep of","Venezuela","Venezuela","South America","Americas","South America"
+"British Virgin Islands","VGB","VG","VIRGIN ISLANDS, BRITISH ","British Virgin Islands","British Virgin Islands","United Kingdom","Caribbean","Americas","North America"
+"Virgin Islands, U.S.","VIR","VI","VIRGIN ISLANDS, U.S.","US Virgin Islands","Virgin Islands","United States","Caribbean","Americas","North America"
+"Vietnam","VNM","VN","VIET NAM","Viet Nam","Viet Nam","Vietnam","South-Eastern Asia","Asia","Asia"
+"Vanuatu","VUT","VU","VANUATU","Vanuatu","Vanuatu","Vanuatu","Melanesia","Oceania","Oceania"
+"Wallis and Futuna","WLF","WF","WALLIS AND FUTUNA","Wallis and Futuna Is","Wallis et Futuna","France","Polynesia","Oceania","Oceania"
+"Samoa","WSM","WS","SAMOA","Samoa","Samoa","Samoa","Polynesia","Oceania","Oceania"
+"Akrotiri and Dhekelia","XAD","3","AKROTIRI AND DHEKELIA","","Akrotiri and Dhekelia","","Western Asia","Asia","Asia"
+"Caspian Sea","XCA","12","","","Caspian Sea","","","","Asia"
+"Clipperton Island","XCL","8","","","Clipperton Island","","Central America","Americas","North America"
+"Kosovo","XKO","13","<Null>","","Kosova","","Southern Europe","Europe","Europe"
+"Northern Cyprus","XNC","11","NOTHERN CYPRUS","","","","Western Asia","Asia","Asia"
+"Yemen","YEM","YE","YEMEN","Yemen","Al Yaman","Yemen","Western Asia","Asia","Asia"
+"South Africa","ZAF","ZA","SOUTH AFRICA","South Africa","South Africa","South Africa","Southern Africa","Africa","Africa"
+"Zambia","ZMB","ZM","ZAMBIA","Zambia","Zambia","Zambia","Eastern Africa","Africa","Africa"
+"Zimbabwe","ZWE","ZW","ZIMBABWE","Zimbabwe","Zimbabwe","Zimbabwe","Eastern Africa","Africa","Africa"
diff --git a/inst/external/countries.rds b/inst/external/countries.rds
new file mode 100644
index 0000000..a1ace13
Binary files /dev/null and b/inst/external/countries.rds differ
diff --git a/inst/external/lux.dbf b/inst/external/lux.dbf
new file mode 100644
index 0000000..9f5d434
Binary files /dev/null and b/inst/external/lux.dbf differ
diff --git a/inst/external/lux.prj b/inst/external/lux.prj
new file mode 100644
index 0000000..a30c00a
--- /dev/null
+++ b/inst/external/lux.prj
@@ -0,0 +1 @@
+GEOGCS["GCS_WGS_1984",DATUM["D_WGS_1984",SPHEROID["WGS_1984",6378137,298.257223563]],PRIMEM["Greenwich",0],UNIT["Degree",0.017453292519943295]]
\ No newline at end of file
diff --git a/inst/external/lux.shp b/inst/external/lux.shp
new file mode 100644
index 0000000..7e4d0ef
Binary files /dev/null and b/inst/external/lux.shp differ
diff --git a/inst/external/lux.shx b/inst/external/lux.shx
new file mode 100644
index 0000000..aa58a52
Binary files /dev/null and b/inst/external/lux.shx differ
diff --git a/inst/external/rlogo.grd b/inst/external/rlogo.grd
new file mode 100644
index 0000000..3eb9e26
--- /dev/null
+++ b/inst/external/rlogo.grd
@@ -0,0 +1,28 @@
+[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=
diff --git a/inst/external/rlogo.gri b/inst/external/rlogo.gri
new file mode 100644
index 0000000..d13aa2a
Binary files /dev/null and b/inst/external/rlogo.gri differ
diff --git a/inst/external/test.grd b/inst/external/test.grd
new file mode 100644
index 0000000..29d61b8
--- /dev/null
+++ b/inst/external/test.grd
@@ -0,0 +1,28 @@
+[general]
+creator=R package 'raster'
+created= 2009-11-25 16:43:06
+[georeference]
+nrows= 115
+ncols= 80
+xmin= 178400
+ymin= 329400
+xmax= 181600
+ymax= 334000
+xres= 40
+yres= 40
+projection= +init=epsg:28992 +towgs84=565.237,50.0087,465.658,-0.406857,0.350733,-1.87035,4.0812 +proj=sterea +lat_0=52.15616055555555 +lon_0=5.38763888888889 +k=0.9999079 +x_0=155000 +y_0=463000 +ellps=bessel +units=m +no_defs
+[data]
+datatype= FLT4S
+byteorder= little
+nbands= 1
+bandorder= BIL
+minvalue= 128.434005737305
+maxvalue= 1805.78002929688
+nodatavalue= -3.4e+38
+[legend]
+legendtype=
+values=
+color=
+[description]
+layername= test
+history=
diff --git a/inst/external/test.gri b/inst/external/test.gri
new file mode 100644
index 0000000..8dc3a1a
Binary files /dev/null and b/inst/external/test.gri differ
diff --git a/man/Arith-methods.Rd b/man/Arith-methods.Rd
new file mode 100644
index 0000000..d3719f7
--- /dev/null
+++ b/man/Arith-methods.Rd
@@ -0,0 +1,75 @@
+\name{Arith-methods}
+
+\docType{methods}
+
+\alias{Arith-methods}
+\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)
+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}
diff --git a/man/Compare-methods.Rd b/man/Compare-methods.Rd
new file mode 100644
index 0000000..2eb9c5b
--- /dev/null
+++ b/man/Compare-methods.Rd
@@ -0,0 +1,47 @@
+\name{Compare-methods}
+
+\docType{methods}
+
+\alias{Compare-methods}
+\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}
diff --git a/man/Extent-class.Rd b/man/Extent-class.Rd
new file mode 100644
index 0000000..be2f033
--- /dev/null
+++ b/man/Extent-class.Rd
@@ -0,0 +1,45 @@
+\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}
diff --git a/man/KML.Rd b/man/KML.Rd
new file mode 100644
index 0000000..ae92f2a
--- /dev/null
+++ b/man/KML.Rd
@@ -0,0 +1,60 @@
+\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}
diff --git a/man/Logic-methods.Rd b/man/Logic-methods.Rd
new file mode 100644
index 0000000..a8893cd
--- /dev/null
+++ b/man/Logic-methods.Rd
@@ -0,0 +1,58 @@
+\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)
+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}
diff --git a/man/Math-methods.Rd b/man/Math-methods.Rd
new file mode 100644
index 0000000..a5d9ba2
--- /dev/null
+++ b/man/Math-methods.Rd
@@ -0,0 +1,40 @@
+\name{Math-methods}
+
+\docType{methods}
+
+\alias{Math-methods}
+\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}
diff --git a/man/NAvalue.Rd b/man/NAvalue.Rd
new file mode 100644
index 0000000..490962b
--- /dev/null
+++ b/man/NAvalue.Rd
@@ -0,0 +1,45 @@
+\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 }
+
diff --git a/man/RGB.Rd b/man/RGB.Rd
new file mode 100644
index 0000000..a44d2dd
--- /dev/null
+++ b/man/RGB.Rd
@@ -0,0 +1,45 @@
+\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, ...)
+}
+
+\arguments{
+ \item{x}{RasterBrick or RasterStack}
+ \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}
+
diff --git a/man/Raster-classes.Rd b/man/Raster-classes.Rd
new file mode 100644
index 0000000..db96b0a
--- /dev/null
+++ b/man/Raster-classes.Rd
@@ -0,0 +1,89 @@
+\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 i [...]
+
+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 [...]
+
+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 cla [...]
+
+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}
diff --git a/man/Summary-methods.Rd b/man/Summary-methods.Rd
new file mode 100644
index 0000000..0b76e45
--- /dev/null
+++ b/man/Summary-methods.Rd
@@ -0,0 +1,45 @@
+\name{Summary-methods}
+
+\docType{methods}
+
+\alias{Summary-methods}
+\alias{mean,Raster-method}
+
+\title{ Summary methods }
+
+\description{
+The following summary methods are available for Raster* objects:
+
+ \code{mean, 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]{maxValue}} and \code{\link[raster]{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}
+
diff --git a/man/addLayer.Rd b/man/addLayer.Rd
new file mode 100644
index 0000000..03b869b
--- /dev/null
+++ b/man/addLayer.Rd
@@ -0,0 +1,43 @@
+\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 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 }
diff --git a/man/adjacent.Rd b/man/adjacent.Rd
new file mode 100644
index 0000000..3bc9865
--- /dev/null
+++ b/man/adjacent.Rd
@@ -0,0 +1,71 @@
+\name{adjacent}
+
+\alias{adjacent}
+
+\title{Adjacent cells}
+
+\description{
+Identify cells that are adjacent to a set of cells on a raster.
+}
+
+\usage{
+adjacent(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 neigborhood 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) }
+ }
+
+\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)
+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}
diff --git a/man/aggregate.Rd b/man/aggregate.Rd
new file mode 100644
index 0000000..6cd87e9
--- /dev/null
+++ b/man/aggregate.Rd
@@ -0,0 +1,90 @@
+\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.
+
+SpatialPolygons:
+
+Aggregate ('dissolve') SpatialPolygons, optionally by combining polygons that have the same attributes for one or more variables.
+}
+
+\usage{
+\S4method{aggregate}{Raster}(x, fact=2, 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}{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 then 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} overlapping polygons are dissolved into single features (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 firs [...]
+
+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 then 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 \ [...]
+
+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}
+
diff --git a/man/alignExtent.Rd b/man/alignExtent.Rd
new file mode 100644
index 0000000..df93d7a
--- /dev/null
+++ b/man/alignExtent.Rd
@@ -0,0 +1,44 @@
+\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}
diff --git a/man/animate.Rd b/man/animate.Rd
new file mode 100644
index 0000000..a427499
--- /dev/null
+++ b/man/animate.Rd
@@ -0,0 +1,42 @@
+\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}
+
diff --git a/man/approxNA.Rd b/man/approxNA.Rd
new file mode 100644
index 0000000..0451beb
--- /dev/null
+++ b/man/approxNA.Rd
@@ -0,0 +1,62 @@
+\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}
+
diff --git a/man/area.Rd b/man/area.Rd
new file mode 100644
index 0000000..41f496e
--- /dev/null
+++ b/man/area.Rd
@@ -0,0 +1,45 @@
+\name{area}
+
+\alias{area}
+\alias{area,RasterLayer-method}
+\alias{area,RasterStackBrick-method}
+\alias{area,SpatialPolygons-method}
+
+\title{Size of cells}
+
+\description{
+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 (latitudial 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.
+}
+
+\usage{
+\S4method{area}{RasterLayer}(x, filename="", na.rm=FALSE, weights=FALSE, ...)
+
+\S4method{area}{RasterStackBrick}(x, filename="", na.rm=FALSE, weights=FALSE, ...)
+}
+
+\arguments{
+\item{x}{Raster* 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{
+RasterLayer or RasterBrick. Cell values represent the size of the cell in km2, or the relative size if \code{weights=TRUE}
+}
+
+
+
+\examples{
+
+r <- raster(nrow=18, ncol=36)
+a <- area(r)
+}
+
+\keyword{methods}
+\keyword{spatial}
diff --git a/man/as.data.frame.Rd b/man/as.data.frame.Rd
new file mode 100644
index 0000000..72f3d87
--- /dev/null
+++ b/man/as.data.frame.Rd
@@ -0,0 +1,61 @@
+\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)
+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}
diff --git a/man/as.list.Rd b/man/as.list.Rd
new file mode 100644
index 0000000..27d1e1a
--- /dev/null
+++ b/man/as.list.Rd
@@ -0,0 +1,34 @@
+\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)
+r[] <- 1:ncell(r)
+as.list(r)
+
+s <- stack(r,r*2,r*3)
+as.list(s, r)
+}
+
+\keyword{spatial}
+\keyword{methods}
diff --git a/man/as.logical-methods.Rd b/man/as.logical-methods.Rd
new file mode 100644
index 0000000..9146c3c
--- /dev/null
+++ b/man/as.logical-methods.Rd
@@ -0,0 +1,40 @@
+\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]{as.logical}}, \code{\link[base]{as.integer}} }
+
+\examples{
+r <- raster(nrow=10, ncol=10)
+set.seed(0)
+r[] <- runif(ncell(r)) * 10
+r
+r <- as.integer(r)
+r
+as.logical(r)
+}
+
+
+\keyword{methods}
+\keyword{spatial}
diff --git a/man/as.matrix.Rd b/man/as.matrix.Rd
new file mode 100644
index 0000000..a0ecff3
--- /dev/null
+++ b/man/as.matrix.Rd
@@ -0,0 +1,66 @@
+\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)
+r[] <- 1:ncell(r)
+as.matrix(r)
+s <- stack(r,r)
+as.array(s)
+as.vector(extent(s))
+}
+
+\keyword{spatial}
+\keyword{methods}
diff --git a/man/as.raster.Rd b/man/as.raster.Rd
new file mode 100644
index 0000000..2cbef67
--- /dev/null
+++ b/man/as.raster.Rd
@@ -0,0 +1,40 @@
+\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)
+r[] <- 1:ncell(r)
+as.raster(r)
+}
+
+\keyword{spatial}
+\keyword{methods}
diff --git a/man/atan2.Rd b/man/atan2.Rd
new file mode 100644
index 0000000..876372e
--- /dev/null
+++ b/man/atan2.Rd
@@ -0,0 +1,34 @@
+\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)
+r1[] <- (runif(ncell(r1))-0.5) * 10
+r2[] <- (runif(ncell(r1))-0.5) * 10
+atan2(r1, r2)
+}
+
+\keyword{methods}
+\keyword{math}
diff --git a/man/autocor.Rd b/man/autocor.Rd
new file mode 100644
index 0000000..ea8b1f4
--- /dev/null
+++ b/man/autocor.Rd
@@ -0,0 +1,68 @@
+\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
+
+\url{http://en.wikipedia.org/wiki/Indicators_of_spatial_association}
+}
+
+\examples{
+r <- raster(nrows=10, ncols=10)
+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}
diff --git a/man/bands.Rd b/man/bands.Rd
new file mode 100644
index 0000000..8127841
--- /dev/null
+++ b/man/bands.Rd
@@ -0,0 +1,42 @@
+\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}
diff --git a/man/barplot.Rd b/man/barplot.Rd
new file mode 100644
index 0000000..ab2be00
--- /dev/null
+++ b/man/barplot.Rd
@@ -0,0 +1,46 @@
+\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}
+
diff --git a/man/bind.Rd b/man/bind.Rd
new file mode 100644
index 0000000..452425c
--- /dev/null
+++ b/man/bind.Rd
@@ -0,0 +1,63 @@
+\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}
+
+\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)
+}
+
+
+\arguments{
+ \item{x}{Spatial* object or data.frame}
+ \item{y}{Spatial* object or data.frame}
+ \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{
+if (require(rgdal) & require(rgeos)) {
+ p <- shapefile(system.file("external/lux.shp", 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}
diff --git a/man/blockSize.Rd b/man/blockSize.Rd
new file mode 100644
index 0000000..4d78e3f
--- /dev/null
+++ b/man/blockSize.Rd
@@ -0,0 +1,43 @@
+\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 }
diff --git a/man/boundaries.Rd b/man/boundaries.Rd
new file mode 100644
index 0000000..e5b829e
--- /dev/null
+++ b/man/boundaries.Rd
@@ -0,0 +1,44 @@
+\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}
+}
+
+\note{'edge' is obsolete and should not be used. It will be removed from this pacakge}
+
+\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}
diff --git a/man/boxplot.Rd b/man/boxplot.Rd
new file mode 100644
index 0000000..32f09fe
--- /dev/null
+++ b/man/boxplot.Rd
@@ -0,0 +1,47 @@
+\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)
+r1[] <- rnorm(ncell(r1), 100, 40)
+r2[] <- rnorm(ncell(r1), 80, 10)
+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}
+
diff --git a/man/brick.Rd b/man/brick.Rd
new file mode 100644
index 0000000..f070e9f
--- /dev/null
+++ b/man/brick.Rd
@@ -0,0 +1,105 @@
+\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,big.matrix-method}
+\alias{brick,list-method}
+\alias{brick,SpatialPixels-method}
+\alias{brick,SpatialGrid-method}
+\alias{brick,kasc-method}
+\alias{brick,grf-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=NA, nl=1)
+
+\S4method{brick}{array}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, transpose=FALSE)
+
+\S4method{brick}{big.matrix}(x, template, filename='', ...)
+
+\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 withing -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}
+\item{template}{Raster* object used to set the extent, number of rows and columns and CRS}
+}
+
+\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}}. The big.matrix most have rows representing cells and columns representing layers.
+
+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.
+
+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}
diff --git a/man/buffer.Rd b/man/buffer.Rd
new file mode 100644
index 0000000..75f2c06
--- /dev/null
+++ b/man/buffer.Rd
@@ -0,0 +1,47 @@
+\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}.
+
+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.
+}
+
+\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)
+r[] <- NA
+r[500] <- 1
+b <- buffer(r, width=5000000)
+#plot(b)
+}
+
+\keyword{spatial}
diff --git a/man/calc.Rd b/man/calc.Rd
new file mode 100644
index 0000000..8a41f19
--- /dev/null
+++ b/man/calc.Rd
@@ -0,0 +1,154 @@
+\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)
+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 indiviudal 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}
diff --git a/man/cellFrom.Rd b/man/cellFrom.Rd
new file mode 100644
index 0000000..23ecb45
--- /dev/null
+++ b/man/cellFrom.Rd
@@ -0,0 +1,85 @@
+\name{cellFrom}
+
+\alias{cellFromRowCol}
+\alias{cellFromRowColCombine}
+\alias{cellFromRow}
+\alias{cellFromCol}
+\alias{colFromX}
+\alias{rowFromY}
+\alias{cellFromXY}
+\alias{cellFromLine}
+\alias{cellFromPolygon}
+\alias{fourCellsFromXY}
+
+
+\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, rownr, colnr)
+cellFromRowColCombine(object, rownr, colnr)
+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{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)}
+}
+
+\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}
diff --git a/man/cellStats.Rd b/man/cellStats.Rd
new file mode 100644
index 0000000..d0493d5
--- /dev/null
+++ b/man/cellStats.Rd
@@ -0,0 +1,54 @@
+\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]{minValue}}, \code{\link[raster]{maxValue}}, \code{\link[raster]{setMinMax}}
+}
+
+
+
+\examples{
+r <- raster(nrow=18, ncol=36)
+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}
diff --git a/man/cellsFromExtent.Rd b/man/cellsFromExtent.Rd
new file mode 100644
index 0000000..c85c21d
--- /dev/null
+++ b/man/cellsFromExtent.Rd
@@ -0,0 +1,42 @@
+\name{cellsFromExtent}
+
+\alias{cellsFromExtent}
+
+
+\title{Cells from Extent}
+
+\description{
+This function 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.
+}
+
+\usage{
+cellsFromExtent(object, extent, expand=FALSE)
+}
+
+\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}) }
+}
+
+\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)
+r[] <- cells
+}
+
+\keyword{spatial}
diff --git a/man/clamp.Rd b/man/clamp.Rd
new file mode 100644
index 0000000..1b6f6f0
--- /dev/null
+++ b/man/clamp.Rd
@@ -0,0 +1,43 @@
+\name{clamp}
+
+\alias{clamp}
+\alias{clamp,Raster-method}
+\alias{clamp,numeric-method}
+
+\title{Clamp values}
+
+\description{
+Clamp values to a mininum and maximum value. That is, all values below the lower clamp value and 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}
+
diff --git a/man/clearValues.Rd b/man/clearValues.Rd
new file mode 100644
index 0000000..d17d218
--- /dev/null
+++ b/man/clearValues.Rd
@@ -0,0 +1,39 @@
+
+\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[raster]{values}}, \code{\link[raster]{replacement} }}
+
+
+\value{
+a Raster* object
+}
+
+
+
+\examples{
+r <- raster(ncol=10, nrow=10)
+r[] <- 1:ncell(r)
+r <- clearValues(r)
+}
+
+
+\keyword{ spatial }
+\keyword{ methods }
+
diff --git a/man/click.Rd b/man/click.Rd
new file mode 100644
index 0000000..02aa59a
--- /dev/null
+++ b/man/click.Rd
@@ -0,0 +1,66 @@
+\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{
+ r <- raster(system.file("external/test.grd", package="raster"))
+#plot(r)
+#click(r)
+#now click on the plot (map)
+}
+
+\keyword{ spatial }
diff --git a/man/clump.Rd b/man/clump.Rd
new file mode 100644
index 0000000..929b510
--- /dev/null
+++ b/man/clump.Rd
@@ -0,0 +1,43 @@
+\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)
+r[] <- round(runif(ncell(r))*0.7 )
+rc <- clump(r)
+freq(rc)
+plot(rc)
+}
+\keyword{spatial}
+
diff --git a/man/cluster.Rd b/man/cluster.Rd
new file mode 100644
index 0000000..9e51cc3
--- /dev/null
+++ b/man/cluster.Rd
@@ -0,0 +1,116 @@
+\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}} [...]
+
+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()
+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='rcltest.grd', datatype='INT2S', overwrite=TRUE)
+
+# equivalent to:
+rc2 <- reclassify(r, rcl=m, right=FALSE, filename='rcltest.grd', 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 }
+
diff --git a/man/colortable.Rd b/man/colortable.Rd
new file mode 100644
index 0000000..e10b809
--- /dev/null
+++ b/man/colortable.Rd
@@ -0,0 +1,35 @@
+\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}
diff --git a/man/compare.Rd b/man/compare.Rd
new file mode 100644
index 0000000..5f11541
--- /dev/null
+++ b/man/compare.Rd
@@ -0,0 +1,52 @@
+\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 }
+
diff --git a/man/compareCRS.Rd b/man/compareCRS.Rd
new file mode 100644
index 0000000..476bc03
--- /dev/null
+++ b/man/compareCRS.Rd
@@ -0,0 +1,45 @@
+\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{\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 }
+
diff --git a/man/contour.Rd b/man/contour.Rd
new file mode 100644
index 0000000..ed9375b
--- /dev/null
+++ b/man/contour.Rd
@@ -0,0 +1,37 @@
+\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}
+
diff --git a/man/coordinates.Rd b/man/coordinates.Rd
new file mode 100644
index 0000000..fa66b39
--- /dev/null
+++ b/man/coordinates.Rd
@@ -0,0 +1,68 @@
+\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}
+
+
+\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}{A Raster* object}
+ \item{value}{A new x or y coordinate}
+}
+
+
+\value{
+a single number
+}
+
+\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}
diff --git a/man/corLocal.Rd b/man/corLocal.Rd
new file mode 100644
index 0000000..372afcd
--- /dev/null
+++ b/man/corLocal.Rd
@@ -0,0 +1,74 @@
+\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}
+
diff --git a/man/cover.Rd b/man/cover.Rd
new file mode 100644
index 0000000..ac80a19
--- /dev/null
+++ b/man/cover.Rd
@@ -0,0 +1,63 @@
+\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)
+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}
diff --git a/man/crop.Rd b/man/crop.Rd
new file mode 100644
index 0000000..002128b
--- /dev/null
+++ b/man/crop.Rd
@@ -0,0 +1,67 @@
+\name{crop}
+
+\alias{crop}
+\alias{crop,Raster-method}
+\alias{crop,Spatial-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 be 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, 15))}
+}
+
+\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)
+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}
diff --git a/man/crosstab.Rd b/man/crosstab.Rd
new file mode 100644
index 0000000..693e9d2
--- /dev/null
+++ b/man/crosstab.Rd
@@ -0,0 +1,55 @@
+\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)
+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}
+
diff --git a/man/cut.Rd b/man/cut.Rd
new file mode 100644
index 0000000..264e9d2
--- /dev/null
+++ b/man/cut.Rd
@@ -0,0 +1,40 @@
+\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)
+r[] <- rnorm(ncell(r))
+breaks <- -2:2 * 3
+rc <- cut(r, breaks=breaks)
+}
+
+\keyword{spatial}
diff --git a/man/cv.Rd b/man/cv.Rd
new file mode 100644
index 0000000..ec6d0e3
--- /dev/null
+++ b/man/cv.Rd
@@ -0,0 +1,38 @@
+\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}
diff --git a/man/dataType.Rd b/man/dataType.Rd
new file mode 100644
index 0000000..cde526a
--- /dev/null
+++ b/man/dataType.Rd
@@ -0,0 +1,64 @@
+\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)
+s <- writeRaster(r, 'new.grd', datatype='INT2U', overwrite=TRUE)
+dataType(s)
+}
+
+\keyword{ spatial }
+
diff --git a/man/datasource.Rd b/man/datasource.Rd
new file mode 100644
index 0000000..ace25c7
--- /dev/null
+++ b/man/datasource.Rd
@@ -0,0 +1,56 @@
+\name{datasource}
+
+\alias{fromDisk}
+\alias{inMemory}
+\alias{hasValues}
+
+\title{Are values in memory and/or on disk?}
+
+\description{
+These are helper functons 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} 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)
+inMemory(x)
+hasValues(x)
+}
+
+\arguments{
+ \item{x}{ Raster* object }
+}
+
+\value{
+Logical value
+}
+
+
+
+\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='test', overwrite=TRUE)
+inMemory(rs)
+fromDisk(rs)
+}
+
+\keyword{ spatial }
diff --git a/man/density.Rd b/man/density.Rd
new file mode 100644
index 0000000..9b46b44
--- /dev/null
+++ b/man/density.Rd
@@ -0,0 +1,36 @@
+\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 \code{\link[graphics]{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}
diff --git a/man/dimensions.Rd b/man/dimensions.Rd
new file mode 100644
index 0000000..140e069
--- /dev/null
+++ b/man/dimensions.Rd
@@ -0,0 +1,49 @@
+\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}
+
diff --git a/man/direction.Rd b/man/direction.Rd
new file mode 100644
index 0000000..3653e87
--- /dev/null
+++ b/man/direction.Rd
@@ -0,0 +1,45 @@
+\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 distance 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)
+r[] <- NA
+r[306] <- 1
+b <- direction(r)
+#plot(b)
+}
+
+\keyword{spatial}
diff --git a/man/disaggregate.Rd b/man/disaggregate.Rd
new file mode 100644
index 0000000..c15099e
--- /dev/null
+++ b/man/disaggregate.Rd
@@ -0,0 +1,44 @@
+\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)
+r[] <- 1:ncell(r)
+rd <- disaggregate(r, fact=c(4, 2), method='bilinear')
+
+}
+
+\keyword{spatial}
+
diff --git a/man/distance.Rd b/man/distance.Rd
new file mode 100644
index 0000000..093c0f4
--- /dev/null
+++ b/man/distance.Rd
@@ -0,0 +1,52 @@
+\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)
+r[] <- NA
+r[500] <- 1
+dist <- distance(r)
+#plot(dist / 1000)
+}
+
+\keyword{spatial}
diff --git a/man/distanceFromPoints.Rd b/man/distanceFromPoints.Rd
new file mode 100644
index 0000000..7c88f79
--- /dev/null
+++ b/man/distanceFromPoints.Rd
@@ -0,0 +1,39 @@
+\name{distanceFromPoints}
+
+\alias{distanceFromPoints}
+
+\title{Distance from points}
+
+\description{
+The function calculates the distance from a set of points to all cells of a RasterLayer.
+
+The distance unit is in meters if the RasterLayer is not projected (\code{+proj=longlat}) and in map units (typically meters) when it is projected.
+}
+
+\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}}}
+}
+
+
+\value{RasterLayer object}
+
+\seealso{ \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} }
+
+
+
+
+\examples{
+r <- raster(ncol=36,nrow=18)
+xy = c(0,0)
+dist <- distanceFromPoints(r, xy)
+#plot(dist)
+}
+
+\keyword{spatial}
diff --git a/man/draw.Rd b/man/draw.Rd
new file mode 100644
index 0000000..189c5a2
--- /dev/null
+++ b/man/draw.Rd
@@ -0,0 +1,34 @@
+\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 }
diff --git a/man/drawExtent.Rd b/man/drawExtent.Rd
new file mode 100644
index 0000000..a19d3d5
--- /dev/null
+++ b/man/drawExtent.Rd
@@ -0,0 +1,36 @@
+\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)
+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 }
diff --git a/man/erase.Rd b/man/erase.Rd
new file mode 100644
index 0000000..7729099
--- /dev/null
+++ b/man/erase.Rd
@@ -0,0 +1,44 @@
+\name{erase}
+
+\docType{methods}
+
+\alias{erase}
+\alias{erase,SpatialPolygons,SpatialPolygons-method}
+
+\title{
+Erase parts of a Spatial* object
+}
+
+\description{
+Erase parts of a Spatial* objects with another Spatial* object
+}
+
+\usage{
+\S4method{erase}{SpatialPolygons,SpatialPolygons}(x, y, ...)
+}
+
+\arguments{
+ \item{x}{Spatial* object}
+ \item{y}{Spatial* object}
+ \item{...}{Additional arguments (none)}
+}
+
+\value{
+Spatial*
+}
+
+\author{Robert J. Hijmans}
+
+\examples{
+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)
+ e <- erase(p, b)
+ plot(e)
+}
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/extend.Rd b/man/extend.Rd
new file mode 100644
index 0000000..1e4ba68
--- /dev/null
+++ b/man/extend.Rd
@@ -0,0 +1,62 @@
+\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, 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{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)
+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}
diff --git a/man/extension.Rd b/man/extension.Rd
new file mode 100644
index 0000000..6c1917b
--- /dev/null
+++ b/man/extension.Rd
@@ -0,0 +1,43 @@
+\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}
+
diff --git a/man/extent.Rd b/man/extent.Rd
new file mode 100644
index 0000000..b6d1602
--- /dev/null
+++ b/man/extent.Rd
@@ -0,0 +1,60 @@
+\name{extent}
+
+\alias{extent}
+\alias{extent,Extent-method}
+\alias{extent,BasicRaster-method}
+\alias{extent,Spatial-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, 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}
diff --git a/man/extract.Rd b/man/extract.Rd
new file mode 100644
index 0000000..181d550
--- /dev/null
+++ b/man/extract.Rd
@@ -0,0 +1,169 @@
+\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,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 other spatial data. You can use coordinates (points), lines, polygons or an Extent (rectangle) object. You can also use cell numbers 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 anyway).
+
+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, 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{\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, f [...]
+
+\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{weights}{logical. If \code{TRUE} and \code{normalizeWeights=FALSE}, the function returns, for each polygon, a matrix with the cell values and the approximate fraction of each cell that is covered by the polygon(rounded to 1/100). If \code{TRUE} and \code{normalizeWeights=TRUE} the weights are normalized such that they add up to one. The weights can be used for averaging; see examples. This option can be useful (but slow) if the polygons are small relative to the cells size of the [...]
+
+\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 [...]
+}
+
+\seealso{ \code{\link{getValues}, \link{getValuesFocal}} }
+
+\examples{
+r <- raster(ncol=36, nrow=18)
+r[] <- 1:ncell(r)
+
+###############################
+# 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
+ projection(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
+###############################
+
+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)
+
+#plot(r)
+#plot(polys, add=TRUE)
+v <- extract(r, polys)
+v
+# 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}
+
diff --git a/man/extractIndex.Rd b/man/extractIndex.Rd
new file mode 100644
index 0000000..ffc7c6a
--- /dev/null
+++ b/man/extractIndex.Rd
@@ -0,0 +1,71 @@
+\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)
+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}
diff --git a/man/extremeValues.Rd b/man/extremeValues.Rd
new file mode 100644
index 0000000..001c25d
--- /dev/null
+++ b/man/extremeValues.Rd
@@ -0,0 +1,51 @@
+\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}
diff --git a/man/factor.Rd b/man/factor.Rd
new file mode 100644
index 0000000..b26ff56
--- /dev/null
+++ b/man/factor.Rd
@@ -0,0 +1,118 @@
+\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{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 fu [...]
+
+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)
+
+factorValues(x, v, layer=1, att=NULL, append.names=FALSE)
+
+ratify(x, filename='', count=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)
+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)
+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, 'test.grd', overwrite=TRUE)
+rr
+
+# create a single-layer factor
+x <- deratify(r, 'landcover')
+x
+is.factor(x)
+levels(x)
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/filename.Rd b/man/filename.Rd
new file mode 100644
index 0000000..4e76035
--- /dev/null
+++ b/man/filename.Rd
@@ -0,0 +1,31 @@
+\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 }
+
diff --git a/man/filledContour.Rd b/man/filledContour.Rd
new file mode 100644
index 0000000..7c73a7d
--- /dev/null
+++ b/man/filledContour.Rd
@@ -0,0 +1,33 @@
+\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}
+
diff --git a/man/flip.Rd b/man/flip.Rd
new file mode 100644
index 0000000..e64a67f
--- /dev/null
+++ b/man/flip.Rd
@@ -0,0 +1,43 @@
+\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{
+flip(x, direction, ...)
+}
+
+\arguments{
+ \item{x}{Raster* object}
+ \item{direction}{Character. 'y' or 'x'; or 1 (=x) or 2 (=y)}
+ \item{...}{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)
+r[] <- as.vector(t(m))
+rx <- flip(r, direction='x')
+r[] <- as.vector(m)
+ry <- flip(r, direction='y')
+}
+
+\keyword{spatial}
diff --git a/man/flowpath.Rd b/man/flowpath.Rd
new file mode 100644
index 0000000..f9d279b
--- /dev/null
+++ b/man/flowpath.Rd
@@ -0,0 +1,39 @@
+\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}
diff --git a/man/focal.Rd b/man/focal.Rd
new file mode 100644
index 0000000..35ebf3b
--- /dev/null
+++ b/man/focal.Rd
@@ -0,0 +1,123 @@
+\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}
+
+\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} is generally not a good idea in this function because it will 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 filter: \code{filter=matrix(c(1,2,1,0,0,0,-1,-2,-1) / 4, nrow=3)}
+
+see the \code{\link{focalWeight}} function to create distance based circular, rectangular, or Gaussian filters.
+}
+
+\value{
+RasterLayer
+}
+
+
+\seealso{ \code{\link{focalWeight}} }
+
+\examples{
+r <- raster(ncols=36, nrows=18, xmn=0)
+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)
+}
+}
+
+
+\keyword{spatial}
+
diff --git a/man/focalWeight.Rd b/man/focalWeight.Rd
new file mode 100644
index 0000000..7011d3b
--- /dev/null
+++ b/man/focalWeight.Rd
@@ -0,0 +1,34 @@
+\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'))
+}
+
+\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}
+}
+
+\value{
+matrix that can be used in \code{\link{focal}}
+}
+
+
+\examples{
+r <- raster(ncols=36, nrows=18, xmn=0)
+# Gaussian filter for square cells
+gf <- focalWeight(r, 2, "Gauss")
+}
+
+
+\keyword{spatial}
+
diff --git a/man/freq.Rd b/man/freq.Rd
new file mode 100644
index 0000000..8c3dbd9
--- /dev/null
+++ b/man/freq.Rd
@@ -0,0 +1,53 @@
+\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{\link[base]{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)
+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}
diff --git a/man/gainoffset.Rd b/man/gainoffset.Rd
new file mode 100644
index 0000000..0e196e6
--- /dev/null
+++ b/man/gainoffset.Rd
@@ -0,0 +1,50 @@
+\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 }
diff --git a/man/geom.Rd b/man/geom.Rd
new file mode 100644
index 0000000..816b99b
--- /dev/null
+++ b/man/geom.Rd
@@ -0,0 +1,44 @@
+\name{geom}
+
+\docType{methods}
+
+\alias{geom}
+\alias{geom,SpatialPolygons-method}
+\alias{geom,SpatialLines-method}
+\alias{geom,SpatialPoints-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, ...)
+}
+
+\arguments{
+ \item{x}{SpatialPolygons*, SpatialLines*, or SpatialPoints* object}
+ \item{sepNA}{logical. If \code{TRUE}, geometries are separated by a row with \code{NA} values}
+ \item{...}{additional arguments, none implemented}
+}
+
+
+\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}} }
+
+
+\examples{
+if (require(rgdal) & require(rgeos)) {
+ p <- shapefile(system.file("external/lux.shp", package="raster"))
+ x <- geom(p)
+}
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/getData.Rd b/man/getData.Rd
new file mode 100644
index 0000000..64f77c1
--- /dev/null
+++ b/man/getData.Rd
@@ -0,0 +1,76 @@
+\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 pacakge .
+
+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{http://www.worldclim.org}
+
+\url{http://www.gadm.org}
+
+\url{http://srtm.csi.cgiar.org/}
+
+\url{http://diva-gis.org/gdata}
+}
+
+
+
+
+\keyword{ spatial }
diff --git a/man/getValues.Rd b/man/getValues.Rd
new file mode 100644
index 0000000..f0c298f
--- /dev/null
+++ b/man/getValues.Rd
@@ -0,0 +1,58 @@
+\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 specifiy 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}
diff --git a/man/getValuesBlock.Rd b/man/getValuesBlock.Rd
new file mode 100644
index 0000000..830ccb5
--- /dev/null
+++ b/man/getValuesBlock.Rd
@@ -0,0 +1,54 @@
+\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}{postive integer. How many rows? Default is 1}
+ \item{col}{postive integer. Column number to start from, should be between 1 and ncol(x)}
+ \item{ncols}{postive integer. How many columns? Default is the number of colums left after the start column}
+ \item{format}{character. If \code{format='matrix'}, a matrix is returned instead of a vector}
+ \item{lyrs}{integer (vector). Which layers? Default is all layers (\code{1:nlayers(x)})}
+}
+
+
+\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}
diff --git a/man/getValuesFocal.Rd b/man/getValuesFocal.Rd
new file mode 100644
index 0000000..dd53bf0
--- /dev/null
+++ b/man/getValuesFocal.Rd
@@ -0,0 +1,48 @@
+
+\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')
+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}
diff --git a/man/gridDistance.Rd b/man/gridDistance.Rd
new file mode 100644
index 0000000..a80acc6
--- /dev/null
+++ b/man/gridDistance.Rd
@@ -0,0 +1,60 @@
+\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)
+r[] <- 1
+r[48] <- 2
+r[66:68] <- 3
+d <- gridDistance(r,origin=2,omit=3)
+plot(d)
+
+#UTM small area
+projection(r) <- "+proj=utm +zone=15 +ellps=GRS80 +datum=NAD83 +units=m +no_defs"
+d <- gridDistance(r,origin=2,omit=3)
+plot(d)
+
+}
+
+\keyword{spatial}
diff --git a/man/hdrFiles.Rd b/man/hdrFiles.Rd
new file mode 100644
index 0000000..c9a9028
--- /dev/null
+++ b/man/hdrFiles.Rd
@@ -0,0 +1,39 @@
+\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')
+}
+
+\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'})}
+}
+
+\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]{writeGDAL}} }
+
+\examples{
+r <- raster(system.file("external/test.grd", package="raster"))
+r <- writeRaster(r, filename='export.grd', overwrite=TRUE)
+hdr(r, format="ENVI")
+}
+
+\keyword{ spatial }
diff --git a/man/headtail.Rd b/man/headtail.Rd
new file mode 100644
index 0000000..d4d7744
--- /dev/null
+++ b/man/headtail.Rd
@@ -0,0 +1,49 @@
+\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)
+r[] = 1:ncell(r)
+head(r)
+tail(r, cols=10, rows=5)
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/hillShade.Rd b/man/hillShade.Rd
new file mode 100644
index 0000000..8bfc4dd
--- /dev/null
+++ b/man/hillShade.Rd
@@ -0,0 +1,50 @@
+\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}
+
diff --git a/man/hist.Rd b/man/hist.Rd
new file mode 100644
index 0000000..66146e8
--- /dev/null
+++ b/man/hist.Rd
@@ -0,0 +1,51 @@
+\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}
+
diff --git a/man/image.Rd b/man/image.Rd
new file mode 100644
index 0000000..318f242
--- /dev/null
+++ b/man/image.Rd
@@ -0,0 +1,46 @@
+\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}
+
diff --git a/man/iniFile.Rd b/man/iniFile.Rd
new file mode 100644
index 0000000..e1f767d
--- /dev/null
+++ b/man/iniFile.Rd
@@ -0,0 +1,34 @@
+\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}
diff --git a/man/init.Rd b/man/init.Rd
new file mode 100644
index 0000000..97408ac
--- /dev/null
+++ b/man/init.Rd
@@ -0,0 +1,52 @@
+\name{initialize}
+
+\alias{init}
+
+\title{Intitialize 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 [...]
+}
+
+\usage{
+init(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}
+ \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='test.grd', overwrite=TRUE)
+
+# This is equivalent to (but not memory safe):
+z2 <- setValues(r, rep(1, ncell(r)))
+# or
+r[] <- rep(1, ncell(r))
+# or
+r[] <- 1
+}
+
+\keyword{spatial}
+
diff --git a/man/interpolate.Rd b/man/interpolate.Rd
new file mode 100644
index 0000000..e034046
--- /dev/null
+++ b/man/interpolate.Rd
@@ -0,0 +1,135 @@
+\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 [...]
+}
+
+\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{
+\dontrun{
+## 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)
+
+#### 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'
+elevation <- mask(elevation, r)
+
+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
+projection(meuse) <- projection(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}
diff --git a/man/intersect.Rd b/man/intersect.Rd
new file mode 100644
index 0000000..213427c
--- /dev/null
+++ b/man/intersect.Rd
@@ -0,0 +1,95 @@
+\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]{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}
+
diff --git a/man/isLonLat.Rd b/man/isLonLat.Rd
new file mode 100644
index 0000000..bd119c0
--- /dev/null
+++ b/man/isLonLat.Rd
@@ -0,0 +1,42 @@
+\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}
+
+
+\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{
+isLonLat(x)
+couldBeLonLat(x, warnings=TRUE)
+}
+
+\arguments{
+\item{x}{Raster* 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}
+}
+
+
+\value{
+Logical
+}
+
+
+
+\examples{
+r <- raster()
+isLonLat(r)
+projection(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84"
+isLonLat(r)
+}
+
+\keyword{spatial}
diff --git a/man/layerStats.Rd b/man/layerStats.Rd
new file mode 100644
index 0000000..0fcc2e9
--- /dev/null
+++ b/man/layerStats.Rd
@@ -0,0 +1,64 @@
+\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)
+}
+
diff --git a/man/layerize.Rd b/man/layerize.Rd
new file mode 100644
index 0000000..6bb11b3
--- /dev/null
+++ b/man/layerize.Rd
@@ -0,0 +1,46 @@
+\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=36, ncol=72)
+r[] <- round(runif(ncell(r))*5)
+r[1:5] <- NA
+b <- layerize(r)
+
+r2 <- raster(nrow=10, ncol=10)
+b2 <- layerize(r, r2)
+}
+
+\keyword{spatial}
diff --git a/man/localFun.Rd b/man/localFun.Rd
new file mode 100644
index 0000000..e040d21
--- /dev/null
+++ b/man/localFun.Rd
@@ -0,0 +1,60 @@
+\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}
+
diff --git a/man/mask.Rd b/man/mask.Rd
new file mode 100644
index 0000000..1dae87e
--- /dev/null
+++ b/man/mask.Rd
@@ -0,0 +1,66 @@
+\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}
+
+\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 [...]
+}
+
+\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_ \code{NA} are masked. This option is only relevant if ]code{maskvalue=NA}}
+\item{maskvalue}{numeric. The value in \code{mask} that indicates the cells of \code{x} that should become \code{maskvalue} (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 that value 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)
+r[] <- runif(ncell(r)) * 10
+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}
+
diff --git a/man/match.Rd b/man/match.Rd
new file mode 100644
index 0000000..87cea93
--- /dev/null
+++ b/man/match.Rd
@@ -0,0 +1,49 @@
+\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* obeject
+}
+
+\seealso{ \code{\link{calc}, \link[base]{match}} }
+
+
+
+
+\examples{
+r <- raster(nrow=10, ncol=10)
+r[] <- 1:100
+m <- match(r, c(5:10, 50:55))
+n <- r \%in\% c(5:10, 50:55)
+}
+
+\keyword{spatial}
+\keyword{methods}
diff --git a/man/merge.Rd b/man/merge.Rd
new file mode 100644
index 0000000..6625827
--- /dev/null
+++ b/man/merge.Rd
@@ -0,0 +1,65 @@
+\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)
+r1[] <- 1:ncell(r1)
+r2 <- raster(xmn=-100, xmx=-50, ymx=50, ymn=30)
+res(r2) <- c(xres(r1), yres(r1))
+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}
+
diff --git a/man/metadata.Rd b/man/metadata.Rd
new file mode 100644
index 0000000..14150a9
--- /dev/null
+++ b/man/metadata.Rd
@@ -0,0 +1,61 @@
+\name{metadata}
+
+\alias{metadata}
+\alias{metadata<-}
+
+\title{ Metadata }
+
+\description{
+Get or set a metadata to a Raster object
+}
+
+\usage{
+metadata(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 matadata 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)
+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
+x <- writeRaster(r, 'test.grd', overwrite=TRUE)
+metax <- metadata(x)
+
+identical(metax, m)
+
+\dontrun{
+# 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 }
+
diff --git a/man/modal.Rd b/man/modal.Rd
new file mode 100644
index 0000000..0d317f4
--- /dev/null
+++ b/man/modal.Rd
@@ -0,0 +1,37 @@
+\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}
diff --git a/man/mosaic.Rd b/man/mosaic.Rd
new file mode 100644
index 0000000..87b8408
--- /dev/null
+++ b/man/mosaic.Rd
@@ -0,0 +1,70 @@
+\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))
+
+r1[] <- 1:ncell(r1)
+r2[] <- 1:ncell(r2)
+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}
+
diff --git a/man/movingFun.Rd b/man/movingFun.Rd
new file mode 100644
index 0000000..9ca5f5c
--- /dev/null
+++ b/man/movingFun.Rd
@@ -0,0 +1,43 @@
+\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 [...]
+ \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}
diff --git a/man/names.Rd b/man/names.Rd
new file mode 100644
index 0000000..e769022
--- /dev/null
+++ b/man/names.Rd
@@ -0,0 +1,52 @@
+\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)
+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}
diff --git a/man/ncell.Rd b/man/ncell.Rd
new file mode 100644
index 0000000..db53a74
--- /dev/null
+++ b/man/ncell.Rd
@@ -0,0 +1,59 @@
+\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<-}
+
+
+\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)}
+}
+
+\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}
+
diff --git a/man/nlayers.Rd b/man/nlayers.Rd
new file mode 100644
index 0000000..40bf1c2
--- /dev/null
+++ b/man/nlayers.Rd
@@ -0,0 +1,44 @@
+\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)
+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}
diff --git a/man/origin.Rd b/man/origin.Rd
new file mode 100644
index 0000000..8c26b73
--- /dev/null
+++ b/man/origin.Rd
@@ -0,0 +1,42 @@
+\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 lenght 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}
diff --git a/man/overlay.Rd b/man/overlay.Rd
new file mode 100644
index 0000000..40ade2d
--- /dev/null
+++ b/man/overlay.Rd
@@ -0,0 +1,94 @@
+\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 "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 ustacked 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 aritmetic functions such as \code{*, /, +, -} with Raster objects (see examples). In that case you cannot specifiy 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}
diff --git a/man/pairs.Rd b/man/pairs.Rd
new file mode 100644
index 0000000..80f277a
--- /dev/null
+++ b/man/pairs.Rd
@@ -0,0 +1,49 @@
+\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}
+
diff --git a/man/persp.Rd b/man/persp.Rd
new file mode 100644
index 0000000..df04bee
--- /dev/null
+++ b/man/persp.Rd
@@ -0,0 +1,42 @@
+\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. Van be used to zoom in 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}}, \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}
+
diff --git a/man/plot.Rd b/man/plot.Rd
new file mode 100644
index 0000000..4c1c9af
--- /dev/null
+++ b/man/plot.Rd
@@ -0,0 +1,145 @@
+\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}
+
+\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 \code{\link[graphics]{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:
+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)
+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}
+
diff --git a/man/plotRGB.Rd b/man/plotRGB.Rd
new file mode 100644
index 0000000..5e0cbfc
--- /dev/null
+++ b/man/plotRGB.Rd
@@ -0,0 +1,59 @@
+\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, ...)
+}
+
+\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{...}{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}
+
diff --git a/man/pointdistance.Rd b/man/pointdistance.Rd
new file mode 100644
index 0000000..4307b96
--- /dev/null
+++ b/man/pointdistance.Rd
@@ -0,0 +1,49 @@
+\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 }
diff --git a/man/predict.Rd b/man/predict.Rd
new file mode 100644
index 0000000..a72a5d8
--- /dev/null
+++ b/man/predict.Rd
@@ -0,0 +1,181 @@
+ \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 pre [...]
+
+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 \href{http://cran.r-project.org/web/packages/dismo/vignettes/sdm.pdf}{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. Typicially 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
+}
+
+\note{
+There is a lot of general information about the use of the predict function in the \href{http://cran.r-project.org/web/packages/dismo/vignettes/sdm.pdf}{species distribution modeling} vignette of the dismo package.
+}
+
+\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
+# too 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'
+pc <- predict(logo, m, OOB=TRUE, factors=f)
+
+
+# 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}
diff --git a/man/programming.Rd b/man/programming.Rd
new file mode 100644
index 0000000..2f2fe5b
--- /dev/null
+++ b/man/programming.Rd
@@ -0,0 +1,70 @@
+\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)
+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{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 prograss 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=100000, ncol=100000)
+canProcessInMemory(r, 2)
+}
+
+\keyword{ spatial }
+
diff --git a/man/projectRaster.Rd b/man/projectRaster.Rd
new file mode 100644
index 0000000..aa66c1e
--- /dev/null
+++ b/man/projectRaster.Rd
@@ -0,0 +1,115 @@
+\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}.
+}
+
+\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.
+
+One of the best places to find PROJ.4 coordinate reference system descriptions is \url{http://www.spatialreference.org}.
+
+You can also consult this page: \url{http://www.remotesensing.org/geotiff/proj_list/} to find the parameter options and names for projections.
+
+Also see \code{projInfo('proj')}, \code{projInfo('ellps')}, and \code{projInfo('datum')} for valid PROJ.4 values.
+}
+
+\note{
+Vector (points, lines, polygons) can be transformed with \code{\link[rgdal]{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[rgdal]{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))
+projection(r)
+# proj.4 projection description
+newproj <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=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}
+
diff --git a/man/projection.Rd b/man/projection.Rd
new file mode 100644
index 0000000..735d1df
--- /dev/null
+++ b/man/projection.Rd
@@ -0,0 +1,60 @@
+\name{projection}
+
+\alias{crs}
+\alias{crs,ANY-method}
+\alias{crs<-}
+\alias{projection}
+\alias{projection<-}
+\alias{proj4string}
+\alias{proj4string<-}
+\alias{as.character,CRS-method}
+\alias{is.na,CRS-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, ...)
+
+crs(x) <- value
+
+projection(x, asText=TRUE)
+projection(x) <- value
+}
+
+\arguments{
+ \item{x}{Raster* or Spatial object }
+ \item{asText}{logical. If \code{TRUE}, the projection is returned as text. Otherwise a \code{\link[sp]{CRS}} object is returned}
+ \item{...}{additional arguments (not implemented)}
+ \item{value}{\code{CRS} object or a character string describing a projection and datum in the PROJ.4 format }
+}
+
+
+\value{
+Raster*, Spatial*, CRS, 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}.
+}
+
+\seealso{ \code{\link[raster]{projectRaster}, \link[rgdal]{CRS-class}, \link[rgdal]{spTransform-methods}, \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 +ellps=WGS84"
+crs(r)
+}
+
+\keyword{ spatial }
+
diff --git a/man/properties.Rd b/man/properties.Rd
new file mode 100644
index 0000000..01e8c2d
--- /dev/null
+++ b/man/properties.Rd
@@ -0,0 +1,42 @@
+\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}
diff --git a/man/quantile.Rd b/man/quantile.Rd
new file mode 100644
index 0000000..c40704b
--- /dev/null
+++ b/man/quantile.Rd
@@ -0,0 +1,41 @@
+\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)
+r[] <- rnorm(ncell(r), 0, 50)
+quantile(r)
+quantile(r, probs = c(0.25, 0.75), type=7,names = FALSE)
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/raster-package.Rd b/man/raster-package.Rd
new file mode 100644
index 0000000..ef6423f
--- /dev/null
+++ b/man/raster-package.Rd
@@ -0,0 +1,377 @@
+\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 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, col 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 spaces 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{project [...]
+
+ \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{projection}} \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{band}} \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 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} a SpatialPolygons object with 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 trainling blanks from a character string \cr
+ \code{\link{extension}} \tab Get or set the extentsion 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-chunck 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{Acknowledgements}{
+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 Kranstaube [...]
+}
+
+\keyword{package}
+\keyword{spatial}
diff --git a/man/raster.Rd b/man/raster.Rd
new file mode 100644
index 0000000..54b849e
--- /dev/null
+++ b/man/raster.Rd
@@ -0,0 +1,167 @@
+\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,big.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,GridTopology-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=NA, ...)
+
+\S4method{raster}{matrix}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, template=NULL)
+
+\S4method{raster}{big.matrix}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, template=NULL)
+
+\S4method{raster}{Spatial}(x, origin, ...)
+
+\S4method{raster}{SpatialGrid}(x, layer=1, values=TRUE)
+
+\S4method{raster}{SpatialPixels}(x, layer=1, values=TRUE)
+}
+
+\arguments{
+\item{x}{filename (character), Extent, Raster*, 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 withing -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)
+
+
+\dontrun{
+# from NSIDC sea ice concentration file
+baseurl <- "ftp://sidads.colorado.edu/pub/DATASETS/"
+# southern hemisphere
+f1 <- paste(baseurl,
+ "nsidc0051_gsfc_nasateam_seaice/final-gsfc/south/daily/2013/nt_20130114_f17_v01_s.bin",
+ sep='')
+# or northern hemisphere
+f2 <- paste(baseurl,
+ "nsidc0051_gsfc_nasateam_seaice/final-gsfc/north/daily/2013/nt_20130105_f17_v01_n.bin",
+ sep='')
+
+if (!file.exists(basename(f1))) download.file(f1, basename(f1), mode = "wb")
+ice1 <- raster(basename(f1))
+
+if (!file.exists(basename(f2))) download.file(f2, basename(f2), mode = "wb")
+ice2 <- raster(basename(f2))
+
+}
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/rasterFromCells.Rd b/man/rasterFromCells.Rd
new file mode 100644
index 0000000..91b5527
--- /dev/null
+++ b/man/rasterFromCells.Rd
@@ -0,0 +1,42 @@
+\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}
diff --git a/man/rasterFromXYZ.Rd b/man/rasterFromXYZ.Rd
new file mode 100644
index 0000000..ce1f725
--- /dev/null
+++ b/man/rasterFromXYZ.Rd
@@ -0,0 +1,46 @@
+\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=NA, 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=10, ncol=10, xmn=0, xmx=10, ymn=0, ymx=10, crs=NA)
+r[] <- runif(ncell(r))
+r[r<0.5] <- NA
+xyz <- rasterToPoints(r)
+
+r2 <- rasterFromXYZ(xyz)
+
+# equivalent to:
+r3 <- raster(nrow=10, ncol=10, xmn=0, xmx=10, ymn=0, ymx=10)
+cells <- cellFromXY(r3, xyz[,1:2])
+r3[cells] <- xyz[,3]
+}
+
+\keyword{methods}
+\keyword{spatial}
diff --git a/man/rasterOptions.Rd b/man/rasterOptions.Rd
new file mode 100644
index 0000000..c333251
--- /dev/null
+++ b/man/rasterOptions.Rd
@@ -0,0 +1,65 @@
+\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{<your R installation>/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, 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 cells to read/write in a single chunk while processing (chunk by chunk) disk based Raster* objects}
+\item{maxmemory}{integer. Maximum number of cells to read into memory. I.e., if a Raster* object has more than this number of cells, \code{\link[raster]{canProcessInMemory}} will return \code{FALSE} }
+\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 }
+
diff --git a/man/rasterTmpFile.Rd b/man/rasterTmpFile.Rd
new file mode 100644
index 0000000..b8b4c99
--- /dev/null
+++ b/man/rasterTmpFile.Rd
@@ -0,0 +1,63 @@
+\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 RasterLayer 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 sho [...]
+}
+
+\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)}
+}
+
+\details{
+The default path where the temporary files are stored is returned (can be changed with \code{\link{rasterOptions}}).
+}
+
+\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)
+
+# It is possible (but undesirable!) to create overlapping temp file names.
+for (i in 1:10) {
+ set.seed(0)
+ print(rasterTmpFile())
+}
+That can be avoided by using a prefix
+for (i in 1:10) {
+ set.seed(0)
+ print(rasterTmpFile(prefix=paste('i', i, '_', sep='')))
+}
+
+}}
+
+\keyword{ spatial }
+
+
diff --git a/man/rasterToContour.Rd b/man/rasterToContour.Rd
new file mode 100644
index 0000000..7b2f341
--- /dev/null
+++ b/man/rasterToContour.Rd
@@ -0,0 +1,41 @@
+\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 }
diff --git a/man/rasterToPoints.Rd b/man/rasterToPoints.Rd
new file mode 100644
index 0000000..094f288
--- /dev/null
+++ b/man/rasterToPoints.Rd
@@ -0,0 +1,44 @@
+\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)
+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 }
diff --git a/man/rasterToPolygons.Rd b/man/rasterToPolygons.Rd
new file mode 100644
index 0000000..7ab956b
--- /dev/null
+++ b/man/rasterToPolygons.Rd
@@ -0,0 +1,46 @@
+\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)
+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 }
diff --git a/man/rasterize.Rd b/man/rasterize.Rd
new file mode 100644
index 0000000..98df677
--- /dev/null
+++ b/man/rasterize.Rd
@@ -0,0 +1,175 @@
+\name{rasterize}
+
+\docType{methods}
+
+\alias{rasterize}
+\alias{rasterize,matrix,Raster-method}
+\alias{rasterize,data.frame,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 w [...]
+
+\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 [...]
+
+If you want to know the number of points in each grid cell, you can use \code{ fun='count'} or \code{fun=function(x,...){length(x)}}. For the number of unique values per grid cell you can use: \code{fun=function(x, ...){ length(unique(na.rm(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
+x <- runif(n) * 360 - 180
+y <- runif(n) * 180 - 90
+xy <- cbind(x, y)
+# get the (last) indices
+r0 <- rasterize(xy, r)
+# prensence/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)
+
+r[] <- 1:ncell(r)
+r <- rasterize(lines, r, mask=TRUE)
+plot(r)
+
+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 at 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}
+
diff --git a/man/readAll.Rd b/man/readAll.Rd
new file mode 100644
index 0000000..dbf0e28
--- /dev/null
+++ b/man/readAll.Rd
@@ -0,0 +1,36 @@
+\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}
diff --git a/man/reclassify.Rd b/man/reclassify.Rd
new file mode 100644
index 0000000..abb3736
--- /dev/null
+++ b/man/reclassify.Rd
@@ -0,0 +1,57 @@
+\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 must have 3 columns. The first two columns are "from" "to" of 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 byrow=TRUE)). You can also provide a two column matrix ("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{cut}, \link{calc}} }
+
+
+
+
+\examples{
+
+r <- raster(ncols=36, nrows=18)
+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)
+
+# equivalent to
+rc <- reclassify(r, c(-Inf,0.25,1, 0.25,0.5,2, 0.5,Inf,3))
+}
+
+\keyword{spatial}
diff --git a/man/rectify.Rd b/man/rectify.Rd
new file mode 100644
index 0000000..9e9a7f0
--- /dev/null
+++ b/man/rectify.Rd
@@ -0,0 +1,36 @@
+\name{rectify}
+
+\alias{rectify}
+
+
+\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{
+rectify(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}
+
diff --git a/man/replacement.Rd b/man/replacement.Rd
new file mode 100644
index 0000000..6f65051
--- /dev/null
+++ b/man/replacement.Rd
@@ -0,0 +1,67 @@
+\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{[[<-,RasterBrick,numeric,missing-method}
+\alias{[[<-,RasterStackBrick,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)
+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}
diff --git a/man/resample.Rd b/man/resample.Rd
new file mode 100644
index 0000000..ef29331
--- /dev/null
+++ b/man/resample.Rd
@@ -0,0 +1,49 @@
+\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)
+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}
+
diff --git a/man/resolution.Rd b/man/resolution.Rd
new file mode 100644
index 0000000..4a61564
--- /dev/null
+++ b/man/resolution.Rd
@@ -0,0 +1,54 @@
+\name{resolution}
+
+\alias{xres}
+\alias{yres}
+\alias{res}
+\alias{xres,BasicRaster-method}
+\alias{yres,BasicRaster-method}
+\alias{res,BasicRaster-method}
+
+
+\alias{res<-}
+
+
+\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}
diff --git a/man/rotate.Rd b/man/rotate.Rd
new file mode 100644
index 0000000..26ef6be
--- /dev/null
+++ b/man/rotate.Rd
@@ -0,0 +1,42 @@
+\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)
+r[] <- as.vector(t(m))
+extent(r) <- extent(0, 360, -90, 90)
+rr <- rotate(r)
+}
+
+\keyword{spatial}
diff --git a/man/rotated.Rd b/man/rotated.Rd
new file mode 100644
index 0000000..785ff72
--- /dev/null
+++ b/man/rotated.Rd
@@ -0,0 +1,34 @@
+\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}
diff --git a/man/round.Rd b/man/round.Rd
new file mode 100644
index 0000000..33ad875
--- /dev/null
+++ b/man/round.Rd
@@ -0,0 +1,57 @@
+\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
+}
+
+\seealso{ \code{\link[base]{round}} }
+
+\value{
+a RasterLayer object
+}
+
+
+\examples{
+r <- raster(ncol=10, nrow=10)
+r[] <- runif(ncell(r)) * 10
+s <- round(r)
+
+}
+\keyword{spatial}
diff --git a/man/roundExtent.Rd b/man/roundExtent.Rd
new file mode 100644
index 0000000..ee2a502
--- /dev/null
+++ b/man/roundExtent.Rd
@@ -0,0 +1,39 @@
+\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 }
+
+
diff --git a/man/rowFromCell.Rd b/man/rowFromCell.Rd
new file mode 100644
index 0000000..81118ac
--- /dev/null
+++ b/man/rowFromCell.Rd
@@ -0,0 +1,47 @@
+\name{rowFromCell}
+
+\alias{colFromCell}
+\alias{rowFromCell}
+\alias{rowColFromCell}
+
+
+\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}
diff --git a/man/rowSums.Rd b/man/rowSums.Rd
new file mode 100644
index 0000000..cf0658d
--- /dev/null
+++ b/man/rowSums.Rd
@@ -0,0 +1,45 @@
+\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}
+
diff --git a/man/sampleInt.Rd b/man/sampleInt.Rd
new file mode 100644
index 0000000..0bec9c3
--- /dev/null
+++ b/man/sampleInt.Rd
@@ -0,0 +1,35 @@
+\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}
diff --git a/man/sampleRandom.Rd b/man/sampleRandom.Rd
new file mode 100644
index 0000000..140f8f0
--- /dev/null
+++ b/man/sampleRandom.Rd
@@ -0,0 +1,50 @@
+\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}
diff --git a/man/sampleRegular.Rd b/man/sampleRegular.Rd
new file mode 100644
index 0000000..da0abbf
--- /dev/null
+++ b/man/sampleRegular.Rd
@@ -0,0 +1,44 @@
+\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 then 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}
diff --git a/man/sampleStratified.Rd b/man/sampleStratified.Rd
new file mode 100644
index 0000000..c3f11a7
--- /dev/null
+++ b/man/sampleStratified.Rd
@@ -0,0 +1,48 @@
+\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'
+ r[] <- round((runif(ncell(r))+0.5)*3)
+ sampleStratified(r, size=3)
+}
+
+\keyword{spatial}
diff --git a/man/saveStack.Rd b/man/saveStack.Rd
new file mode 100644
index 0000000..2dcac0a
--- /dev/null
+++ b/man/saveStack.Rd
@@ -0,0 +1,48 @@
+\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))
+s <- stackSave(s, "mystack")
+# note that filename adds an extension .stk to a stackfile
+\dontrun{
+s2 <- stackOpen("mystack.stk")
+s2
+}
+}
+\keyword{ spatial }
+
diff --git a/man/scale.Rd b/man/scale.Rd
new file mode 100644
index 0000000..8ed1213
--- /dev/null
+++ b/man/scale.Rd
@@ -0,0 +1,36 @@
+\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 }
diff --git a/man/scalebar.Rd b/man/scalebar.Rd
new file mode 100644
index 0000000..7524a26
--- /dev/null
+++ b/man/scalebar.Rd
@@ -0,0 +1,47 @@
+\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}
diff --git a/man/select.Rd b/man/select.Rd
new file mode 100644
index 0000000..68d5003
--- /dev/null
+++ b/man/select.Rd
@@ -0,0 +1,73 @@
+\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)
+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 at polygons[[1]]@Polygons[[2]]@hole <- TRUE
+
+plot(pols, col=rainbow(3))
+ps <- select(pols) # now click on the map twice
+ps
+}
+}
+
+\keyword{spatial}
+
diff --git a/man/setExtent.Rd b/man/setExtent.Rd
new file mode 100644
index 0000000..420122f
--- /dev/null
+++ b/man/setExtent.Rd
@@ -0,0 +1,45 @@
+\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}
diff --git a/man/setMinMax.Rd b/man/setMinMax.Rd
new file mode 100644
index 0000000..2de23fd
--- /dev/null
+++ b/man/setMinMax.Rd
@@ -0,0 +1,41 @@
+\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}{ A \code{Raster*} object }
+}
+
+\value{
+a 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 }
+
diff --git a/man/setValues.Rd b/man/setValues.Rd
new file mode 100644
index 0000000..2c98c3f
--- /dev/null
+++ b/man/setValues.Rd
@@ -0,0 +1,62 @@
+\name{setValues}
+
+\alias{values<-}
+\alias{values<-,RasterLayer-method}
+\alias{values<-,RasterLayerSparse-method}
+\alias{values<-,RasterStack-method}
+\alias{values<-,RasterBrick-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{
+You can use the setValues function to assign values to a Raster* object. 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 these functions do.
+}
+
+\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
+}
+
+
+\examples{
+r <- raster(ncol=10, nrow=10)
+vals <- 1:ncell(r)
+r <- setValues(r, vals)
+# equivalent to
+r[] <- vals
+}
+
+
+\keyword{ spatial }
+\keyword{ methods }
+
diff --git a/man/shapefile.Rd b/man/shapefile.Rd
new file mode 100644
index 0000000..ceaa6de
--- /dev/null
+++ b/man/shapefile.Rd
@@ -0,0 +1,53 @@
+
+\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 geomotry), .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}
+
diff --git a/man/shift.Rd b/man/shift.Rd
new file mode 100644
index 0000000..363cdcb
--- /dev/null
+++ b/man/shift.Rd
@@ -0,0 +1,47 @@
+\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}(object, x=0, y=0, filename='', ...)
+
+\S4method{shift}{SpatialPolygons}(object, x=0, y=0, ...)
+
+\S4method{shift}{SpatialLines}(object, x=0, y=0, ...)
+
+\S4method{shift}{SpatialPoints}(object, x=0, y=0, ...)
+}
+
+\arguments{
+ \item{object}{Raster* or Spatial* object}
+ \item{x}{numeric. The shift in horizontal direction}
+ \item{y}{numeric. The shift in vertical direction}
+ \item{filename}{character file name (optional)}
+ \item{...}{if \code{object} 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, x=1, y=-1)
+}
+
+\keyword{spatial}
diff --git a/man/slopeAspect.Rd b/man/slopeAspect.Rd
new file mode 100644
index 0000000..ebb27c1
--- /dev/null
+++ b/man/slopeAspect.Rd
@@ -0,0 +1,30 @@
+\name{Slope and aspect}
+
+\alias{slopeAspect}
+
+\title{Slope and aspect}
+
+\description{
+This is a deprecated function. Use \code{\link{terrain}} instead.
+}
+
+\usage{
+slopeAspect(dem, filename='', out=c('slope', 'aspect'), unit='radians',
+ neighbors=8, flatAspect, ...)
+}
+
+\arguments{
+ \item{dem}{RasterLayer object with elevation values in map units, or in meters when the crs is longitude/latitude}
+ \item{filename}{Character. Filename. optional}
+ \item{out}{Character vector containing one or more of these options: 'slope', 'aspect'}
+ \item{unit}{Character. 'degrees' or 'radians' }
+ \item{neighbors}{Integer. Indicating how many neighboring cells to use to compute slope for any cell. Either 8 (queen case) or 4 (rook case), see Details}
+ \item{flatAspect}{Numeric or NA. What value to use for aspect when slope is zero (and hence the aspect is undefined)? The default value is 90 degrees (or 0.5*pi radians) }
+ \item{...}{Standard additional arguments for writing RasterLayer files}
+}
+
+\seealso{ \code{\link{terrain}} }
+
+
+
+\keyword{spatial}
diff --git a/man/spEasy.Rd b/man/spEasy.Rd
new file mode 100644
index 0000000..4420bd2
--- /dev/null
+++ b/man/spEasy.Rd
@@ -0,0 +1,46 @@
+\name{sp}
+
+\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=NA)
+spPolygons(x, ..., attr=NULL, crs=NA)
+}
+
+\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 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))
+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}
diff --git a/man/spplot.Rd b/man/spplot.Rd
new file mode 100644
index 0000000..cc63e9f
--- /dev/null
+++ b/man/spplot.Rd
@@ -0,0 +1,60 @@
+\name{spplot}
+
+\docType{methods}
+
+\alias{spplot}
+\alias{spplot,Raster-method}
+\alias{spplot,SpatialPoints-method}
+\alias{lines,SpatialPolygons-method}
+
+
+\title{Use spplot to plot a Raster* 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 these wrapper functions is the additional \code{maxpixels} argument to sample large Raster objects for faster drawing.
+}
+
+\section{Methods}{
+\describe{
+\code{spplot(obj, ..., maxpixels=50000, as.table=TRUE)}
+
+\tabular{rll}{
+\tab \code{obj} \tab A Raster* object \cr
+\tab \code{...} \tab Any argument that can be passed to \code{\link[sp]{spplot}} and \link[lattice]{levelplot} \cr
+\tab \code{maxpixels} \tab Integer. Number of pixels to sample from each layer of large Raster objects \cr
+}
+}}
+
+
+\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}
+
diff --git a/man/stack.Rd b/man/stack.Rd
new file mode 100644
index 0000000..5eaddc5
--- /dev/null
+++ b/man/stack.Rd
@@ -0,0 +1,66 @@
+\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}
+
+
+\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]{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}
diff --git a/man/stackApply.Rd b/man/stackApply.Rd
new file mode 100644
index 0000000..897b500
--- /dev/null
+++ b/man/stackApply.Rd
@@ -0,0 +1,50 @@
+\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 [...]
+
+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)
+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}
+
diff --git a/man/stackSelect.Rd b/man/stackSelect.Rd
new file mode 100644
index 0000000..ba65dce
--- /dev/null
+++ b/man/stackSelect.Rd
@@ -0,0 +1,46 @@
+\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 cell 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)
+r[] <- 1
+s <- stack(r, r+2, r+5)
+r[] <- round((runif(ncell(r)))*3)
+x <- stackSelect(s, r)
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/strech.Rd b/man/strech.Rd
new file mode 100644
index 0000000..a5be028
--- /dev/null
+++ b/man/strech.Rd
@@ -0,0 +1,41 @@
+\name{stretch}
+
+\alias{stretch}
+
+\title{Stretch}
+
+\description{
+Linear strech of values in a Raster object
+}
+
+\usage{
+stretch(x, minv=0, maxv=255, minq=0, maxq=1, filename='', ...)
+}
+
+\arguments{
+\item{x}{Raster* object}
+\item{minv}{numeric >= 0 and smaller than maxv. lower bound of streched value}
+\item{maxv}{numeric <= 255 and larger than maxv. upper bound of streched value}
+\item{minq}{numeric >= 0 and smaller than maxq. lower quitile bound of original value}
+\item{maxq}{numeric <= 1 and larger than minq. upper quitile bound of original value}
+\item{filename}{character. Filename for the output Raster object (optional)}
+\item{...}{ additional arguments as for \code{\link{writeRaster}}}
+}
+
+
+\value{
+Raster* object
+}
+
+\seealso{stretch argument in \code{\link{plotRGB}}}
+
+\examples{
+r <- raster(nc=10, nr=10)
+r[] <- 1:100 * 10
+stretch(r)
+s <- stack(r, r*2)
+stretch(s)
+
+}
+
+\keyword{spatial}
diff --git a/man/subset.Rd b/man/subset.Rd
new file mode 100644
index 0000000..454eb46
--- /dev/null
+++ b/man/subset.Rd
@@ -0,0 +1,57 @@
+\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]{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 }
diff --git a/man/substitute.Rd b/man/substitute.Rd
new file mode 100644
index 0000000..a10106d
--- /dev/null
+++ b/man/substitute.Rd
@@ -0,0 +1,62 @@
+\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{cut}}}
+
+\examples{
+r <- raster(ncol=10, nrow=10)
+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}
+
diff --git a/man/summary.Rd b/man/summary.Rd
new file mode 100644
index 0000000..ae6f766
--- /dev/null
+++ b/man/summary.Rd
@@ -0,0 +1,32 @@
+\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}
diff --git a/man/symdif.Rd b/man/symdif.Rd
new file mode 100644
index 0000000..8e66391
--- /dev/null
+++ b/man/symdif.Rd
@@ -0,0 +1,49 @@
+\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*
+}
+
+\author{Robert J. Hijmans}
+
+\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')
+ projection(b) <- projection(p)
+ sd <- symdif(p, b)
+ plot(sd, col='red')
+}
+}
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/terrain.Rd b/man/terrain.Rd
new file mode 100644
index 0000000..ada3f58
--- /dev/null
+++ b/man/terrain.Rd
@@ -0,0 +1,93 @@
+\name{terrain}
+
+\alias{terrain}
+
+\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{
+terrain(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), as in \href{http://www.gdal.org/gdaldem.html}{gdaldem}. 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}
diff --git a/man/text.Rd b/man/text.Rd
new file mode 100644
index 0000000..b78c310
--- /dev/null
+++ b/man/text.Rd
@@ -0,0 +1,57 @@
+\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}
+
diff --git a/man/transpose.Rd b/man/transpose.Rd
new file mode 100644
index 0000000..74fea46
--- /dev/null
+++ b/man/transpose.Rd
@@ -0,0 +1,37 @@
+\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)
+r[] <- 1:ncell(r)
+rt <- t(r)
+}
+
+\keyword{spatial}
diff --git a/man/trim.Rd b/man/trim.Rd
new file mode 100644
index 0000000..ae35741
--- /dev/null
+++ b/man/trim.Rd
@@ -0,0 +1,49 @@
+\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, ...)
+}
+
+\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{...}{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}
+
diff --git a/man/union.Rd b/man/union.Rd
new file mode 100644
index 0000000..7229f6f
--- /dev/null
+++ b/man/union.Rd
@@ -0,0 +1,67 @@
+\name{union}
+
+\docType{methods}
+
+\alias{union}
+\alias{union,Extent,Extent-method}
+\alias{union,SpatialPolygons,SpatialPolygons-method}
+\alias{union,SpatialPolygons,missing-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.
+
+Single SpatialPolygons* object. Overlapping polygons are intersected. Original attributes are lost. New attributes allow for determining how many, and which, polygons overlapped.
+}
+
+\usage{
+\S4method{union}{Extent,Extent}(x, y)
+
+\S4method{union}{SpatialPolygons,SpatialPolygons}(x, y)
+
+\S4method{union}{SpatialPolygons,missing}(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')
+ projection(b) <- projection(p)
+ u <- union(p0, b)
+ plot(u, col=2:4)
+}
+}
+
+
+\keyword{methods}
+\keyword{spatial}
+
diff --git a/man/unique.Rd b/man/unique.Rd
new file mode 100644
index 0000000..a00490d
--- /dev/null
+++ b/man/unique.Rd
@@ -0,0 +1,42 @@
+\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, or the unique combinations of values in a multi-layer raster object.
+}
+
+\usage{
+\S4method{unique}{RasterLayer,missing}(x, incomparables=FALSE, ...)
+
+\S4method{unique}{RasterStackBrick,missing}(x, incomparables=FALSE, ...)
+}
+
+\arguments{
+ \item{x}{Raster object}
+ \item{incomparables}{ignored. Must be missing}
+ \item{...}{additional arguments. One implemented: \code{progress}, as in \code{\link{writeRaster}}}
+}
+
+\seealso{ \code{\link[base]{unique}} }
+
+\value{
+vector or matrix
+}
+
+
+
+\examples{
+r <- raster(ncol=10, nrow=10)
+r[] <- round(runif(ncell(r))*10)
+unique(r)
+unique(stack(r, round(r/2)))
+}
+
+\keyword{spatial}
diff --git a/man/unstack.Rd b/man/unstack.Rd
new file mode 100644
index 0000000..a81826c
--- /dev/null
+++ b/man/unstack.Rd
@@ -0,0 +1,39 @@
+\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 }
diff --git a/man/update.Rd b/man/update.Rd
new file mode 100644
index 0000000..0b065c3
--- /dev/null
+++ b/man/update.Rd
@@ -0,0 +1,68 @@
+\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{
+update(object, ...)
+}
+
+\arguments{
+ \item{object}{RasterLayer or RasterBrick that is associated with a file}
+ \item{...}{Additional arguments.
+
+ \code{v} - vector or matrix with new values
+
+ \code{cell} - cell from where to start writing. Or a vector of cell numbers if v is a vector of the same length.
+
+ \code{band} - band (layer) to update (for RasterBrick objects).
+ }
+}
+
+\value{
+RasterLayer or RasterBrick
+}
+
+
+
+\examples{
+# setting up an example RasterLayer with file
+r <- raster(nrow=5, ncol=10)
+r[] = 0
+r <- writeRaster(r, 'test', 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}
+
diff --git a/man/validCell.Rd b/man/validCell.Rd
new file mode 100644
index 0000000..f4f992b
--- /dev/null
+++ b/man/validCell.Rd
@@ -0,0 +1,40 @@
+\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}
diff --git a/man/validNames.Rd b/man/validNames.Rd
new file mode 100644
index 0000000..5e420d6
--- /dev/null
+++ b/man/validNames.Rd
@@ -0,0 +1,31 @@
+\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'))
+}
+
diff --git a/man/weighted.mean.Rd b/man/weighted.mean.Rd
new file mode 100644
index 0000000..94bb0f7
--- /dev/null
+++ b/man/weighted.mean.Rd
@@ -0,0 +1,61 @@
+\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)
+}
+
diff --git a/man/which.Rd b/man/which.Rd
new file mode 100644
index 0000000..a9b7f3e
--- /dev/null
+++ b/man/which.Rd
@@ -0,0 +1,57 @@
+\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)
+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}
diff --git a/man/which.minmax.Rd b/man/which.minmax.Rd
new file mode 100644
index 0000000..76b997e
--- /dev/null
+++ b/man/which.minmax.Rd
@@ -0,0 +1,65 @@
+\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}
diff --git a/man/writeFormats.Rd b/man/writeFormats.Rd
new file mode 100644
index 0000000..7c15804
--- /dev/null
+++ b/man/writeFormats.Rd
@@ -0,0 +1,45 @@
+\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 }
diff --git a/man/writeRaster.Rd b/man/writeRaster.Rd
new file mode 100644
index 0000000..da66142
--- /dev/null
+++ b/man/writeRaster.Rd
@@ -0,0 +1,118 @@
+\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.
+(see \url{http://www.gdal.org/frmt_gtiff.html})
+
+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
+}
+
+\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{
+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="allint.grd", datatype='INT4S', overwrite=TRUE)
+
+# make a brick and save multi-layer file
+b <- brick(r, sqrt(r))
+bf <- writeRaster(b, filename="multi.grd", bandorder='BIL', overwrite=TRUE)
+
+# write to a new geotiff file (depends on rgdal)
+if (require(rgdal)) {
+ rf <- writeRaster(r, filename="test.tif", format="GTiff", overwrite=TRUE)
+ bf <- writeRaster(b, filename="multi.tif", options="INTERLEAVE=BAND", overwrite=TRUE)
+}
+
+# write to netcdf
+if (require(ncdf4)) {
+ rnc <- writeRaster(r, filename='netCDF.nc', format="CDF", overwrite=TRUE)
+}
+}
+
+\keyword{ spatial }
+\keyword{ methods }
+
diff --git a/man/writeValues.Rd b/man/writeValues.Rd
new file mode 100644
index 0000000..9a4997e
--- /dev/null
+++ b/man/writeValues.Rd
@@ -0,0 +1,91 @@
+\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{
+writeStart(x, filename, ...)
+writeValues(x, v, start)
+writeStop(x)
+}
+
+\arguments{
+ \item{x}{Raster* object}
+ \item{filename}{character. Output file name}
+ \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{
+
+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 }
diff --git a/man/xyFromCell.Rd b/man/xyFromCell.Rd
new file mode 100644
index 0000000..07889d3
--- /dev/null
+++ b/man/xyFromCell.Rd
@@ -0,0 +1,65 @@
+\name{xyFromCell}
+
+\alias{xFromCol}
+\alias{yFromRow}
+\alias{xyFromCell}
+\alias{xFromCell}
+\alias{yFromCell}
+
+
+\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{
+xFromCol(object, col=1:ncol(object))
+yFromRow(object, row=1:nrow(object))
+xyFromCell(object, cell, spatial=FALSE)
+xFromCell(object, cell)
+yFromCell(object, cell)
+}
+
+
+\arguments{
+ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)}
+ \item{cell}{cell number(s)}
+ \item{col}{column number; or vector of column numbers}
+ \item{row}{row number; or vector of row numbers}
+ \item{spatial}{return a SpatialPoints object (sp package) instead of a matrix}
+}
+
+\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
+}
+
+
+\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}
diff --git a/man/zApply.Rd b/man/zApply.Rd
new file mode 100644
index 0000000..0d47c60
--- /dev/null
+++ b/man/zApply.Rd
@@ -0,0 +1,45 @@
+\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}
diff --git a/man/zonal.Rd b/man/zonal.Rd
new file mode 100644
index 0000000..4d46f95
--- /dev/null
+++ b/man/zonal.Rd
@@ -0,0 +1,60 @@
+\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)
+r[] <- runif(ncell(r)) * 1:ncell(r)
+z <- r
+z[] <- rep(1:5, each=20)
+# for big 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}
+
diff --git a/man/zoom.Rd b/man/zoom.Rd
new file mode 100644
index 0000000..d0944a2
--- /dev/null
+++ b/man/zoom.Rd
@@ -0,0 +1,46 @@
+\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 \code{\link[graphics]{plot}}}
+}
+
+\value{
+Extent object (invisibly)
+}
+
+
+
+\seealso{ \code{\link[raster]{drawExtent}}, \code{\link[raster]{plot}}}
+
+\keyword{spatial}
+
diff --git a/man/zvalues.Rd b/man/zvalues.Rd
new file mode 100644
index 0000000..0a56a4a
--- /dev/null
+++ b/man/zvalues.Rd
@@ -0,0 +1,40 @@
+\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}
diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
new file mode 100644
index 0000000..6fd9d80
--- /dev/null
+++ b/src/RcppExports.cpp
@@ -0,0 +1,188 @@
+// This file was generated by Rcpp::compileAttributes
+// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+#include <Rcpp.h>
+
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ 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);
+ __result = Rcpp::wrap(doBilinear(xy, x, y, v));
+ return __result;
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ 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);
+ __result = Rcpp::wrap(doCellFromRowCol(nrow, ncol, rownr, colnr));
+ return __result;
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericMatrix >::type xyv(xyvSEXP);
+ Rcpp::traits::input_parameter< NumericVector >::type res(resSEXP);
+ Rcpp::traits::input_parameter< int >::type nodes(nodesSEXP);
+ __result = Rcpp::wrap(getPolygons(xyv, res, nodes));
+ return __result;
+END_RCPP
+}
+// getMode
+double getMode(NumericVector values, int ties);
+RcppExport SEXP raster_getMode(SEXP valuesSEXP, SEXP tiesSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericVector >::type values(valuesSEXP);
+ Rcpp::traits::input_parameter< int >::type ties(tiesSEXP);
+ __result = Rcpp::wrap(getMode(values, ties));
+ return __result;
+END_RCPP
+}
+// doSpmin
+NumericVector doSpmin(NumericVector x, NumericVector y);
+RcppExport SEXP raster_doSpmin(SEXP xSEXP, SEXP ySEXP) {
+BEGIN_RCPP
+ Rcpp::RObject __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
+ Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
+ __result = Rcpp::wrap(doSpmin(x, y));
+ return __result;
+END_RCPP
+}
+// doSpmax
+NumericVector doSpmax(NumericVector x, NumericVector y);
+RcppExport SEXP raster_doSpmax(SEXP xSEXP, SEXP ySEXP) {
+BEGIN_RCPP
+ Rcpp::RObject __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
+ Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
+ __result = Rcpp::wrap(doSpmax(x, y));
+ return __result;
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
+ Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
+ Rcpp::traits::input_parameter< bool >::type narm(narmSEXP);
+ __result = Rcpp::wrap(ppmin(x, y, narm));
+ return __result;
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP);
+ Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP);
+ Rcpp::traits::input_parameter< bool >::type narm(narmSEXP);
+ __result = Rcpp::wrap(ppmax(x, y, narm));
+ return __result;
+END_RCPP
+}
+// doRowMin
+NumericVector doRowMin(NumericMatrix x, bool narm);
+RcppExport SEXP raster_doRowMin(SEXP xSEXP, SEXP narmSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP);
+ Rcpp::traits::input_parameter< bool >::type narm(narmSEXP);
+ __result = Rcpp::wrap(doRowMin(x, narm));
+ return __result;
+END_RCPP
+}
+// doRowMax
+NumericVector doRowMax(NumericMatrix x, bool narm);
+RcppExport SEXP raster_doRowMax(SEXP xSEXP, SEXP narmSEXP) {
+BEGIN_RCPP
+ Rcpp::RObject __result;
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP);
+ Rcpp::traits::input_parameter< bool >::type narm(narmSEXP);
+ __result = Rcpp::wrap(doRowMax(x, narm));
+ return __result;
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ 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);
+ __result = Rcpp::wrap(doCellFromXY(ncols, nrows, xmin, xmax, ymin, ymax, x, y));
+ return __result;
+END_RCPP
+}
+// doXYFromCell
+NumericMatrix doXYFromCell(int ncols, int 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 __result;
+ Rcpp::RNGScope __rngScope;
+ 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 cell(cellSEXP);
+ __result = Rcpp::wrap(doXYFromCell(ncols, nrows, xmin, xmax, ymin, ymax, cell));
+ return __result;
+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 __result;
+ Rcpp::RNGScope __rngScope;
+ 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);
+ __result = Rcpp::wrap(doFourCellsFromXY(ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat));
+ return __result;
+END_RCPP
+}
diff --git a/src/aggregate.c b/src/aggregate.c
new file mode 100644
index 0000000..e74ae0c
--- /dev/null
+++ b/src/aggregate.c
@@ -0,0 +1,153 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+#define min(a, b) (((a) < (b)) ? (a) : (b))
+#define max(a,b) ((a)>(b)?(a):(b))
+
+
+SEXP aggregate(SEXP d, SEXP op, SEXP na, SEXP dim) {
+
+ R_len_t i, j, k, n;
+ SEXP v;
+ double *xd, *xv, dv;
+ int *cnts, row, col, newrow, newcol, newcell, mean, expected;
+
+ int oper = INTEGER(op)[0];
+ int narm = INTEGER(na)[0];
+
+// int nrin = INTEGER(dim)[0];
+ int ncin = INTEGER(dim)[1];
+ int nl = INTEGER(dim)[2];
+ int nrout = INTEGER(dim)[3];
+ int ncout = INTEGER(dim)[4];
+ int xfact = INTEGER(dim)[5];
+ int yfact = INTEGER(dim)[6];
+
+
+ PROTECT(d = coerceVector(d, REALSXP));
+ xd = REAL(d);
+
+ if (oper==1) {
+ oper = 0;
+ mean = 1;
+ } else {
+ mean = 0;
+ }
+
+ cnts=(int *) malloc(nrout*ncout*nl*sizeof(int));
+ PROTECT( v = allocVector(REALSXP, nrout*ncout*nl) );
+ xv = REAL(v);
+
+ if (oper==2) {
+ for (i=0; i<length(v); i++) {
+ xv[i] = R_PosInf;
+ cnts[i] = 0;
+ }
+
+ } else if (oper ==3) {
+ for (i=0; i<length(v); i++) {
+ xv[i] = R_NegInf;
+ cnts[i] = 0;
+ }
+
+ } else {
+ for (i=0; i<length(v); i++) {
+ xv[i] = 0;
+ cnts[i] = 0;
+ }
+ }
+
+ int ncell = length(d) / nl;
+ int ncellout = ncout * nrout;
+
+ if (oper==0) { // sum or mean
+ for (i=0; i<ncell; i++) {
+ row = i / ncin;
+ col = i - (row*ncin);
+ newrow = row / yfact;
+ newcol = col / xfact;
+ newcell = newrow * ncout + newcol;
+ if ((newcol < ncout) & (newrow < nrout)) {
+ for (k=0; k<nl; k++) {
+ j = i + ncell * k;
+ if (!R_IsNA(xd[j])) {
+ n = newcell + ncellout * k;
+ xv[n] = xv[n] + xd[j];
+ cnts[n] = cnts[n] + 1;
+ }
+ }
+ }
+ }
+ } else {
+
+ for (i=0; i<ncell; i++) {
+ row = i / ncin;
+ col = i - (row*ncin);
+ newrow = row / yfact;
+ newcol = col / xfact;
+ newcell = newrow * ncout + newcol;
+ if ((newcol < ncout) & (newrow < nrout)) {
+ for (k=0; k<nl; k++) {
+ j = i + ncell * k;
+ if (!R_IsNA(xd[j])) {
+ n = newcell + ncellout * k;
+ if (oper==2) {
+ xv[n] = min(xv[n], xd[j]);
+ } else if (oper==3) {
+ xv[n] = max(xv[n], xd[j]);
+ }
+ cnts[n] = cnts[n] + 1;
+ }
+ }
+ }
+ }
+ }
+ //Rprintf ("newcell = %i \n", newcell);
+ if (mean==1) {
+ expected = xfact * yfact;
+ dv = 1.0 / expected;
+ if (narm==0) {
+ for (i=0; i<length(v); i++) {
+ if (cnts[i] == expected) {
+ xv[i] = xv[i] * dv;
+ } else {
+ xv[i] = R_NaReal;
+ }
+ }
+ } else {
+ for (i=0; i<length(v); i++) {
+ if (cnts[i] == expected) {
+ xv[i] = xv[i] * dv;
+ } else if (cnts[i] == 0) {
+ xv[i] = R_NaReal;
+ } else {
+ xv[i] = xv[i] / cnts[i];
+ }
+ }
+ }
+ } else if (narm==0) {
+ expected = xfact * yfact;
+ for (i=0; i<length(v); i++) {
+ if (cnts[i] < expected) {
+ xv[i] = R_NaReal;
+ }
+ }
+ } else {
+ for (i=0; i<length(v); i++) {
+ if (cnts[i] == 0) {
+ xv[i] = R_NaReal;
+ }
+ }
+ }
+ UNPROTECT(2);
+ return(v);
+}
+
+
+
diff --git a/src/aggregate_get.c b/src/aggregate_get.c
new file mode 100644
index 0000000..ea67e85
--- /dev/null
+++ b/src/aggregate_get.c
@@ -0,0 +1,73 @@
+/* Robert Hijmans, October 2014 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+
+SEXP aggregate_get(SEXP d, SEXP dim) {
+
+ R_len_t i, j, k, q;
+
+ SEXP val;
+ int nrow, ncol, dx, dy, dz, ro, co, lo, c1, c2, g;
+ double *xd, *xval;
+
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+ //nlyr = INTEGER(dim)[2];
+ dy = INTEGER(dim)[3];
+ dx = INTEGER(dim)[4];
+ dz = INTEGER(dim)[5];
+ PROTECT(d = coerceVector(d, REALSXP));
+
+ int n = length(d);
+ int blockcells = dx * dy * dz;
+ int blocks = n / blockcells;
+ int ncell = nrow * ncol;
+// int dxdy = dx * dy;
+ int bpRow = ncol / dx;
+ int bpCol = nrow / dy;
+ int bpLyr = bpRow * bpCol;
+
+
+ PROTECT( val = allocVector(REALSXP, n) );
+
+ xd = REAL(d);
+ xval = REAL(val);
+
+ int f;
+
+ for (i = 0; i < blocks; i++) {
+ ro = (dy * (i / bpRow)) % nrow;
+ co = dx * (i % bpRow);
+ lo = dz * (i / bpLyr);
+
+ f = 0;
+ g = i * blockcells;
+ // Rprintf ("\n\nlo = %i \n\n", lo);
+
+ for (j = lo; j < (lo+dz); j++) {
+ c1 = (j * ncell);
+ for (k = ro; k < (ro+dy); k++) {
+ c2 = k * ncol;
+ for (q=co; q < (co+dx); q++) {
+ //int cell = c1 + c2 + q;
+ xval[g+f] = xd[c1 + c2 + q];
+ f++;
+ }
+ }
+ }
+ }
+ UNPROTECT(2);
+ return(val);
+}
+
+
+
diff --git a/src/bilinear.cpp b/src/bilinear.cpp
new file mode 100644
index 0000000..c7b539d
--- /dev/null
+++ b/src/bilinear.cpp
@@ -0,0 +1,35 @@
+#include <Rcpp.h>
+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;
+}
diff --git a/src/broom.c b/src/broom.c
new file mode 100644
index 0000000..a4eebda
--- /dev/null
+++ b/src/broom.c
@@ -0,0 +1,209 @@
+/* Robert Hijmans, October 2011
+This is an implementation of J. Ronald Eastman's pushbroom algorithm
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+#define min( a, b ) ( ((a) < (b)) ? (a) : (b) )
+
+
+SEXP broom(SEXP d, SEXP f, SEXP dm, SEXP dist, SEXP dw) {
+
+ R_len_t i, j, r;
+ SEXP dis;
+ int n, nr, nc, down;
+ double *xd, *xdis, *xf;
+ double dx, dy, dxy;
+
+ dx = REAL(dist)[0];
+ dy = REAL(dist)[1];
+ dxy = REAL(dist)[2];
+ down = INTEGER(dw)[0];
+ int leftright = 2; //INTEGER(lr)[0];
+ nr = INTEGER(dm)[0];
+ nc = INTEGER(dm)[1];
+ n = nr * nc;
+// Rprintf ("n = %i \n", n);
+
+ PROTECT(d = coerceVector(d, REALSXP));
+ PROTECT(f = coerceVector(f, REALSXP));
+
+ xd = REAL(d);
+ xf = REAL(f);
+
+ PROTECT( dis = allocVector(REALSXP, n) );
+ xdis = REAL(dis);
+
+ for (i=0; i<n; i++) {
+ xdis[i] = R_PosInf;
+ }
+
+ 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 ( R_IsNA(xd[0])) {
+ xdis[0] = xf[0] + dy;
+ } else {
+ xdis[0] = 0;
+ }
+ // other cells
+ for (i=1; i<nc; i++) {
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(min(xf[i] + dy, xf[i-1] + dxy), xdis[i-1] + dx);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ //other rows
+ for (r=1; r<nr; r++) {
+ i=r*nc;
+ if (R_IsNA(xd[i])) {
+ xdis[i] = xdis[i-nc] + dy;
+ } else {
+ xdis[i] = 0;
+ }
+ for (i=r*nc+1; i<((r+1)*nc); i++) {
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(min(xdis[i-1] + dx, xdis[i-nc] + dy), xdis[i-nc-1] + dxy);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ }
+
+ }
+ //right to left
+ //first row
+ //first cell
+
+
+ if ((leftright == 0) | (leftright > 1)) {
+
+ if ( R_IsNA(xd[nc-1])) {
+ xdis[nc-1] = min(xdis[nc-1], xf[nc-1] + dy);
+ } else {
+ xdis[nc-1] = 0;
+ }
+
+ // other cells
+ for (i=(nc-2); i > -1; i--) {
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(min(min(xdis[i], xf[i] + dy), xf[i+1] + dxy), xdis[i+1] + dx);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ // other rows
+ for (r=1; r<nr; r++) {
+ i=(r+1)*nc-1;
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(xdis[i], xdis[i-nc] + dy);
+ } else {
+ xdis[i] = 0;
+ }
+ for (i=(r+1)*nc-2; i>(r*nc-1); i--) {
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(min(min(xdis[i], xdis[i+1] + dx), xdis[i-nc] + dy), xdis[i-nc+1] + dxy);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ }
+
+ }
+
+ } else {
+ // bottom to top
+ // left to right
+ // first (last) row
+ if (leftright >= 1) {
+
+ r = nr-1;
+ // first cell
+ i = r*nc;
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(xdis[i], xf[0] + dy);
+ } else {
+ xdis[i] = 0;
+ }
+ // other cells
+ for (i=(r*nc+1); i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ j = i - r*nc;
+ xdis[i] = min(min(min(xdis[i], xf[j] + dy), xf[j-1] + dxy), xdis[i-1] + dx);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ // other rows
+ for (r=nr-2; r >= 0; r--) {
+ i=r*nc;
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(xdis[i], xdis[i+nc] + dy);
+ } else {
+ xdis[i] = 0;
+ }
+ for (i=(r*nc+1); i<((r+1)*nc); i++) {
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(min(min(xdis[i], xdis[i-1] + dx), xdis[i+nc] + dy), xdis[i+nc-1] + dxy);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ }
+ }
+
+ if ((leftright == 0) | (leftright > 1)) {
+
+ // right to left
+ // first row
+ // first cell
+ if (R_IsNA(xd[n-1])) {
+ xdis[n-1] = min(xdis[n-1], xf[nc-1] + dy);
+ } else {
+ xdis[n-1] = 0;
+ }
+ // other cells
+ r = nr-1;
+ for (i=n-2; i > (r*nc-1); i--) {
+ if (R_IsNA(xd[i])) {
+ j = i - r*nc;
+ xdis[i] = min(min(min(xdis[i], xf[j] + dx), xf[j+1] + dxy), xdis[i+1] + dx);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ // other rows
+ for (r=nr-2; r >= 0; r--) {
+ i=(r+1)*nc-1;
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(xdis[i], xdis[i+nc] + dy);
+ } else {
+ xdis[i] = 0;
+ }
+
+ for (i=(r+1)*nc-2; i>(r*nc-1); i--) {
+ if (R_IsNA(xd[i])) {
+ xdis[i] = min(min(min(xdis[i], xdis[i+1] + dx), xdis[i+nc] + dy), xdis[i+nc+1] + dxy);
+ } else {
+ xdis[i] = 0;
+ }
+ }
+ }
+ }
+ }
+ UNPROTECT(3);
+ return(dis);
+}
+
diff --git a/src/cellRowCol.cpp b/src/cellRowCol.cpp
new file mode 100644
index 0000000..4579ce5
--- /dev/null
+++ b/src/cellRowCol.cpp
@@ -0,0 +1,29 @@
+#include <Rcpp.h>
+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;
+}
diff --git a/src/clamp.c b/src/clamp.c
new file mode 100644
index 0000000..07742f5
--- /dev/null
+++ b/src/clamp.c
@@ -0,0 +1,52 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+#include "Rmath.h"
+#include "util.h"
+
+
+SEXP clamp(SEXP d, SEXP rr, SEXP usevals) {
+
+ R_len_t i;
+ SEXP val;
+ double *xd, *r, *xval;
+ PROTECT(d = coerceVector(d, REALSXP));
+ PROTECT(rr = coerceVector(rr, REALSXP));
+ int uv = INTEGER(usevals)[0];
+ r = REAL(rr);
+ xd = REAL(d);
+
+ int n = length(d);
+ PROTECT( val = allocVector(REALSXP, n) );
+ xval = REAL(val);
+
+ if (uv) {
+ for (i=0; i<n; i++) {
+ if ( xd[i] < r[0] ) {
+ xval[i] = r[0];
+ } else if ( xd[i] > r[1] ) {
+ xval[i] = r[1];
+ } else {
+ xval[i] = xd[i];
+ }
+ }
+ } else {
+ for (i=0; i<n; i++) {
+ if ( (xd[i] < r[0]) | (xd[i] > r[1])) {
+ xval[i] = R_NaReal;
+ } else {
+ xval[i] = xd[i];
+ }
+ }
+ }
+ UNPROTECT(3);
+ return(val);
+}
+
+
diff --git a/src/direction.c b/src/direction.c
new file mode 100644
index 0000000..b422a66
--- /dev/null
+++ b/src/direction.c
@@ -0,0 +1,131 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+#include "dist_util.h"
+#include "util.h"
+
+
+
+double directionPlane(double x1, double y1, double x2, double y2, int degrees) {
+ double a, b;
+ a = y2 - y1;
+ b = x2 - x1;
+ a = atan2(b, a);
+ a = mod(a, M_2PI) ;
+ if (a < 0) {
+ a = a + M_2PI;
+ }
+ if (degrees) {
+ return( toDeg(a)) ;
+ } else {
+ return(a);
+ }
+}
+
+
+double directionSphere(double lon1, double lat1, double lon2, double lat2, int degrees) {
+ double dLon, y, x, azm;
+ lat1 = toRad(lat1);
+ lat2 = toRad(lat2);
+ lon1 = toRad(lon1);
+ lon2 = toRad(lon2);
+ dLon = lon2 - lon1;
+ y = sin(dLon) * cos( lat2 ) ;
+ x = cos( lat1 ) * sin( lat2) - sin( lat1 ) * cos( lat2 ) * cos(dLon) ;
+ azm = atan2(y, x);
+ if (azm < 0) {
+ azm = azm + M_2PI;
+ }
+ if (degrees) {
+ azm = toDeg(azm);
+ }
+ return(azm);
+}
+
+
+
+SEXP directionToNearestPoint(SEXP d, SEXP p, SEXP geo, SEXP degrees, SEXP fromto) {
+
+ R_len_t i, j;
+ SEXP res;
+ int pt;
+ double md, *xd, *xp, *xres, dist;
+
+ SEXP dim1 = getAttrib(d, R_DimSymbol);
+ int n = INTEGER(dim1)[0];
+ SEXP dim2 = getAttrib(p, R_DimSymbol);
+ int m = INTEGER(dim2)[0];
+ int deg = INTEGER(degrees)[0];
+
+ PROTECT(d = coerceVector(d, REALSXP));
+ PROTECT(p = coerceVector(p, REALSXP));
+ int lonlat = INTEGER(geo)[0];
+ int from = INTEGER(fromto)[0];
+
+ xd = REAL(d);
+ xp = REAL(p);
+
+ PROTECT( res = allocVector(REALSXP, n) );
+ xres = REAL(res);
+
+ double r = 6378137;
+
+ if (lonlat) {
+ for (i=0; i<n; i++) {
+ dist = distCos(xd[i], xd[i+n], xp[0], xp[m], r);
+ pt = 0;
+ for (j=1; j<m; j++) {
+ md = distCos(xd[i], xd[i+n], xp[j], xp[j+m], r);
+ if (md < dist) {
+ dist = md;
+ pt = j;
+ }
+ }
+ if (dist == 0) {
+ xres[i] = R_NaReal;
+ } else {
+ if (from) {
+ xres[i] = directionSphere(xp[pt], xp[pt+m], xd[i], xd[i+n], deg);
+ } else {
+ xres[i] = directionSphere(xd[i], xd[i+n], xp[pt], xp[pt+m], deg);
+ }
+ }
+ }
+
+ } else {
+
+ for (i=0; i<n; i++) {
+ dist = distPlane(xd[i], xd[i+n], xp[0], xp[m]) ;
+ pt = 0;
+ for (j=1; j<m; j++) {
+ md = distPlane(xd[i], xd[i+n], xp[j], xp[j+m]) ;
+ if (md < dist) {
+ dist = md;
+ pt = j;
+ }
+ }
+ if (dist == 0) {
+ xres[i] = R_NaReal;
+ } else {
+ if (from) {
+ xres[i] = directionPlane(xp[pt], xp[pt+m], xd[i], xd[i+n], deg);
+ } else {
+ xres[i] = directionPlane(xd[i], xd[i+n], xp[pt], xp[pt+m], deg);
+ }
+ }
+ }
+ }
+
+ UNPROTECT(3);
+ return(res) ;
+}
+
+
+
diff --git a/src/dist_util.c b/src/dist_util.c
new file mode 100644
index 0000000..12d03b4
--- /dev/null
+++ b/src/dist_util.c
@@ -0,0 +1,148 @@
+/* Robert Hijmans, June 2011 */
+
+#include <R.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rmath.h"
+#include "util.h"
+
+
+
+
+
+double distPlane(double x1, double y1, double x2, double y2) {
+ return( sqrt(pow((x2-x1),2) + pow((y2-y1), 2)) );
+}
+
+
+double distCos(double lon1, double lat1, double lon2, double lat2, double r) {
+ double cosd;
+ lon1 = toRad(lon1);
+ lon2 = toRad(lon2);
+ lat1 = toRad(lat1);
+ lat2 = toRad(lat2);
+ cosd = sin(lat1) * sin(lat2) + cos(lat1) * cos(lat2) * cos(lon1-lon2);
+ return acos(cosd) * r;
+}
+
+
+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;
+}
+
+
+
+
+double distVinSph(double lon1, double lat1, double lon2, double lat2, double r) {
+
+ double x, x1, x2, y;
+
+ lon1 = toRad(lon1);
+ lon2 = toRad(lon2);
+ lat1 = toRad(lat1);
+ lat2 = toRad(lat2);
+
+ x1 = sqrt(cos(lat2) * sin(lon1-lon2));
+ x2 = cos(lat1) * sin(lat2) - sin(lat1) * cos(lat2) * cos(lon1-lon2);
+ x = x1*x1 + x2*x2;
+ y = sin(lat1) * sin(lat2) + cos(lat1) * cos(lat2) * cos(lon1-lon2);
+
+ return r * atan2(x, y);
+}
+
+
+
+double distVinEll(double lon1, double lat1, double lon2, double lat2, double a, double b, double f) {
+/* Vincenty Inverse Solution of Geodesics on the Ellipsoid (c) Chris Veness 2002-2009
+ Calculate geodesic distance (in m) between two points specified by latitude/longitude
+ (in numeric degrees) using Vincenty inverse formula for ellipsoids
+ based on source http://www.movable-type.co.uk/scripts/latlong-vincenty.html (c) 2002-2009 Chris Veness
+*/
+ double L, U1, U2, sinU1, cosU1, sinU2, cosU2, lambda, sinLambda, cosLambda, sinSigma,
+ cosSigma, sigma, sinAlpha, cosSqAlpha, cos2SigmaM, C, lambdaP, uSq, A, B, deltaSigma;
+
+ int iterLimit, cont;
+
+ if ((lon1 == lon2) & (lat1 == lat2)) {
+
+ return 0.;
+
+ } else if ( isnan(lon1) | isnan(lat1) | isnan(lon2) | isnan(lat2)) {
+
+ return R_NaReal;
+
+ } else {
+
+ lon1 = toRad(lon1);
+ lon2 = toRad(lon2);
+ lat1 = toRad(lat1);
+ lat2 = toRad(lat2);
+
+ L = (lon2-lon1);
+ U1 = atan((1.-f) * tan(lat1));
+ U2 = atan((1.-f) * tan(lat2));
+ sinU1 = sin(U1);
+ cosU1 = cos(U1);
+ sinU2 = sin(U2);
+ cosU2 = cos(U2);
+ lambda = L;
+ iterLimit = 100;
+ cont = 1;
+
+ while (cont) {
+ sinLambda = sin(lambda);
+ cosLambda = cos(lambda);
+ sinSigma = sqrt((cosU2*sinLambda) * (cosU2*sinLambda) + (cosU1*sinU2-sinU1*cosU2*cosLambda) * (cosU1*sinU2-sinU1*cosU2*cosLambda));
+
+ cosSigma = sinU1*sinU2 + cosU1*cosU2*cosLambda;
+ sigma = atan2(sinSigma, cosSigma);
+ sinAlpha = cosU1 * cosU2 * sinLambda / sinSigma;
+ cosSqAlpha = 1. - sinAlpha*sinAlpha;
+ cos2SigmaM = cosSigma - 2.*sinU1*sinU2/cosSqAlpha;
+
+ if (isnan(cos2SigmaM)) {
+ cos2SigmaM = 0.; // equatorial line: cosSqAlpha=0 (�6)
+ }
+
+ C = f/16.*cosSqAlpha*(4.+f*(4.-3.*cosSqAlpha));
+ lambdaP = lambda;
+ lambda = L + (1.-C) * f * sinAlpha * (sigma + C*sinSigma*(cos2SigmaM+C*cosSigma*(-1.+2.*cos2SigmaM*cos2SigmaM)));
+
+ iterLimit = iterLimit - 1;
+ cont = (fabs(lambda-lambdaP) > 1e-12 && iterLimit > 0);
+ }
+
+ if (iterLimit==0) {
+ return R_NaReal; // formula failed to converge
+ } else {
+ uSq = cosSqAlpha * (a*a - b*b) / (b*b);
+ A = 1. + uSq/16384.*(4096.+uSq*(-768.+uSq*(320.-175.*uSq)));
+ B = uSq/1024. * (256.+uSq*(-128.+uSq*(74.-47.*uSq)));
+ deltaSigma = B*sinSigma*(cos2SigmaM+B/4.*(cosSigma*(-1.+2.*cos2SigmaM*cos2SigmaM)- B/6.*cos2SigmaM*(-3.+4.*sinSigma*sinSigma)*(-3.+4.*cos2SigmaM*cos2SigmaM)));
+ return b*A*(sigma-deltaSigma);
+ }
+ }
+}
+
+
+void distanceEllipsoid(int *n, double *lon1, double *lat1, double *lon2, double *lat2, double *a, double *b, double *f, int *m, double *dist) {
+ int i;
+ if (*m > 0) {
+ for(i=0; i < *n; i++) {
+ dist[i] = distVinEll(lon1[i], lat1[i], lon2[i], lat2[i], a[i], b[i], f[i]);
+ }
+ }
+}
+
diff --git a/src/dist_util.h b/src/dist_util.h
new file mode 100644
index 0000000..ab3f58c
--- /dev/null
+++ b/src/dist_util.h
@@ -0,0 +1,16 @@
+/* (Euclidian) distance on a plane */
+double distPlane(double x1, double y1, double x2, double y2) ;
+
+/* law of cosines distance */
+double distCos(double lon1, double lat1, double lon2, double lat2, double r) ;
+
+/* haversine distance */
+double distHav(double lon1, double lat1, double lon2, double lat2, double r);
+
+
+/* direction on a plane */
+double directionPlane(double x1, double y1, double x2, double y2, int degrees);
+
+/* direction on a sphere */
+double directionSphere(double lon1, double lat1, double lon2, double lat2, int degrees) ;
+
diff --git a/src/distance.c b/src/distance.c
new file mode 100644
index 0000000..8f49c2d
--- /dev/null
+++ b/src/distance.c
@@ -0,0 +1,58 @@
+/* Robert Hijmans, October 2011 */
+
+#include <Rinternals.h>
+#include "dist_util.h"
+#include "util.h"
+
+
+
+SEXP distanceToNearestPoint(SEXP d, SEXP p, SEXP geo) {
+
+ R_len_t i, j;
+ SEXP res;
+ double md, *xd, *xp, *xres;
+
+ SEXP dim1 = getAttrib(d, R_DimSymbol);
+ int n = INTEGER(dim1)[0];
+ SEXP dim2 = getAttrib(p, R_DimSymbol);
+ int m = INTEGER(dim2)[0];
+
+ PROTECT(d = coerceVector(d, REALSXP));
+ PROTECT(p = coerceVector(p, REALSXP));
+ int lonlat = INTEGER(geo)[0];
+
+ xd = REAL(d);
+ xp = REAL(p);
+
+ PROTECT( res = allocVector(REALSXP, n) );
+ xres = REAL(res);
+
+ double r = 6378137;
+
+ if (lonlat) {
+ for (i=0; i<n; i++) {
+ xres[i] = distCos(xd[i], xd[i+n], xp[0], xp[m], r);
+ for (j=1; j<m; j++) {
+ md = distCos(xd[i], xd[i+n], xp[j], xp[j+m], r);
+ if (md < xres[i]) {
+ xres[i] = md;
+ }
+ }
+ }
+ } else {
+ for (i=0; i<n; i++) {
+ xres[i] = distPlane(xd[i], xd[i+n], xp[0], xp[m]) ;
+ for (j=1; j<m; j++) {
+ md = distPlane(xd[i], xd[i+n], xp[j], xp[j+m]) ;
+ if (md < xres[i]) {
+ xres[i] = md;
+ }
+ }
+ }
+ }
+ UNPROTECT(3);
+ return(res) ;
+}
+
+
+
diff --git a/src/edge.c b/src/edge.c
new file mode 100644
index 0000000..786f28d
--- /dev/null
+++ b/src/edge.c
@@ -0,0 +1,100 @@
+/* Robert Hijmans, November 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+
+SEXP edge(SEXP d, SEXP dim, SEXP classes, SEXP type, SEXP directions) {
+
+ R_len_t i, j;
+ SEXP val;
+ int nrow, ncol, n, cell, k;
+ int *xd, *xval;
+
+ int class = INTEGER(classes)[0];
+ int edgetype = INTEGER(type)[0];
+ int dirs = INTEGER(directions)[0];
+ int falseval = 0;
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+ n = nrow * ncol;
+
+
+ PROTECT(d = coerceVector(d, INTSXP));
+ xd = INTEGER(d);
+
+ PROTECT( val = allocVector( INTSXP, n) );
+ xval = INTEGER(val);
+
+ int r[8] = { -1,0,0,1 , -1,-1,1,1};
+ int c[8] = { 0,-1,1,0 , -1,1,-1,1};
+
+ if (class == 0) {
+ if (edgetype == 0) { // inner
+ for (i = 1; i < (nrow-1); i++) {
+ for (j = 1; j < (ncol-1); j++) {
+ cell = i*ncol+j;
+ xval[cell] = R_NaInt;
+ if ( xd[cell] != R_NaInt ) {
+ xval[cell] = falseval;
+ for (k=0; k< dirs; k++) {
+ if ( xd[cell + r[k] * ncol + c[k]] == R_NaInt ) {
+ xval[cell] = 1;
+ break;
+ }
+ }
+ }
+ }
+ }
+
+ } else if (edgetype == 1) { //outer
+ for (i = 1; i < (nrow-1); i++) {
+ for (j = 1; j < (ncol-1); j++) {
+ cell = i*ncol+j;
+ xval[cell] = falseval;
+ if ( xd[cell] == R_NaInt ) {
+ xval[cell] = R_NaInt;
+ for (k=0; k < dirs; k++) {
+ if ( xd[cell+ r[k] * ncol + c[k] ] != R_NaInt ) {
+ xval[cell] = 1;
+ break;
+ }
+ }
+ }
+ }
+ }
+ }
+ } else { // by class
+ int test;
+ for (i = 1; i < (nrow-1); i++) {
+ for (j = 1; j < (ncol-1); j++) {
+ cell = i*ncol+j;
+ test = xd[ cell+r[0]*ncol+c[0] ];
+ if (test == R_NaInt) {
+ xval[cell] = R_NaInt;
+ } else {
+ xval[cell] = falseval;
+ }
+ for (k=1; k < dirs; k++) {
+ if (test != xd[ cell+r[k]*ncol +c[k] ]) {
+ xval[cell] = 1;
+ break;
+ }
+ }
+ }
+ }
+
+ }
+
+ UNPROTECT(2);
+ return(val);
+}
+
+
diff --git a/src/focal_fun.c b/src/focal_fun.c
new file mode 100644
index 0000000..4bd7555
--- /dev/null
+++ b/src/focal_fun.c
@@ -0,0 +1,124 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+SEXP focal_fun(SEXP d, SEXP w, SEXP dim, SEXP fun, SEXP NAonly, SEXP rho) {
+
+ R_len_t i, j, k, q;
+ SEXP R_fcall, ans, x;
+ int nrow, ncol, n, wn;
+ double *xd, *xans, *xw, *xx;
+
+ if(!isFunction(fun)) error("'fun' must be a function");
+ if(!isEnvironment(rho)) error("'rho' should be an environment");
+ PROTECT(R_fcall = lang2(fun, R_NilValue));
+
+ SEXP wdim = getAttrib(w, R_DimSymbol);
+ int wrows = INTEGER(wdim)[0];
+ int wcols = INTEGER(wdim)[1];
+ wn = wrows * wcols;
+ if(wn==0) error("'w' has zero dimension(s)");
+
+ PROTECT(d = coerceVector(d, REALSXP));
+ PROTECT(w = coerceVector(w, REALSXP));
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+ int naonly = INTEGER(NAonly)[0];
+
+ n = nrow * ncol;
+ PROTECT( ans = allocVector(REALSXP, n) );
+ PROTECT(x = allocVector(REALSXP, wn));
+ xx = REAL(x);
+
+ if ((wrows % 2 == 0) | (wcols % 2 == 0))
+ error("weights matrix must have uneven sides");
+ int wr = floor(wrows / 2);
+ int wc = floor(wcols / 2);
+
+ xd = REAL(d);
+ xans = REAL(ans);
+ xw = REAL(w);
+
+ int nwc = ncol - wc - 1;
+ int col = 0;
+
+ if (naonly) {
+ // first rows
+ for (i = 0; i < ncol*wr; i++) {
+ xans[i] = xd[i];
+ }
+ for (i = ncol*wr; i < ncol * (nrow-wr); i++) {
+ if (!R_IsNA(xd[i])) {
+ xans[i] = xd[i];
+ } else {
+ col = i % ncol;
+ if ((col < wc) | (col > nwc)) {
+ xans[i] = xd[i];
+ } else {
+ q = 0;
+ for (j = -wr; j <= wr; j++) {
+ for (k = -wc; k <= wc; k++) {
+ xx[q] = xd[j * ncol + k + i] * xw[q];
+ q++;
+ }
+ }
+ SETCADR(R_fcall, x);
+ xans[i] = REAL(eval(R_fcall, rho))[0];
+
+ if (R_IsNaN(xans[i])) {
+ xans[i] = R_NaReal;
+ }
+
+ }
+ }
+ }
+ // last rows
+ for (i = ncol * (nrow-wr); i < n; i++) {
+ xans[i] = xd[i];
+ }
+
+ } else {
+
+ // first rows
+ for (i = 0; i < ncol*wr; i++) {
+ xans[i] = R_NaReal;
+ }
+
+ for (i = ncol*wr; i < (ncol * (nrow-wr)); i++) {
+ col = i % ncol;
+ if ((col < wc) | (col > nwc)) {
+ xans[i] = R_NaReal;
+ } else {
+ q = 0;
+ for (j = -wr; j <= wr; j++) {
+ for (k = -wc; k <= wc; k++) {
+ xx[q] = xd[j * ncol + k + i] * xw[q];
+ q++;
+ }
+ }
+ SETCADR(R_fcall, x);
+ xans[i] = REAL(eval(R_fcall, rho))[0];
+ if (R_IsNaN(xans[i])) {
+ xans[i] = R_NaReal;
+ }
+
+ }
+ }
+ // last rows
+ for (i = ncol * (nrow-wr); i < n; i++) {
+ xans[i] = R_NaReal;
+ }
+ }
+
+ UNPROTECT(5);
+ return(ans);
+}
+
diff --git a/src/focal_get.c b/src/focal_get.c
new file mode 100644
index 0000000..bbbd1c8
--- /dev/null
+++ b/src/focal_get.c
@@ -0,0 +1,61 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+
+SEXP focal_get(SEXP d, SEXP dim, SEXP ngb) {
+
+ R_len_t i, j;
+ int a, aa, b;
+
+ SEXP val;
+ int nrow, ncol, n;
+ double *xd, *xval;
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+
+ int wrows = INTEGER(ngb)[0];
+ int wcols = INTEGER(ngb)[1];
+
+ if ((wrows % 2 == 0) | (wcols % 2 == 0))
+ error("weights matrix must have uneven sides");
+
+ PROTECT(d = coerceVector(d, REALSXP));
+
+ n = (nrow-wrows+1) * (ncol-wcols+1) * wrows * wcols;
+ PROTECT( val = allocVector(REALSXP, n) );
+
+ int wr = floor(wrows / 2);
+ int wc = floor(wcols / 2);
+
+ xd = REAL(d);
+ xval = REAL(val);
+
+ int f = 0;
+
+ for (i = 0+wr; i < nrow-wr; i++) {
+ for (j = 0+wc; j < ncol-wc; j++) {
+ for (a=-wr; a <= wr ; a++) {
+ aa = (i+a) * ncol;
+ for (b=-wc; b <= wc ; b++) {
+ xval[f] = xd[aa+j+b];
+ f++;
+ }
+ }
+ }
+ }
+
+ UNPROTECT(2);
+ return(val);
+}
+
+
+
diff --git a/src/focal_sum.c b/src/focal_sum.c
new file mode 100644
index 0000000..3a66b5b
--- /dev/null
+++ b/src/focal_sum.c
@@ -0,0 +1,169 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <Rmath.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+
+SEXP focal_sum(SEXP d, SEXP w, SEXP dim, SEXP rmNA, SEXP NAonly, SEXP domean) {
+
+ R_len_t i, j, k, q, p;
+ SEXP val;
+ int nrow, ncol, n, bemean;
+ double *xd, *xval, *xw, a;
+
+
+ SEXP wdim = getAttrib(w, R_DimSymbol);
+
+ if (isNull(wdim))
+ error("wdim is null");
+
+ int wrows = INTEGER(wdim)[0];
+ int wcols = INTEGER(wdim)[1];
+ PROTECT(w = coerceVector(w, REALSXP));
+
+ if ((wrows % 2 == 0) | (wcols % 2 == 0))
+ error("weights matrix must have uneven sides");
+
+ int narm = INTEGER(rmNA)[0];
+ int naonly = INTEGER(NAonly)[0];
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+ bemean = INTEGER(domean)[0];
+ n = nrow * ncol;
+ PROTECT( val = allocVector(REALSXP, n) );
+ PROTECT(d = coerceVector(d, REALSXP));
+
+ int wr = floor(wrows / 2);
+ int wc = floor(wcols / 2);
+
+ xd = REAL(d);
+ xval = REAL(val);
+ xw = REAL(w);
+
+ int nwc = ncol - wc - 1;
+ int col = 0;
+
+ if (narm) {
+ if (naonly) {
+ // first rows
+ for (i = 0; i < ncol*wr; i++) {
+ xval[i] = xd[i];
+ }
+
+ for (i = ncol*wr; i < ncol*(nrow-wr); i++) {
+ if (! R_IsNA(xd[i])) {
+ xval[i] = xd[i];
+ } else {
+ col = i % ncol;
+ if ((col < wc) | (col > nwc)) {
+ xval[i] = xd[i];
+ } else {
+ xval[i] = 0;
+ q = 0;
+ p = 0;
+ for (j = -wr; j <= wr; j++) {
+ for (k = -wc; k <= wc; k++) {
+ a = xd[j * ncol + k + i];
+ if ( !R_IsNA(a) ) {
+ xval[i] += a * xw[q];
+ p++;
+ }
+ q++;
+ }
+ }
+ if (p==0) {
+ xval[i] = R_NaReal;
+ } else if (bemean) {
+ xval[i] = xval[i] / p;
+ }
+ }
+ }
+ }
+
+ // last rows
+ for (i = ncol * (nrow-wr); i < n; i++) {
+ xval[i] = xd[i];
+ }
+
+ } else {
+
+ // first rows
+ for (i = 0; i < ncol*wr; i++) {
+ xval[i] = R_NaReal;
+ }
+
+ for (i = ncol*wr; i < ncol * (nrow-wr); i++) {
+ col = i % ncol;
+ if ((col < wc) | (col > nwc)) {
+ xval[i] = R_NaReal;
+ } else {
+ q = 0;
+ p = 0;
+ xval[i] = 0;
+ for (j = -wr; j <= wr; j++) {
+ for (k = -wc; k <= wc; k++) {
+ a = xd[j * ncol + k + i];
+ if ( !R_IsNA(a) ) {
+ xval[i] += a * xw[q];
+ p++;
+ }
+ q++;
+ }
+ }
+ if (p==0) {
+ xval[i] = R_NaReal;
+ } else if (bemean) {
+ xval[i] = xval[i] / p;
+ }
+ }
+ }
+
+ // last rows
+ for (i = ncol * (nrow-wr); i < n; i++) {
+ xval[i] = R_NaReal;
+ }
+ }
+ } else {
+
+ // first rows
+ for (i = 0; i < ncol*wr; i++) {
+ xval[i] = R_NaReal;
+ }
+ for (i = ncol*wr; i < ncol * (nrow-wr); i++) {
+ col = i % ncol;
+ if ((col < wc) | (col > nwc)) {
+ xval[i] = R_NaReal;
+ } else {
+ xval[i] = 0;
+ q = 0;
+ for (j = -wr; j <= wr; j++) {
+ for (k = -wc; k <= wc; k++) {
+ xval[i] += xd[j * ncol + k + i] * xw[q];
+ q++;
+ }
+ }
+
+ if (bemean) {
+ xval[i] = xval[i] / q;
+ }
+ }
+ }
+ // last rows
+ for (i = ncol * (nrow-wr); i < n; i++) {
+ xval[i] = R_NaReal;
+ }
+ }
+
+ UNPROTECT(3);
+ return(val);
+}
+
+
+
diff --git a/src/geodesic.c b/src/geodesic.c
new file mode 100644
index 0000000..dd88662
--- /dev/null
+++ b/src/geodesic.c
@@ -0,0 +1,1781 @@
+/**
+ * \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 <b>87</b>, 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) <charles at karney.com> and licensed
+ * under the MIT/X11 License. For more information, see
+ * http://geographiclib.sourceforge.net/
+ */
+
+#include "geodesic.h"
+#include <math.h>
+
+#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 */
diff --git a/src/geodesic.h b/src/geodesic.h
new file mode 100644
index 0000000..2be5aec
--- /dev/null
+++ b/src/geodesic.h
@@ -0,0 +1,804 @@
+/**
+ * \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,
+ * <a href="https://dx.doi.org/10.1007/s00190-012-0578-z">
+ * Algorithms for geodesics</a>,
+ * J. Geodesy <b>87</b>, 43--55 (2013);
+ * DOI: <a href="https://dx.doi.org/10.1007/s00190-012-0578-z">
+ * 10.1007/s00190-012-0578-z</a>;
+ * addenda: <a href="http://geographiclib.sf.net/geod-addenda.html">
+ * geod-addenda.html</a>.
+ * .
+ * The principal advantages of these algorithms over previous ones (e.g.,
+ * Vincenty, 1975) are
+ * - accurate to round off for |<i>f</i>| < 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 |<i>f</i>| < 1/50; for the
+ * WGS84 ellipsoid, the errors are less than 15 nanometers. (Reasonably
+ * accurate results are obtained for |<i>f</i>| < 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 <a href="http://geographiclib.sf.net"> GeographicLib</a>. 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) <charles at karney.com> and licensed
+ * under the MIT/X11 License. For more information, see
+ * http://geographiclib.sourceforge.net/
+ *
+ * This library was distributed with
+ * <a href="../index.html">GeographicLib</a> 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
+ * (meters<sup>2</sup>).
+ * @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
+ * (meters<sup>2</sup>).
+ * @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
+ * (meters<sup>2</sup>); 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 (meters<sup>2</sup>);
+ * 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 (meters<sup>2</sup>);
+ * 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 (meters<sup>2</sup>);
+ * 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 (meters<sup>2</sup>).
+ * @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
diff --git a/src/geolib.c b/src/geolib.c
new file mode 100644
index 0000000..86a6997
--- /dev/null
+++ b/src/geolib.c
@@ -0,0 +1,72 @@
+#include "geodesic.h"
+#include <Rinternals.h>
+
+/* Robert Hijmans, May 2015 */
+
+SEXP inversegeodesic(SEXP longitude1, SEXP latitude1, SEXP longitude2, SEXP latitude2, SEXP pa, SEXP pf) {
+
+ PROTECT(latitude1 = coerceVector(latitude1, REALSXP));
+ PROTECT(longitude1 = coerceVector(longitude1, REALSXP));
+ PROTECT(latitude2 = coerceVector(latitude2, REALSXP));
+ PROTECT(longitude2 = coerceVector(longitude2, REALSXP));
+ double a = REAL(pa)[0];
+ double f = REAL(pf)[0];
+
+ double *lat1, *lon1, *lat2, *lon2, *xr;
+ lat1 = REAL(latitude1);
+ lon1 = REAL(longitude1);
+ lat2 = REAL(latitude2);
+ lon2 = REAL(longitude2);
+
+ SEXP r;
+ PROTECT( r = allocVector(REALSXP, length(latitude1) ));
+ xr = REAL(r);
+
+ double azi1, azi2, s12;
+ struct geod_geodesic g;
+
+ geod_init(&g, a, f);
+
+ for (int i=0; i < length(latitude1); i++) {
+ geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &s12, &azi1, &azi2);
+ xr[i] = s12;
+ }
+
+ UNPROTECT(5);
+ return r;
+}
+
+
+SEXP polygonarea(SEXP longitude, SEXP latitude, SEXP pa, SEXP pf) {
+
+ PROTECT(latitude = coerceVector(latitude, REALSXP));
+ PROTECT(longitude = coerceVector(longitude, REALSXP));
+ double *lat, *lon, *xr;
+ lat = REAL(latitude);
+ lon = REAL(longitude);
+
+ double a = REAL(pa)[0];
+ double f = REAL(pf)[0];
+
+ double A, P;
+ int i;
+ struct geod_geodesic g;
+ struct geod_polygon p;
+
+ geod_init(&g, a, f);
+ geod_polygon_init(&p, 0);
+
+ for (i=0; i<length(latitude); i++) {
+ geod_polygon_addpoint(&g, &p, lat[i], lon[i]);
+ }
+
+ geod_polygon_compute(&g, &p, 0, 1, &A, &P);
+
+ SEXP r;
+ PROTECT( r = allocVector(REALSXP, 1) );
+ xr = REAL(r);
+ xr[0] = A;
+
+ UNPROTECT(3);
+ return(r);
+}
diff --git a/src/getPolygons.cpp b/src/getPolygons.cpp
new file mode 100644
index 0000000..c8635a4
--- /dev/null
+++ b/src/getPolygons.cpp
@@ -0,0 +1,94 @@
+#include <Rcpp.h>
+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;
+
+ }
+}
diff --git a/src/intersect.c b/src/intersect.c
new file mode 100644
index 0000000..4f3738a
--- /dev/null
+++ b/src/intersect.c
@@ -0,0 +1,66 @@
+#include <R.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rmath.h"
+
+
+/*
+By Paul Bourke
+http://paulbourke.net/geometry/lineline2d/
+Determine the intersection point of two line segments
+*/
+
+int intersectSegments( double x1, double y1, double x2, double y2, double x3, double y3, double x4, double y4,
+ double *xa, double *ya, double *xb, double *yb) {
+ double mua,mub;
+ double denom,numera,numerb;
+ double EPS = 0.000000001;
+
+ *xa = 0;
+ *ya = 0;
+ *xb = 0;
+ *yb = 0;
+
+ denom = (y4-y3) * (x2-x1) - (x4-x3) * (y2-y1);
+ numera = (x4-x3) * (y1-y3) - (y4-y3) * (x1-x3);
+ numerb = (x2-x1) * (y1-y3) - (y2-y1) * (x1-x3);
+
+ /* Are the line coincident? */
+ if (fabs(numera) < EPS && fabs(numerb) < EPS && fabs(denom) < EPS) {
+ // changes by RH
+ // return two points if lines coincide.
+ if (x1 > x3) {
+ *xa = x1;
+ *ya = y1;
+ } else {
+ *xa = x3;
+ *ya = y3;
+ }
+ if (x2 > x4) {
+ *xb = x2;
+ *yb = y2;
+ } else {
+ *xb = x4;
+ *yb = y4;
+ }
+ return(2);
+ }
+
+ /* Are the line parallel */
+ if (fabs(denom) < EPS) {
+ return(0);
+ }
+
+ /* Is the intersection along the the segments */
+ mua = numera / denom;
+ mub = numerb / denom;
+ if (mua < 0 || mua > 1 || mub < 0 || mub > 1) {
+ return(0);
+ }
+
+ *xa = x1 + mua * (x2 - x1);
+ *ya = y1 + mua * (y2 - y1);
+ return(1);
+}
+
diff --git a/src/intersect.h b/src/intersect.h
new file mode 100644
index 0000000..0d0b89e
--- /dev/null
+++ b/src/intersect.h
@@ -0,0 +1 @@
+int intersectSegments( double x1, double y1, double x2, double y2, double x3, double y3, double x4, double y4, double *x, double *y, double *xa, double *ya);
diff --git a/src/layerize.c b/src/layerize.c
new file mode 100644
index 0000000..e7218fd
--- /dev/null
+++ b/src/layerize.c
@@ -0,0 +1,56 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+
+
+SEXP layerize(SEXP d, SEXP cls, SEXP falsena) {
+
+ R_len_t i, j;
+ int *xd, *xc, *xv, vna;
+ SEXP v;
+
+ PROTECT(d = coerceVector(d, INTSXP));
+ PROTECT(cls = coerceVector(cls, INTSXP));
+ int fna = INTEGER(falsena)[0];
+
+ xd = INTEGER(d);
+ xc = INTEGER(cls);
+
+ PROTECT( v = allocVector(INTSXP, length(d) * length(cls)) );
+ xv = INTEGER(v);
+
+ if (fna) {
+ vna = R_NaInt;
+ } else {
+ vna = 0;
+ }
+ for (i=0; i<length(v); i++) {
+ xv[i] = vna;
+ }
+
+ int m = length(d);
+ int n = length(cls);
+
+ for (i=0; i<length(d); i++) {
+ if (xd[i] != R_NaInt) {
+ for (j=0; j<n; j++) {
+ if (xd[i] == xc[j]) {
+ xv[j * m + i] = 1;
+ break;
+ }
+ }
+ } else {
+ for (j=0; j<n; j++) {
+ xv[j * m + i] = R_NaInt;
+ }
+ }
+ }
+ UNPROTECT(3);
+ return(v);
+}
+
diff --git a/src/modal.cpp b/src/modal.cpp
new file mode 100644
index 0000000..ad62dcc
--- /dev/null
+++ b/src/modal.cpp
@@ -0,0 +1,79 @@
+#include <Rcpp.h>
+using namespace Rcpp;
+
+// [[Rcpp::export(name = ".getMode")]]
+double getMode(NumericVector values, int ties) {
+ int n = values.length();
+ IntegerVector counts(n);
+
+ if (ties < 3) {
+ 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];
+}
+
diff --git a/src/pointinpoly.c b/src/pointinpoly.c
new file mode 100644
index 0000000..8a293d4
--- /dev/null
+++ b/src/pointinpoly.c
@@ -0,0 +1,300 @@
+// Derived from code in the sp package by Pebesma, Bivand, and others
+// Robert Hijmans, October 2011
+
+#define USING_R 1
+#include "R.h"
+
+#ifdef USING_R
+# include <R.h>
+# include <Rdefines.h>
+/* # include <Rinternals.h> */
+# define R_UNIFORM unif_rand()
+# define R_NORMAL norm_rand()
+# define RANDIN seed_in((long *) NULL)
+# define RANDOUT seed_out((long *) NULL)
+# define S_EVALUATOR
+#endif
+
+
+#ifndef MIN
+# define MIN(a,b) ((a)>(b)?(b):(a))
+#endif
+#ifndef MAX
+# define MAX(a,b) ((a)>(b)?(a):(b))
+#endif
+
+
+/* polygon structs: */
+typedef struct {
+ double x, y;
+} PLOT_POINT;
+
+typedef struct {
+ PLOT_POINT min, max;
+} MBR;
+
+typedef struct polygon {
+ MBR mbr;
+ int lines;
+ PLOT_POINT *p;
+ int close; /* 1 - is closed polygon */
+} POLYGON;
+
+
+/*
+This code is described in "Computational Geometry in C" (Second Edition),
+Chapter 7. It is not written to be comprehensible without the
+explanation in that book.
+
+For each query point q, InPoly returns one of four char's:
+ i : q is strictly interior to P
+ o : q is strictly exterior to P
+ v : q is a vertex of P
+ e : q lies on the relative interior of an edge of P
+These represent mutually exclusive categories.
+For an explanation of the code, see Chapter 7 of
+"Computational Geometry in C (Second Edition)."
+
+Written by Joseph O'Rourke, contributions by Min Xu, June 1997.
+Questions to orourke at cs.smith.edu.
+--------------------------------------------------------------------
+This code is Copyright 1998 by Joseph O'Rourke. It may be freely
+redistributed in its entirety provided that this copyright notice is
+not removed.
+--------------------------------------------------------------------
+*/
+
+/*
+InPoly returns a char in {i,o,v,e}. See above for definitions.
+changed to 1 or 0 by RH
+*/
+
+int InPoly(PLOT_POINT q, POLYGON *Poly)
+{
+ int n = Poly->lines;
+ PLOT_POINT *P=Poly->p;
+
+ int i, i1; /* point index; i1 = i-1 mod n */
+ double x; /* x intersection of e with ray */
+ double xx=q.x, yy=q.y;
+ int Rcross = 0; /* number of right edge/ray crossings */
+ int Lcross = 0; /* number of left edge/ray crossings */
+
+ /* For each edge e=(i-1,i), see if crosses ray. */
+ for( i = 0; i < n; i++ ) {
+ /* First see if q=(0,0) is a vertex. */
+ if (( P[i].x - xx )==0 &&( P[i].y - yy )==0 ) return 1;
+ i1 = ( i + n - 1 ) % n;
+ /* printf("e=(%d,%d)\t", i1, i); */
+
+ /* if e "straddles" the x-axis... */
+ /* The commented-out statement is logically equivalent to the one
+ following. */
+ /* if( ( ( P[i].y > 0 ) && ( P[i1].y <= 0 ) ) ||
+ ( ( P[i1].y > 0 ) && ( P[i] .y <= 0 ) ) ) { }*/
+
+ if( (( P[i].y - yy ) > 0 ) != (( P[i1].y - yy ) > 0 ) ) {
+
+ /* e straddles ray, so compute intersection with ray. */
+ x = (( P[i].x - xx) *( P[i1].y - yy ) -( P[i1].x - xx ) *( P[i].y - yy )) /
+ (P[i1].y - P[i].y );
+ /* printf("straddles: x = %g\t", x); */
+
+ /* crosses ray if strictly positive intersection. */
+ if (x > 0) Rcross++;
+ }
+ /* printf("Right cross=%d\t", Rcross); */
+
+ /* if e straddles the x-axis when reversed... */
+ /* if( ( ( P[i] .y < 0 ) && ( P[i1].y >= 0 ) ) ||
+ ( ( P[i1].y < 0 ) && ( P[i] .y >= 0 ) ) ) { }*/
+
+ if ( (( P[i].y - yy ) < 0 ) != (( P[i1].y - yy ) < 0 ) ) {
+
+ /* e straddles ray, so compute intersection with ray. */
+ x = (( P[i].x - xx) *( P[i1].y - yy ) -( P[i1].x - xx ) *( P[i].y - yy )) /
+ (P[i1].y - P[i].y);
+ /* printf("straddles: x = %g\t", x); */
+
+ /* crosses ray if strictly positive intersection. */
+ if (x < 0) Lcross++;
+ }
+ /* printf("Left cross=%d\n", Lcross); */
+ }
+
+ /* q on the edge if left and right cross are not the same parity. */
+ if( ( Rcross % 2 ) != (Lcross % 2 ) )
+ return 1;
+
+ /* q inside iff an odd number of crossings. */
+ if( (Rcross % 2) == 1 )
+ return 1;
+ else
+ return 0;
+}
+
+
+
+void setup_poly_minmax(POLYGON *pl) {
+ int i, n=pl->lines;
+ double minx,maxx,miny,maxy;
+
+ minx=miny=DBL_MAX;
+ maxx=maxy=-DBL_MAX;
+
+ for (i=0;i<n;i++) {
+ minx = MIN(minx, pl->p[i].x);
+ miny = MIN(miny, pl->p[i].y);
+ maxx = MAX(maxx, pl->p[i].x);
+ maxy = MAX(maxy, pl->p[i].y);
+ }
+ pl->mbr.min.x = minx;
+ pl->mbr.min.y = miny;
+ pl->mbr.max.x = maxx;
+ pl->mbr.max.y = maxy;
+}
+
+
+
+SEXP point_in_polygon(SEXP px, SEXP py, SEXP polx, SEXP poly) {
+ int i;
+ PLOT_POINT p;
+ POLYGON pol;
+ SEXP ret;
+
+ S_EVALUATOR
+ pol.lines = LENGTH(polx); /* check later that first == last */
+ pol.p = (PLOT_POINT *) Calloc(pol.lines, PLOT_POINT); /* Calloc does error handling */
+ for (i = 0; i < LENGTH(polx); i++) {
+ pol.p[i].x = NUMERIC_POINTER(polx)[i];
+ pol.p[i].y = NUMERIC_POINTER(poly)[i];
+ }
+ pol.close = (pol.p[0].x == pol.p[pol.lines - 1].x &&
+ pol.p[0].y == pol.p[pol.lines - 1].y);
+ setup_poly_minmax(&pol);
+
+ PROTECT(ret = NEW_INTEGER(LENGTH(px)));
+ for (i = 0; i < LENGTH(px); i++) {
+ p.x = NUMERIC_POINTER(px)[i];
+ p.y = NUMERIC_POINTER(py)[i];
+ if ((p.x > pol.mbr.min.x) & (p.x <= pol.mbr.max.y) & (p.y > pol.mbr.min.y) & (p.y <= pol.mbr.max.y)) {
+ INTEGER_POINTER(ret)[i] = InPoly(p, &pol);
+ } else {
+ INTEGER_POINTER(ret)[i] = 0;
+ }
+ }
+ Free(pol.p);
+ UNPROTECT(1);
+ return(ret);
+}
+
+
+
+SEXP point_in_polygon2(SEXP px, SEXP py, SEXP polx, SEXP poly, SEXP id, SEXP holes) {
+ int i, j;
+ PLOT_POINT p;
+ POLYGON pol;
+ SEXP ret, polxx, polyy;
+ int isHole, nHoles, lastPart;
+ int *hole, *tmp;
+
+
+ PROTECT(px);
+ PROTECT(py);
+ PROTECT(id = coerceVector(id, INTSXP));
+ PROTECT(holes = coerceVector(holes, INTSXP));
+ PROTECT(polx = coerceVector(polx, VECSXP));
+ PROTECT(poly = coerceVector(poly, VECSXP));
+
+ PROTECT(ret = NEW_INTEGER(LENGTH(px)));
+ tmp = (int *) malloc(LENGTH(px)*sizeof(double));
+ hole = (int *) malloc(LENGTH(px)*sizeof(int));
+
+ for (i = 0; i < LENGTH(ret); i++) {
+ INTEGER_POINTER(ret)[i] = R_NaInt;
+ hole[i] = 0;
+ tmp[i] = R_NaInt;
+ }
+
+ lastPart = 0;
+ nHoles = 0;
+ int oldid = INTEGER_POINTER(id)[0];
+
+ int n = LENGTH(polx);
+ for (i = 0; i < n; i++) {
+ if (i == (n-1) ) {
+ lastPart = 1;
+ } else if ((INTEGER_POINTER(id)[i+1]) != oldid) {
+ lastPart = 1;
+ oldid = INTEGER_POINTER(id)[i+1];
+ }
+ if (INTEGER_POINTER(holes)[i]) {
+ isHole = 1;
+ nHoles++;
+ } else {
+ isHole = 0;
+ }
+
+ polxx = VECTOR_ELT(polx, i);
+ polyy = VECTOR_ELT(poly, i);
+ pol.lines = LENGTH(polxx); /* check later that first == last */
+
+ pol.p = (PLOT_POINT *) Calloc(pol.lines, PLOT_POINT); /* Calloc does error handling */
+ for (j = 0; j < LENGTH(polxx); j++) {
+ pol.p[j].x = NUMERIC_POINTER(polxx)[j];
+ pol.p[j].y = NUMERIC_POINTER(polyy)[j];
+ }
+ pol.close = (pol.p[0].x == pol.p[pol.lines - 1].x && pol.p[0].y == pol.p[pol.lines - 1].y);
+ // call error if pol.close = FALSE ?
+
+ setup_poly_minmax(&pol);
+
+ if (isHole) {
+ for (j = 0; j < LENGTH(px); j++) {
+ p.x = NUMERIC_POINTER(px)[j];
+ p.y = NUMERIC_POINTER(py)[j];
+ if ((p.x > pol.mbr.min.x) & (p.x <= pol.mbr.max.x) & (p.y > pol.mbr.min.y) & (p.y <= pol.mbr.max.y)) {
+ if (InPoly(p, &pol)) {
+ hole[j] = 1;
+ }
+ }
+ }
+ } else {
+ for (j = 0; j < LENGTH(px); j++) {
+ p.x = NUMERIC_POINTER(px)[j];
+ p.y = NUMERIC_POINTER(py)[j];
+ if ((p.x > pol.mbr.min.x) & (p.x <= pol.mbr.max.x) & (p.y > pol.mbr.min.y) & (p.y <= pol.mbr.max.y)) {
+ if (InPoly(p, &pol)) {
+ tmp[j] = INTEGER_POINTER(id)[i];
+ }
+ }
+ }
+ }
+ Free(pol.p);
+ if (lastPart) {
+ lastPart = 0;
+ if (nHoles > 0) {
+ nHoles = 0;
+ for (j = 0; j < LENGTH(px); j++) {
+ if ((tmp[j] != NA_INTEGER ) & (! hole[j])) {
+ // Rprintf ("%s \n", "a");
+ INTEGER_POINTER(ret)[j] = tmp[j];
+ }
+ tmp[j] = R_NaInt;
+ hole[j] = 0;
+ }
+ } else {
+ for (j = 0; j < LENGTH(px); j++) {
+ if (NA_INTEGER != tmp[j]) {
+ INTEGER_POINTER(ret)[j] = tmp[j];
+ tmp[i] = R_NaInt;
+ }
+ }
+ }
+ }
+
+ }
+
+ UNPROTECT(7);
+ return(ret);
+}
diff --git a/src/ppmin.cpp b/src/ppmin.cpp
new file mode 100644
index 0000000..900823a
--- /dev/null
+++ b/src/ppmin.cpp
@@ -0,0 +1,158 @@
+#include <Rcpp.h>
+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;
+}
+
diff --git a/src/reclass.c b/src/reclass.c
new file mode 100644
index 0000000..5cbe750
--- /dev/null
+++ b/src/reclass.c
@@ -0,0 +1,192 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+#include "Rmath.h"
+#include "util.h"
+
+
+SEXP reclass(SEXP d, SEXP r, SEXP low, SEXP right, SEXP onlyNA, SEXP valNA) {
+
+ R_len_t i, j;
+ SEXP val;
+ double *xd, *rcl, *xval, lowval, lowres;
+
+ PROTECT(d = coerceVector(d, REALSXP));
+
+ SEXP rdim = getAttrib(r, R_DimSymbol);
+ int a = INTEGER(rdim)[0];
+ int nc = INTEGER(rdim)[1];
+ int b = a * 2;
+
+ PROTECT(r = coerceVector(r, REALSXP));
+ rcl = REAL(r);
+ xd = REAL(d);
+
+ int doright = INTEGER(right)[0];
+ int doleftright = 0;
+ if (doright == R_NaInt) {
+ doleftright = 1;
+ }
+ int dolowest = INTEGER(low)[0];
+ int NAonly = INTEGER(onlyNA)[0];
+ double NAval = REAL(valNA)[0];
+
+ int n = length(d);
+
+ PROTECT( val = allocVector(REALSXP, n) );
+ xval = REAL(val);
+
+
+ if (NAonly) { // only change NA values
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else {
+ xval[i] = xd[i];
+ }
+ }
+
+ } else { // "is - becomes" reclassification
+
+ if (nc == 2) {
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else {
+ xval[i] = xd[i];
+ for (j=0; j<a; j++) {
+ if (xd[i] == rcl[j]) {
+ xval[i] = rcl[j+a];
+ break;
+ }
+ }
+ }
+ }
+
+ // "from - to - becomes" reclassification
+ } else if (doleftright) { // interval closed at left and right
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else {
+ xval[i] = xd[i];
+ for (j=0; j<a; j++) {
+ if ((xd[i] >= rcl[j]) & (xd[i] <= rcl[j+a])) {
+ xval[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 (j=1; j<a; j++) {
+ if (rcl[j] < lowval) {
+ lowval = rcl[j];
+ lowres = rcl[b+j];
+ }
+ }
+
+// Rprintf ("lowval = %f \n", lowval);
+// Rprintf ("lowres = %f \n", lowres);
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else if (xd[i] == lowval) {
+ xval[i] = lowres;
+ } else {
+ xval[i] = xd[i];
+ for (j=0; j<a; j++) {
+ if ((xd[i] > rcl[j]) & (xd[i] <= rcl[j+a])) {
+ xval[i] = rcl[j+b];
+ break;
+ }
+ }
+ }
+ }
+
+ } else { // !dolowest
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else {
+ xval[i] = xd[i];
+ for (j=0; j<a; j++) {
+ if ((xd[i] > rcl[j]) & (xd[i] <= rcl[j+a])) {
+ xval[i] = rcl[j+b];
+ break;
+ }
+ }
+ }
+ }
+ }
+
+ } else { // !doright
+
+ if (dolowest) { // which here means highest because right=FALSE
+
+ lowval = rcl[a];
+ lowres = rcl[b];
+ for (j=a+1; j<b; j++) {
+ if (rcl[j] > lowval) {
+ lowval = rcl[j];
+ lowres = rcl[a+j];
+ }
+ }
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else if (xd[i] == lowval) {
+ xval[i] = lowres;
+ } else {
+ xval[i] = xd[i];
+ for (j=0; j<a; j++) {
+ if ((xd[i] >= rcl[j]) & (xd[i] < rcl[j+a])) {
+ xval[i] = rcl[j+b];
+ break;
+ }
+ }
+ }
+ }
+
+ } else { //!dolowest
+
+ for (i=0; i<n; i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i] = NAval;
+ } else {
+ xval[i] = xd[i];
+ for (j=0; j<a; j++) {
+ if ((xd[i] >= rcl[j]) & (xd[i] < rcl[j+a])) {
+ xval[i] = rcl[j+b];
+ break;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+
+ UNPROTECT(3);
+ return(val);
+}
+
+
diff --git a/src/solar.c b/src/solar.c
new file mode 100644
index 0000000..c93a04f
--- /dev/null
+++ b/src/solar.c
@@ -0,0 +1,156 @@
+/* Robert Hijmans, October 2011
+
+Solar radiation according to:
+ Kumar, L., Skidmore, A.K., Knowles, E., 1997.
+ Modelling Topographic Variation in Solar Radiation in a GIS Environment.
+ International Journal of Geographical Information Science, 11: 475-497.
+
+ Based on Matlab code by Felix Hebeler, Dept. of Geography, University Zurich, May 2008.
+ And AML code by Niklaus E. Zimmermann, Swiss Federal Research Institute WSL
+*/
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+#include "Rmath.h"
+
+
+SEXP solradiat(SEXP elev, SEXP s, SEXP a, SEXP lat, SEXP ref, SEXP days, SEXP dim) {
+
+ R_len_t i, j, h;
+ SEXP rad;
+ double *slope, *aspect, *srad, *latitude, r;
+ int *day;
+ int nrow, ncol, n, nd, d;
+ double L, sinL, cosL, tanL, sinSlop, sinSlop2, cosSlop, cosSlop2, sinAsp, cosAsp, term1, term2, term3;
+ double hsr, It, I, hs, sinAlpha, M, tau_b, tau_r, tau_d, Id, Ir, cos_i, R, Is;
+ double dr = M_PI / 180 ; // degree to radians conversion factor
+
+ PROTECT(elev = coerceVector(elev, REALSXP)); // currently not used, but should be used.
+ PROTECT(s = coerceVector(s, REALSXP));
+ PROTECT(a = coerceVector(a, REALSXP));
+ PROTECT(lat = coerceVector(lat, REALSXP));
+ PROTECT(days = coerceVector(days, INTSXP));
+
+ r = REAL(ref)[0];
+ if ((r > 1) | (r <= 0) ) error("reflection should be between 0 and 1");
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+ n = nrow * ncol;
+ Rprintf(" n: %d \n", n);
+
+ //dem = REAL(elev);
+ slope = REAL(s);
+ aspect = REAL(a);
+ latitude = REAL(lat);
+
+ nd = length(days);
+ day = INTEGER(days);
+ PROTECT( rad = allocVector(REALSXP, n*nd) );
+ srad = REAL(rad);
+
+
+ double S0 = 1367; // solar constant W m^-2 default 1367
+ double I0[365], dS[365];
+
+ for (i=0; i<365; i++) {
+ // extraterrestrial solar radiation
+ I0[i] = S0 * (1 + 0.0344 * cos(M_2PI * (i+1) / 365.));
+ // sun declination
+ dS[i] = 23.45 * dr * sin(M_2PI * ( (284 + i + 1) / 365. ));
+ }
+
+ int row = -1;
+ L = 0;
+ tanL = 0;
+ cosL = 0;
+ sinL = 0;
+// loop over cells
+ for (i=0; i<n; i++) {
+
+ if (i % ncol == 0) {
+ row++;
+ L = latitude[row];
+ L = L * dr;
+ sinL = sin(L);
+ cosL = cos(L);
+ tanL = tan(L);
+ }
+
+ if (slope[i] == R_NaReal) {
+ srad[i] = R_NaReal;
+ continue;
+ }
+
+ sinSlop = sin(slope[i]);
+ cosSlop = cos(slope[i]);
+ cosSlop2 = cosSlop * cosSlop;
+ sinSlop2 = sinSlop * sinSlop;
+ sinAsp = sin(aspect[i]);
+ cosAsp = cos(aspect[i]);
+ term1 = ( sinL * cosSlop - cosL * sinSlop * cosAsp );
+ term2 = ( cosL * cosSlop + sinL * sinSlop * cosAsp );
+ term3 = sinSlop * sinAsp;
+
+ // loop over days
+ for (j=0; j < nd; j++) {
+ d = day[j];
+ // angle at sunrise/sunset
+
+ hsr = -1.0 * tanL * tan(dS[d]);
+ // this only works for latitudes up to 66.5 deg N! Workaround:
+ if (hsr < -1) {
+ hsr = acos(-1);
+ } else if (hsr > 1) {
+ hsr = acos(1);
+ } else {
+ hsr = acos(hsr);
+ }
+ if (i==77) {
+ Rprintf ("hsr: %lf\n", hsr);
+ }
+ It = round(12*(1 + hsr / M_PI) - 12*(1-hsr / M_PI)); // calc daylength
+
+ // daily loop
+ I = 0;
+ for (h=0; h < It; h++) { // loop over sunshine hours
+ // if accounting for shading should be included, calc hillshade here
+
+ // hourangle of sun hs
+ hs = hsr-(M_PI * h/It); // hs(h)
+ // solar angle and azimuth
+ // alpha = asin(sinL*sin(dS)+cosL*cos(dS)*cos(hs));// solar altitude angle
+ sinAlpha = sinL * sin(dS[d]) + cosL * cos(dS[d]) * cos(hs);
+ // alpha_s = asin(cos(dS)*sin(hs)/cos(alpha)); // solar azimuth angle
+ // correction using atmospheric transmissivity taub_b
+ M = sqrt(1229+ pow(614 * sinAlpha, 2)) - 614 * sinAlpha; // Air mass ratio
+ tau_b = 0.56 * (exp(-0.65 * M) + exp(-0.095 * M));
+ tau_d = 0.271 - 0.294 * tau_b; // radiation diffusion coefficient for diffuse insolation
+ tau_r = 0.271 + 0.706 * tau_b; // reflectance transmitivity
+ // correct for local incident angle
+ cos_i = (sin(dS[d]) * term1) + (cos(dS[d]) * cos(hs) * term2) + (cos(dS[d]) * term3 * sin(hs));
+ Is = I0[d] * tau_b; // potential incoming shortwave radiation at surface normal (equator)
+ // R = potential clear sky solar radiation W m2
+ R = Is * cos_i;
+ if (R < 0) {
+ R = 0;
+ }
+ Id = I0[d] * tau_d * cosSlop2 / 2*sinAlpha; //diffuse radiation;
+ Ir = I0[d] * r * tau_r * sinSlop2/ 2* sinAlpha; // reflectance
+ R = R + Id + Ir;
+ if (R < 0) { R = 0; }
+ I = I + R; // solar radiation per day (sunshine hours)
+ }
+ srad[i + n*j] = I;
+ }
+ }
+ UNPROTECT(6);
+ return(rad);
+}
+
+
diff --git a/src/terrain.c b/src/terrain.c
new file mode 100644
index 0000000..19364b5
--- /dev/null
+++ b/src/terrain.c
@@ -0,0 +1,410 @@
+/* Robert Hijmans, October 2011 */
+
+#include <R.h>
+#include <Rinternals.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rdefines.h"
+#include "R_ext/Rdynload.h"
+#include "Rmath.h"
+
+#include "util.h"
+#include "dist_util.h"
+
+
+
+SEXP terrain(SEXP d, SEXP dim, SEXP res, SEXP un, SEXP opt, SEXP lonlat, SEXP geoy) {
+
+ R_len_t i, j;
+ SEXP val;
+ int nrow, ncol, n, unit, *option;
+ double *xd, *xval, dx, dy, *gy, *ddx;
+ double zy, zx;
+
+ PROTECT(d = coerceVector(d, REALSXP));
+ PROTECT(opt = coerceVector(opt, INTSXP));
+
+ nrow = INTEGER(dim)[0];
+ ncol = INTEGER(dim)[1];
+ n = nrow * ncol;
+
+ unit = INTEGER(un)[0];
+ dx = REAL(res)[0];
+ dy = REAL(res)[1];
+
+ option = INTEGER(opt);
+ int nopt = 0;
+ for (i =0; i<8; i++) {
+ nopt += option[i];
+ }
+
+ int geo = INTEGER(lonlat)[0];
+ PROTECT(geoy = coerceVector(geoy, REALSXP));
+ gy = REAL(geoy);
+ if (geo) {
+ double r = 6378137;
+ ddx=(double *) malloc(nrow*sizeof(double));
+ for (i=0; i<nrow; i++) {
+ ddx[i] = distHav(-dx, gy[i], dx, gy[i], r) / 2 ;
+ }
+ } else {
+ // to avoid a warning about ddx perhaps not being initialized
+ ddx=(double *) malloc(sizeof(double));
+ ddx[0] = 1;
+ }
+
+ PROTECT( val = allocVector(REALSXP, n*nopt) );
+
+ xd = REAL(d);
+ xval = REAL(val);
+
+ int add=0;
+ int addn=0;
+
+ if (option[0]) {
+ // terrain ruggedness
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i] = (fabs(xd[i-1-ncol]-xd[i]) + fabs(xd[i-1]-xd[i]) + fabs(xd[i-1+ncol]-xd[i]) + fabs(xd[i-ncol]-xd[i]) +
+ fabs(xd[i+ncol]-xd[i]) + fabs(xd[i+1-ncol]-xd[i]) + fabs(xd[i+1]-xd[i]) + fabs(xd[i+1+ncol]-xd[i])) / 8;
+ }
+ add++;
+ }
+ if (option[1]) {
+ addn = add * n;
+ // topograhic position
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = xd[i] - (xd[i-1-ncol] + xd[i-1] + xd[i-1+ncol] + xd[i-ncol]
+ + xd[i+ncol] + xd[i+1-ncol] + xd[i+1] + xd[i+1+ncol]) / 8;
+ }
+ add++;
+ }
+ if (option[2]) {
+ // roughness
+ addn = add * n;
+ int a[9] = { -1-ncol, -1, -1+ncol, -ncol, 0, ncol, 1-ncol, 1, 1+ncol };
+ double min, max, v;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ min = xd[i + a[0]];
+ max = xd[i + a[0]];
+ for (j = 1; j < 9; j++) {
+ v = xd[i + a[j]];
+ if (v > max) {
+ max = v;
+ } else if (v < min) {
+ min = v;
+ }
+ }
+ xval[i+addn] = max - min;
+ }
+ add++;
+ }
+
+
+ if (option[3]) {
+ // slope 4 neighbors
+ addn = add * n;
+ if (geo) {
+ int k, q;
+ double xwi[2] = {-1,1};
+ double xw[2] = {0,0};
+ double yw[2] = {-1,1};
+
+
+ for (i=0; i<2; i++) {
+ yw[i] = yw[i] / (2 * dy);
+ }
+ for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
+ if (i % ncol == 0) {
+ q = i / ncol;
+ for (k=0; k<2; k++) {
+ xw[k] = xwi[k] / (-2 * ddx[q]);
+ }
+ }
+ zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
+ zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
+ xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ) ;
+ }
+
+
+ } else {
+
+ double xw[2] = {-1,1};
+ double yw[2] = {-1,1};
+ for (i=0; i<2; i++) {
+ xw[i] = xw[i] / (-2 * dx);
+ yw[i] = yw[i] / (2 * dy);
+ }
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
+ zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
+ xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) );
+ }
+ }
+
+ if (unit == 0) {
+ double adj = 180 / M_PI;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = atan(xval[i+addn]) * adj;
+ }
+ } else if (unit == 1) {
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = atan(xval[i+addn]);
+ }
+ }
+
+
+ add++;
+ }
+
+
+ if (option[4]) {
+ // aspect 4 neighbors
+ addn = add * n;
+
+ if (geo) {
+ int k, q;
+ double xwi[2] = {-1,1};
+ double xw[2] = {0,0};
+ double yw[2] = {-1,1};
+
+
+ for (i=0; i<2; i++) {
+ yw[i] = yw[i] / (2 * dy);
+ }
+ for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
+ if (i % ncol == 0) {
+ q = i / ncol;
+ for (k=0; k<2; k++) {
+ xw[k] = xwi[k] / (-2 * ddx[q]);
+ }
+ }
+ zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
+ zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
+ zx = atan2(zy, zx);
+ xval[i+addn] = mod( M_PI_2 - zx, M_2PI);
+ }
+ if (unit == 0) {
+ double adj = 180 / M_PI;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = xval[i+addn] * adj;
+ }
+ }
+
+
+ } else {
+
+ double xw[2] = {-1,1};
+ double yw[2] = {-1,1};
+ for (i=0; i<2; i++) {
+ xw[i] = xw[i] / (-2 * dx);
+ yw[i] = yw[i] / (2 * dy);
+ }
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
+ zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
+ zx = atan2(zy, zx);
+ xval[i+addn] = mod( M_PI_2 -zx, M_2PI);
+ }
+ if (unit == 0) {
+ double adj = 180 / M_PI;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = xval[i+addn] * adj;
+ }
+ }
+ }
+
+ add++;
+
+ }
+
+
+ if (option[5]) {
+ // slope 8 neighbors
+ addn = add * n;
+ if (geo) {
+ int k, 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 (i=0; i<6; i++) {
+ yw[i] = yw[i] / (8 * dy);
+ }
+
+ for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
+ if (i % ncol == 0) {
+ q = i / ncol;
+ for (k=0; k<6; k++) {
+ xw[k] = xwi[k] / (8 * ddx[q]);
+ }
+ }
+ zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ + xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
+ zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ + xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
+ xval[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 (i=0; i<6; i++) {
+ xw[i] = xw[i] / (-8 * dx);
+ yw[i] = yw[i] / (8 * dy);
+ }
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ + xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
+ zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ + xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
+ xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) );
+
+ }
+ }
+
+ if (unit == 0) {
+ double adj = 180 / M_PI;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = atan(xval[i+addn]) * adj;
+ }
+ } else if (unit == 1) {
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = atan(xval[i+addn]);
+ }
+ }
+
+ add++;
+
+ }
+
+ if (option[6]) {
+ // aspect 8 neighbors
+ addn = add * n;
+
+ if (geo) {
+ int k, 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 (i=0; i<6; i++) {
+ yw[i] = yw[i] / (8 * dy);
+ }
+
+ for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
+ if (i % ncol == 0) {
+ q = i / ncol;
+ for (k=0; k<6; k++) {
+ xw[k] = xwi[k] / (-8 * ddx[q]);
+ }
+ }
+ zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ + xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
+ zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ + xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
+ zx = atan2(zy, zx);
+ xval[i+addn] = mod( M_PI_2 -zx, M_2PI);
+ }
+ if (unit == 0) {
+ double adj = 180 / M_PI;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = xval[i+addn] * adj;
+ }
+ }
+
+ } else {
+
+ double xw[6] = {-1,-2,-1,1,2,1};
+ double yw[6] = {-1,1,-2,2,-1,1};
+ for (i=0; i<6; i++) {
+ xw[i] = xw[i] / (-8 * dx);
+ yw[i] = yw[i] / (8 * dy);
+ }
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ + xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
+ zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ + xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
+ zx = atan2(zy, zx);
+ xval[i+addn] = mod( M_PI_2 -zx, M_2PI);
+ }
+ if (unit == 0) {
+ double adj = 180 / M_PI;
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ xval[i+addn] = xval[i+addn] * adj;
+ }
+ }
+
+ }
+
+ add++;
+
+ } if (option[7]) {
+ // flow direction
+ addn = add * n;
+ int v;
+ double d[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);
+ double dmin;
+ GetRNGstate();
+ for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
+ if (R_IsNA(xd[i])) {
+ xval[i+addn] = R_NaReal;
+ } else {
+ d[0] = (xd[i] - xd[i+1]) / dx;
+ d[1] = (xd[i] - xd[i+1+ncol]) / dxy;
+ d[2] = (xd[i] - xd[i+ncol]) / dy;
+ d[3] = (xd[i] - xd[i-1+ncol]) / dxy;
+ d[4] = (xd[i] - xd[i-1]) / dx;
+ d[5] = (xd[i] - xd[i-1-ncol]) / dxy;
+ d[6] = (xd[i] - xd[i-ncol]) / dy;
+ d[7] = (xd[i] - xd[i+1-ncol]) / dxy;
+ // using the lowest neighbor, even if it is higher than the focal cell.
+ dmin = d[0];
+ v = 0;
+ for (j=1; j<8; j++) {
+ if (d[j] > dmin) {
+ dmin = d[j];
+ v = j;
+ } else if (d[j] == dmin) {
+ if (unif_rand() > 0.5) {
+ dmin = d[j];
+ v = j;
+ }
+ }
+ }
+ xval[i+addn] = p[v];
+ }
+ }
+ PutRNGstate();
+ add++;
+ }
+
+// Set edges to NA
+// first row
+ for (j=0; j<add; j++) {
+ int jn = j * n;
+ for (i = 0; i < ncol; i++) {
+ xval[i+jn] = R_NaReal;
+ }
+ // last row
+ for (i = ncol * (nrow-1); i < n; i++) {
+ xval[i+jn] = R_NaReal;
+ }
+ // first and last columns
+ for (i = 1; i < nrow; i++) {
+ xval[i * ncol + jn] = R_NaReal;
+ xval[i * ncol - 1 + jn] = R_NaReal;
+ }
+ }
+
+ free(ddx);
+ UNPROTECT(4);
+ return(val);
+}
+
+
diff --git a/src/util.c b/src/util.c
new file mode 100644
index 0000000..91b0c60
--- /dev/null
+++ b/src/util.c
@@ -0,0 +1,32 @@
+#include <R.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "Rmath.h"
+
+
+
+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 ;
+}
+
+
+
diff --git a/src/util.h b/src/util.h
new file mode 100644
index 0000000..9579f66
--- /dev/null
+++ b/src/util.h
@@ -0,0 +1,15 @@
+/* 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);
+
diff --git a/src/wirth.c b/src/wirth.c
new file mode 100644
index 0000000..c5ca2d7
--- /dev/null
+++ b/src/wirth.c
@@ -0,0 +1,46 @@
+/*
+ * Algorithm from N. Wirth's book, implementation by N. Devillard.
+ * This code in public domain.
+ */
+
+
+typedef float elem_type ;
+
+#define ELEM_SWAP(a,b) { register elem_type t=(a);(a)=(b);(b)=t; }
+
+
+/*---------------------------------------------------------------------------
+ Function : kth_smallest()
+ In : array of elements, # of elements in the array, rank k
+ Out : one element
+ Job : find the kth smallest element in the array
+ Notice : use the median() macro defined below to get the median.
+ Reference: Wirth, N,. 1976. Algorithms + data structures = programs.
+ Prentice-Hall Series in Automatic Computation
+ ---------------------------------------------------------------------------*/
+
+elem_type kth_smallest(elem_type a[], int n, int k) {
+ int i,j,l,m ;
+ register elem_type x ;
+
+ l=0 ; m=n-1 ;
+ while (l<m) {
+ x=a[k] ;
+ i=l ;
+ j=m ;
+ do {
+ while (a[i]<x) i++ ;
+ while (x<a[j]) j-- ;
+ if (i<=j) {
+ ELEM_SWAP(a[i],a[j]) ;
+ i++ ; j-- ;
+ }
+ } while (i<=j) ;
+ if (j<k) l=i ;
+ if (k<i) m=j ;
+ }
+ return a[k] ;
+}
+
+
+#define median(a,n) kth_smallest(a,n,(((n)&1)?((n)/2):(((n)/2)-1)))
diff --git a/src/xyCell.cpp b/src/xyCell.cpp
new file mode 100644
index 0000000..9a53b89
--- /dev/null
+++ b/src/xyCell.cpp
@@ -0,0 +1,168 @@
+#include <Rcpp.h>
+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<int>(row) * ncols + static_cast<int>(col) + 1;
+ result[i] = row * ncols + col + 1 ;
+ }
+ }
+
+ return result;
+}
+
+
+// [[Rcpp::export(name = ".doXYFromCell")]]
+NumericMatrix doXYFromCell(
+ int ncols, int 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;
+ // fmod in stead of %
+ size_t col = fmod(c, ncols);
+ size_t row = (c / ncols);
+ result(i,0) = (col + 0.5) * xres + xmin;
+ result(i,1) = -((row + 0.5) * yres - ymax);
+ }
+
+ 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;
+}
+
+
diff --git a/vignettes/Raster.Rnw b/vignettes/Raster.Rnw
new file mode 100644
index 0000000..f8241c6
--- /dev/null
+++ b/vignettes/Raster.Rnw
@@ -0,0 +1,566 @@
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage{hanging}
+\usepackage[utf8]{inputenc}
+\usepackage{hyperref}
+
+%\VignetteIndexEntry{Introduction to the raster package}
+
+\newcommand{\R}{{\normalfont\textsf{R }}{}}
+\newcommand{\NA}{{\normalfont\textsf{NA }}{}}
+
+\DeclareGraphicsExtensions{.png,.pdf,.jpg}
+
+\begin{document}
+
+\SweaveOpts{png=TRUE, pdf=FALSE}
+
+\SweaveOpts{resolution=100}
+\SweaveOpts{keep.source=TRUE}
+
+<<foo,include=FALSE,echo=FALSE>>=
+options(width = 60)
+foo <- packageDescription("raster")
+@
+
+\title{Introduction to the 'raster' package\\(version \Sexpr{foo$Version})}
+
+\author{Robert J. Hijmans}
+\maketitle
+
+
+\section{Introduction}
+
+This vignette describes the \R package '\verb at raster@'. A raster is a spatial (geographic) data structure that divides a region into rectangles called 'cells' (or 'pixels') that can store one or more values for each of these cells. Such a data structure is also referred to as a 'grid' and is often contrasted with 'vector' data that is used to represent points, lines, and polygons.
+
+The \verb at raster@ package has functions for creating, reading, manipulating, and writing raster data. The package provides, among other things, general raster data manipulation functions that can easily be used to develop more specific functions. For example, there are functions to read a chunk of raster values from a file or to convert cell numbers to coordinates and back. The package also implements raster algebra and most functions for raster data manipulation that are common in Geogr [...]
+
+A notable feature of the \verb at raster@ package is that it can work with raster datasets that are stored on disk and are too large to be loaded into memory (RAM). The package can work with large files because the objects it creates from these files only contain information about the structure of the data, such as the number of rows and columns, the spatial extent, and the filename, but it does not attempt to read all the cell values in memory. In computations with these objects, data is p [...]
+
+To understand what is covered in this vignette, you must understand the basics of the \R language. There is a multitude of on-line and other resources that can help you to get acquainted with it. The \verb at raster@ package does not operate in isolation. For example, for vector type data it uses classes defined in the \verb at sp@ package. See the vignette and help pages of that package or Bivand {\it et al}. (2008). Bivand {\it et al}., provide an introduction to the use of \R for handling s [...]
+
+In the next section, some general aspects of the design of the '\verb at raster@' package are discussed, notably the structure of the main classes, and what they represent. The use of the package is illustrated in subsequent sections. \verb at raster@ has a large number of functions, not all of them are discussed here, and those that are discussed are mentioned only briefly. See the help files of the package for more information on individual functions and {\bf help("raster-package")} for an i [...]
+
+
+\section{Classes}
+
+The package is built around a number of 'S4' classes of which the \verb at RasterLayer@, \verb at RasterBrick@, and \verb at RasterStack@ classes are the most important. See Chambers (2009) for a detailed discussion of the use of S4 classes in \R. When discussing methods that can operate on all three of these objects, they are referred to as 'Raster*' objects.
+
+\subsection{RasterLayer}
+
+A \verb at RasterLayer@ object represents single-layer (variable) raster data. A \verb at RasterLayer@ object always stores a number of fundamental parameters that describe it. These include the number of columns and rows, the coordinates of its spatial extent ('bounding box'), and the coordinate reference system (the 'map projection'). In addition, a \verb at RasterLayer@ can store information about the file in which the raster cell values are stored (if there is such a file). A \verb at RasterLaye [...]
+
+\subsection{RasterStack and RasterBrick}
+
+It is quite common to analyze raster data using single-layer objects. However, in many cases multi-variable raster data sets are used. The \verb at raster@ package has two classes for multi-layer data the \verb at RasterStack@ and the \verb at RasterBrick@. The principal difference between these two classes is that a \verb at RasterBrick@ can only be linked to a single (multi-layer) file. In contrast, a \verb at RasterStack@ can be formed from separate files and/or from a few layers ('bands') from a si [...]
+
+In fact, a \verb at RasterStack@ is a collection of \verb at RasterLayer@ objects with the same spatial extent and resolution. In essence it is a list of \verb at RasterLayer@ objects. A \verb at RasterStack@ can easily be formed form a collection of files in different locations and these can be mixed with \verb at RasterLayer@ objects that only exist in memory.
+
+A \verb at RasterBrick@ is truly a multilayered object, and processing a \verb at RasterBrick@ can be more efficient than processing a \verb at RasterStack@ representing the same data. However, it can only refer to a single file. A typical example of such a file would be a multi-band satellite image or the output of a global climate model (with e.g., a time series of temperature values for each day of the year for each raster cell). Methods that operate on \verb at RasterStack@ and \verb at RasterBri [...]
+
+
+\subsection{Other classes}
+
+Below is some more detail, you do not need to read or understand this section to use the \verb at raster@ package.
+
+The three classes described above inherit from the \verb at Raster@ class (that means they are derived from this more basic 'parent' class by adding something to that class) which itself inherits from the \verb at BasicRaster@ class. The \verb at BasicRaster@ only has a few properties (referred to as 'slots' in S4 speak): the number of columns and rows, the coordinate reference system (which itself is an object of class \verb at CRS@, which is defined in package '\verb at sp@') and the spatial extent, [...]
+
+An object of class \verb at Extent@ has four slots: xmin, xmax, ymin, and ymax. These represent the minimum and maximum x and y coordinates of the of the Raster object. These would be, for example, -180, 180, -90, and 90, for a global raster with longitude/latitude coordinates. Note that raster uses the coordinates of the extremes (corners) of the entire raster (unlike some files/programs that use the coordinates of the center of extreme cells).
+
+\verb at Raster@ is a virtual class. This means that it cannot be instantiated (you cannot create objects from this class). It was created to allow the definition of methods for that class. These methods will be dispatched when called with a descendent of the class (i.e. when the method is called with a \verb at RasterLayer@, \verb at RasterBrick@ or \verb at RasterStack@ object as argument). This allows for efficient code writing because many methods are the same for any of these three classes, a [...]
+
+\verb at RasterStackBrick@ is a class union of the \verb at RasterStack@ and \verb at RasterBrick@ class. This is a also a virtual class. It allows defining methods (functions) that apply to both \verb at RasterStack@ and \verb at RasterBrick@ objects.
+
+
+\section{Creating Raster* objects}
+
+A \verb at RasterLayer@ can easily be created from scratch using the function {\bf raster}. The default settings will create a global raster data structure with a longitude/latitude coordinate reference system and 1 by 1 degree cells. You can change these settings by providing additional arguments such as {\bf xmin}, {\bf nrow}, {\bf ncol}, and/or {\bf crs}, to the function. You can also change these parameters after creating the object. If you set the projection, this is only to properly d [...]
+
+Here is an example of creating and changing a \verb at RasterLayer@ object 'r' from scratch.
+<<raster-1a>>=
+library(raster)
+# RasterLayer with the default parameters
+x <- raster()
+x
+
+# With other parameters
+x <- raster(ncol=36, nrow=18, xmn=-1000, xmx=1000, ymn=-100, ymx=900)
+# that can be changed
+res(x)
+
+# change resolution
+res(x) <- 100
+res(x)
+ncol(x)
+# change the numer of columns (affects resolution)
+ncol(x) <- 18
+ncol(x)
+res(x)
+
+# set the coordinate reference system (CRS) (define the projection)
+projection(x) <- "+proj=utm +zone=48 +datum=WGS84"
+x
+@
+
+The objects 'x' created in the example above only consist of a 'skeleton', that is, we have defined the number of rows and columns, and where the raster is located in geographic space, but there are no cell-values associated with it. Setting and accessing values is illustrated below.
+
+<<raster-1b, fig=TRUE , echo=TRUE>>=
+r <- raster(ncol=10, nrow=10)
+ncell(r)
+hasValues(r)
+
+# use the 'values' function
+# e.g.,
+values(r) <- 1:ncell(r)
+# or
+set.seed(0)
+values(r) <- runif(ncell(r))
+
+hasValues(r)
+inMemory(r)
+values(r)[1:10]
+
+plot(r, main='Raster with 100 cells')
+@
+
+In some cases, for example when you change the number of columns or rows, you will lose the values associated with the \verb at RasterLayer@ if there were any (or the link to a file if there was one). The same applies, in most cases, if you change the resolution directly (as this can affect the number of rows or columns). Values are not lost when changing the extent as this change adjusts the resolution, but does not change the number of rows or columns.
+
+<<raster-1c, echo=TRUE>>=
+hasValues(r)
+res(r)
+dim(r)
+xmax(r)
+
+# change the maximum x coordinate of the extent (bounding box) of the RasterLayer
+xmax(r) <- 0
+
+hasValues(r)
+res(r)
+dim(r)
+
+ncol(r) <- 6
+hasValues(r)
+res(r)
+dim(r)
+xmax(r)
+@
+
+The function {\bf raster} also allows you to create a \verb at RasterLayer@ from another object, including another \verb at RasterLayer@, \verb at RasterStack@ and \verb at RasterBrick@ , as well as from a \verb at SpatialPixels*@ and \verb at SpatialGrid*@ object (defined in the \verb at sp@ package), an \verb at Extent@ object, a matrix, an 'im' object (SpatStat), and 'asc' and 'kasc' objects (adehabitat).
+
+It is more common, however, to create a \verb at RasterLayer@ object from a file. The raster package can use raster files in several formats, including some 'natively' supported formats and other formats via the \verb at rgdal@ package. Supported formats for reading include GeoTIFF, ESRI, ENVI, and ERDAS. Most formats supported for reading can also be written to. Here is an example using the 'Meuse' dataset (taken from the \verb at sp@ package), using a file in the native 'raster-file' format:
+
+<<raster-2a, fig=TRUE , echo=TRUE>>=
+# get the name of an example file installed with the package
+# do not use this construction of your own files
+filename <- system.file("external/test.grd", package="raster")
+
+filename
+r <- raster(filename)
+filename(r)
+hasValues(r)
+inMemory(r)
+plot(r, main='RasterLayer from file')
+@
+
+Multi-layer objects can be created in memory (from \verb at RasterLayer@ objects) or from files.
+
+<<raster-2b>>=
+# create three identical RasterLayer objects
+r1 <- r2 <- r3 <- raster(nrow=10, ncol=10)
+# Assign random cell values
+values(r1) <- runif(ncell(r1))
+values(r2) <- runif(ncell(r2))
+values(r3) <- runif(ncell(r3))
+
+# combine three RasterLayer objects into a RasterStack
+s <- stack(r1, r2, r3)
+s
+nlayers(s)
+
+# combine three RasterLayer objects into a RasterBrick
+b1 <- brick(r1, r2, r3)
+# equivalent to:
+b2 <- brick(s)
+
+# create a RasterBrick from file
+filename <- system.file("external/rlogo.grd", package="raster")
+filename
+b <- brick(filename)
+b
+nlayers(b)
+
+# extract a single RasterLayer
+r <- raster(b, layer=2)
+# equivalent to creating it from disk
+r <- raster(filename, band=2)
+@
+
+
+\section{Raster algebra}
+
+Many generic functions that allow for simple and elegant raster algebra have been implemented for \verb at Raster*@ objects, including the normal algebraic operators such as {\bf +, -, *, /}, logical operators such as {\bf >, >=, <, ==, !} and functions such as {\bf abs, round, ceiling, floor, trunc, sqrt, log, log10, exp, cos, sin, max, min, range, prod, sum, any, all}. In these functions you can mix \verb at Raster@ objects with numbers, as long as the first argument is a \verb at Raster@ object.
+
+<<raster-3a>>=
+# create an empty RasterLayer
+r <- raster(ncol=10, nrow=10)
+# assign values to cells
+values(r) <- 1:ncell(r)
+s <- r + 10
+s <- sqrt(s)
+s <- s * r + 5
+r[] <- runif(ncell(r))
+r <- round(r)
+r <- r == 1
+@
+
+You can also use replacement functions:
+<<raster-3b>>=
+s[r] <- -0.5
+s[!r] <- 5
+s[s == 5] <- 15
+@
+
+If you use multiple \verb at Raster*@ objects (in functions where this is relevant, such as range), these must have the same resolution and origin. The origin of a \verb at Raster*@ object is the point closest to (0, 0) that you could get if you moved from a corners of a \verb at Raster*@ object towards that point in steps of the \verb at x@ and \verb at y@ resolution. Normally these objects would also have the same extent, but if they do not, the returned object covers the spatial intersection of the [...]
+
+
+When you use multiple multi-layer objects with different numbers or layers, the 'shorter' objects are 'recycled'. For example, if you multuply a 4-layer object (a1, a2, a3, a4) with a 2-layer object (b1, b2), the result is a four-layer object (a1b1, a2b2, a3b1, a3b2).
+
+<<raster-3c>>=
+r <- raster(ncol=5, nrow=5)
+r[] <- 1
+s <- stack(r, r+1)
+q <- stack(r, r+2, r+4, r+6)
+x <- r + s + q
+x
+@
+
+
+Summary functions {\bf (min, max, mean, prod, sum, Median, cv, range, any, all)} always return a \verb at RasterLayer@ object. Perhaps this is not obvious when using functions like {\bf min, sum or mean}.
+
+<<raster-3d>>=
+a <- mean(r,s,10)
+b <- sum(r,s)
+st <- stack(r, s, a, b)
+sst <- sum(st)
+sst
+@
+
+Use {\bf cellStats} if instead of a \verb at RasterLayer@ you want a single number summarizing the cell values of each layer.
+<<raster-3e>>=
+cellStats(st, 'sum')
+cellStats(sst, 'sum')
+@
+
+
+
+\section{'High-level' functions}
+
+Several 'high level' functions have been implemented for \verb at RasterLayer@ objects. 'High level' functions refer to functions that you would normally find in a GIS program that supports raster data. Here we briefly discuss some of these functions. All these functions work for raster datasets that cannot be loaded into memory. See the help files for more detailed descriptions of each function.
+
+The high-level functions have some arguments in common. The first argument is typically 'x' or 'object' and can be a \verb at RasterLayer@, or, in most cases, a \verb at RasterStack@ or \verb at RasterBrick@. It is followed by one or more arguments specific to the function (either additional \verb at RasterLayer@ objects or other arguments), followed by a filename="" and "..." arguments.
+
+The default filename is an empty character "". If you do not specify a filename, the default action for the function is to return a \verb at Raster@ object that only exists in memory. However, if the function deems that the \verb at Raster@ object to be created would be too large to hold memory it is written to a temporary file instead.
+
+The "..." argument allows for setting additional arguments that are relevant when writing values to a file: the file format, datatype (e.g. integer or real values), and a to indicate whether existing files should be overwritten.
+
+
+\subsection{Modifying a Raster* object}
+
+There are several functions that deal with modifying the spatial extent of \verb at Raster*@ objects. The {\bf crop} function lets you take a geographic subset of a larger \verb at Raster@ object. You can crop a \verb at Raster*@ by providing an extent object or another spatial object from which an extent can be extracted (objects from classes deriving from Raster and from Spatial in the sp package). An easy way to get an extent object is to plot a \verb at RasterLayer@ and then use {\bf drawExtent} [...]
+
+{\bf trim} crops a \verb at RasterLayer@ by removing the outer rows and columns that only contain \NA values. In contrast, {\bf extend} adds new rows and/or columns with \NA values. The purpose of this could be to create a new \verb at RasterLayer@ with the same Extent of another larger \verb at RasterLayer@ such that the can be used together in other functions.
+
+The {\bf merge} function lets you merge 2 or more \verb at Raster*@ objects into a single new object. The input objects must have the same resolution and origin (such that their cells neatly fit into a single larger raster). If this is not the case you can first adjust one of the \verb at Raster*@ objects with use {\bf (dis)aggregate} or {\bf resample}.
+
+{\bf aggregate} and {\bf disaggregate} allow for changing the resolution (cell size) of a \verb at Raster*@ object. In the case of {\bf aggregate}, you need to specify a function determining what to do with the grouped cell values (e.g. {\bf mean}). It is possible to specify different (dis)aggregation factors in the x and y direction. {\bf aggregate} and {\bf disaggregate} are the best functions when adjusting cells size only, with an integer step (e.g. each side 2 times smaller or larger), [...]
+
+For example, you may need nearly the same cell size, while shifting the cell centers. In those cases, the {\bf resample} function can be used. It can do either nearest neighbor assignments (for categorical data) or bilinear interpolation (for numerical data). Simple linear shifts of a Raster object can be accomplished with the {\bf shift} function or with the {\bf extent} function. {\bf resample} should not be used to create a Raster* object with much larger resolution. If such adjustmen [...]
+
+With the {\bf projectRaster} function you can transform values of \verb at Raster*@ object to a new object with a different coordinate reference system.
+
+Here are some simple examples:
+<<raster-5, fig=TRUE , echo=TRUE>>=
+r <- raster()
+r[] <- 1:ncell(r)
+ra <- aggregate(r, 10)
+r1 <- crop(r, extent(-180,0,0,30))
+r2 <- crop(r, extent(-10,180,-20,10))
+m <- merge(r1, r2, filename='test.grd', overwrite=TRUE)
+plot(m)
+@
+
+{\bf flip} lets you flip the data (reverse order) in horizontal or vertical direction -- typically to correct for a 'communication problem' between different R packages or a misinterpreted file. {\bf rotate} lets you rotate longitude/latitude rasters that have longitudes from 0 to 360 degrees (often used by climatologists) to the standard -180 to 180 degrees system. With {\bf t} you can rotate a \verb at Raster*@ object 90 degrees.
+
+
+\subsection{Overlay}
+The {\bf overlay} function can be used as an alternative to the raster algebra discussed above. Overlay, like the funcitons discussed in the following subsections provide either easy to use short-hand, or more efficient computation for large (file based) objects.
+
+With {\bf overlay} you can combine multiple Raster objects (e.g. multiply them). The related function {\bf mask} removes all values from one layer that are \NA in another layer, and {\bf cover} combines two layers by taking the values of the first layer except where these are \NA.
+
+
+\subsection{Calc}
+
+{\bf calc} allows you to do a computation for a single \verb at Raster@ object by providing a function. If you supply a \verb at RasterLayer@, another \verb at RasterLayer@ is returned. If you provide a multi-layer object you get a (single layer) \verb at RasterLayer@ if you use a summary type function (e.g. {\bf sum}) but a \verb at RasterBrick@ if multiple layers are returned. {\bf stackApply} computes summary type layers for subsets of a \verb at RasterStack@ or \verb at RasterBrick@.
+
+
+\subsection{Reclassify}
+You can use {\bf cut} or {\bf reclassify} to replace ranges of values with single values, or {\bf subs} to substitute (replace) single values with other values.
+
+<<raster-6>>=
+r <- raster(ncol=3, nrow=2)
+r[] <- 1:ncell(r)
+getValues(r)
+s <- calc(r, fun=function(x){ x[x < 4] <- NA; return(x)} )
+as.matrix(s)
+t <- overlay(r, s, fun=function(x, y){ x / (2 * sqrt(y)) + 5 } )
+as.matrix(t)
+u <- mask(r, t)
+as.matrix(u)
+v = u==s
+as.matrix(v)
+w <- cover(t, r)
+as.matrix(w)
+x <- reclassify(w, c(0,2,1, 2,5,2, 4,10,3))
+as.matrix(x)
+y <- subs(x, data.frame(id=c(2,3), v=c(40,50)))
+as.matrix(y)
+@
+
+
+\subsection{Focal functions}
+
+The {\bf focal} function currently only works for (single layer) RasterLayer objects. It uses values in a neighborhood of cells around a focal cell, and computes a value that is stored in the focal cell of the output RasterLayer. The neighborhood is a user-defined a matrix of weights and could approximate any shape by giving some cells zero weight. It is possible to only compute new values for cells that are \NA in the input RasterLayer.
+
+
+\subsection{Distance}
+
+There are a number of distance related functions. {\bf distance} computes the shortest distance to cells that are not \NA. {\bf pointDistance} computes the shortest distance to any point in a set of points. {\bf gridDistance} computes the distance when following grid cells that can be traversed (e.g. excluding water bodies). {\bf direction} computes the direction towards (or from) the nearest cell that is not \NA. {\bf adjacency} determines which cells are adjacent to other cells, and {\ [...]
+
+\subsection{Spatial configuration}
+Function {\bf clump} identifies groups of cells that are connected. {\bf boundaries} identifies edges, that is, transitions between cell values. {\bf area} computes the size of each grid cell (for unprojected rasters), this may be useful to, e.g. compute the area covered by a certain class on a longitude/latitude raster.
+
+<<raster-7>>=
+r <- raster(nrow=45, ncol=90)
+r[] <- round(runif(ncell(r))*3)
+a <- area(r)
+zonal(a, r, 'sum')
+@
+
+
+\subsection{Predictions}
+The package has two functions to make model predictions to (potentially very large) rasters. {\bf predict} takes a multilayer raster and a fitted model as arguments. Fitted models can be of various classes, including glm, gam, randomforest, and brt. Function {\bf interpolate} is similar but is for models that use coordinates as predictor variables, for example in kriging and spline interpolation.
+
+
+\subsection{Vector to raster conversion}
+
+The raster packages supports point, line, and polygon to raster conversion with the {\bf rasterize} function. For vector type data (points, lines, polygons), objects of Spatial* classes defined in the \verb at sp@ package are used; but points can also be represented by a two-column matrix (x and y).
+
+Point to raster conversion is often done with the purpose to analyze the point data. For example to count the number of distinct species (represented by point observations) that occur in each raster cell. {\bf rasterize} takes a \verb at Raster*@ object to set the spatial extent and resolution, and a function to determine how to summarize the points (or an attribute of each point) by cell.
+
+Polygon to raster conversion is typically done to create a \verb at RasterLayer@ that can act as a mask, i.e. to set to \NA a set of cells of a \verb at Raster@ object, or to summarize values on a raster by zone. For example a country polygon is transferred to a raster that is then used to set all the cells outside that country to \NA; whereas polygons representing administrative regions such as states can be transferred to a raster to summarize raster values by region.
+
+It is also possible to convert the values of a \verb at RasterLayer@ to points or polygons, using {\bf rasterToPoints} and {\bf rasterToPolygons}. Both functions only return values for cells that are not \NA. Unlike {\bf rasterToPolygons}, {\bf rasterToPoints} is reasonably efficient and allows you to provide a function to subset the output before it is produced (which can be necessary for very large rasters as the point object is created in memory).
+
+
+\section{Summarizing functions}
+
+When used with a \verb at Raster*@ object as first argument, normal summary statistics functions such as min, max and mean return a RasterLayer. You can use cellStats if, instead, you want to obtain a summary for all cells of a single \verb at Raster*@ object. You can use {\bf freq} to make a frequency table, or to count the number of cells with a specified value. Use {\bf zonal} to summarize a \verb at Raster*@ object using zones (areas with the same integer number) defined in a \verb at RasterLaye [...]
+
+<<raster-10>>=
+r <- raster(ncol=36, nrow=18)
+r[] <- runif(ncell(r))
+cellStats(r, mean)
+s = r
+s[] <- round(runif(ncell(r)) * 5)
+zonal(r, s, 'mean')
+freq(s)
+freq(s, value=3)
+crosstab(r*3, s)
+@
+
+
+\section{Plotting}
+Several generic functions have been implemented for Raster* objects to create maps and other plot types. Use 'plot' to create a map of a Raster* object. When plot is used with a \verb at RasterLayer@, it calls the function 'rasterImage' (but, by default, adds a legend; using code from fields::image.plot). It is also possible to directly call {\bf image}. You can zoom in using 'zoom' and clicking on the map twice (to indicate where to zoom to). With {\bf click} it is possible to interactivel [...]
+
+After plotting a \verb at RasterLayer@ you can add vector type spatial data (points, lines, polygons). You can do this with functions points, lines, polygons if you are using the basic R data structures or plot(object, add=TRUE) if you are using Spatial* objects as defined in the sp package. When plot is used with a multi-layer Raster* object, all layers are plotted (up to 16), unless the layers desired are indicated with an additional argument. You can also plot Raster* objects with spplot [...]
+
+Multi-layer Raster objects can be plotted as individual layers
+<<raster-20a, fig=TRUE , echo=TRUE>>=
+b <- brick(system.file("external/rlogo.grd", package="raster"))
+plot(b)
+@
+
+They can also be combined into a single image, by assigning individual layers to one of the three color channels (red, green and blue):
+<<raster-20b, fig=TRUE , echo=TRUE>>=
+plotRGB(b, r=1, g=2, b=3)
+@
+
+You can also use the a number of other plotting functions with a \verb at Raster@ object as argument, including {\bf hist, persp, contour}, and {\bf density}. See the help files for more info.
+
+
+
+\section{Writing files}
+
+\subsection{File format}
+
+Raster can read most, and write several raster file formats, via the \verb at rgdal@ package. However, it directly reads and writes a native 'rasterfile' format. A rasterfile consists of two files: a binary sequential data file and a text header file. The header file is of the "windows .ini" type. When reading, you do not have to specify the file format, but you do need to do that when writing (except when using the default native format). This file format is also used in DIVA-GIS (\url{htt [...]
+
+
+
+\section{Helper functons}
+
+The cell number is an important concept in the raster package. Raster data can be thought of as a matrix, but in a \verb at RasterLayer@ it is more commonly treated as a vector. Cells are numbered from the upper left cell to the upper right cell and then continuing on the left side of the next row, and so on until the last cell at the lower-right side of the raster. There are several helper functions to determine the column or row number from a cell and vice versa, and to determine the cell [...]
+
+<<raster-15>>=
+library(raster)
+r <- raster(ncol=36, nrow=18)
+ncol(r)
+nrow(r)
+ncell(r)
+rowFromCell(r, 100)
+colFromCell(r, 100)
+cellFromRowCol(r,5,5)
+xyFromCell(r, 100)
+cellFromXY(r, c(0,0))
+colFromX(r, 0)
+rowFromY(r, 0)
+@
+
+
+\section{Accessing cell values}
+
+Cell values can be accessed with several methods. Use {\bf getValues} to get all values or a single row; and {\bf getValuesBlock} to read a block (rectangle) of cell values.
+
+<<raster-20>>=
+r <- raster(system.file("external/test.grd", package="raster"))
+v <- getValues(r, 50)
+v[35:39]
+getValuesBlock(r, 50, 1, 35, 5)
+@
+
+
+You can also read values using cell numbers or coordinates (xy) using the {\bf extract} method.
+<<raster-21>>=
+cells <- cellFromRowCol(r, 50, 35:39)
+cells
+extract(r, cells)
+xy = xyFromCell(r, cells)
+xy
+extract(r, xy)
+@
+
+
+You can also extract values using SpatialPolygons* or SpatialLines*. The default approach for extracting raster values with polygons is that a polygon has to cover the center of a cell, for the cell to be included. However, you can use argument "weights=TRUE" in which case you get, apart from the cell values, the percentage of each cell that is covered by the polygon, so that you can apply, e.g., a "50\% area covered" threshold, or compute an area-weighted average.
+
+In the case of lines, any cell that is crossed by a line is included. For lines and points, a cell that is only 'touched' is included when it is below or to the right (or both) of the line segment/point (except for the bottom row and right-most column).
+
+In addition, you can use standard \R indexing to access values, or to replace values (assign new values to cells) in a \verb at Raster@ object. If you replace a value in a \verb at Raster@ object based on a file, the connection to that file is lost (because it now is different from that file). Setting raster values for very large files will be very slow with this approach as each time a new (temporary) file, with all the values, is written to disk. If you want to overwrite values in an existin [...]
+
+<<raster-32>>=
+r[cells]
+r[1:4]
+filename(r)
+r[2:3] <- 10
+r[1:4]
+filename(r)
+@
+
+Note that in the above examples values are retrieved using cell numbers. That is, a raster is represented as a (one-dimensional) vector. Values can also be inspected using a (two-dimensional) matrix notation. As for \R matrices, the first index represents the row number, the second the column number.
+
+<<raster-33>>=
+r[1]
+r[2,2]
+r[1,]
+r[,2]
+r[1:3,1:3]
+
+# keep the matrix structure
+r[1:3,1:3, drop=FALSE]
+@
+
+Accessing values through this type of indexing should be avoided inside functions as it is less efficient than accessing values via functions like {\bf getValues}.
+
+
+
+\section{Session options}
+
+There is a number of session options that influence reading and writing files. These can be set in a session, with \verb at rasterOptions@, and saved to make them persistent in between sessions. But you probably should not change the default values unless you have pressing need to do so. You can, for example, set the directory where temporary files are written, and set your preferred default file format and data type. Some of these settings can be overwritten by arguments to functions where [...]
+
+<<raster-119>>=
+rasterOptions()
+@
+
+
+\section{Coercion to objects of other classes}
+
+Although the raster package defines its own set of classes, it is easy to coerce objects of these classes to objects of the 'spatial' family defined in the sp package. This allows for using functions defined by sp (e.g. spplot) and for using other packages that expect spatial* objects. To create a Raster object from variable n in a SpatialGrid* x use \verb at raster(x, n)@ or \verb at stack(x)@ or \verb at brick(x)@. Vice versa use \verb at as( , )@
+
+You can also convert objects of class "im" (spatstat) and "asc" (adehabitat) to a \verb at RasterLayer@ and "kasc" (adehabitat) to a \verb at RasterStack@ or Brick using the \verb at raster(x)@, \verb at stack(x)@ or \verb at brick(x)@ function.
+
+<<raster-120>>=
+r1 <- raster(ncol=36, nrow=18)
+r2 <- r1
+r1[] <- runif(ncell(r1))
+r2[] <- runif(ncell(r1))
+s <- stack(r1, r2)
+sgdf <- as(s, 'SpatialGridDataFrame')
+newr2 <- raster(sgdf, 2)
+news <- stack(sgdf)
+@
+
+
+\section{Extending raster objects}
+
+It is straightforward to build on the Raster* objects using the S4 inheritance mechanism. Say you need objects that behave like a \verb at RasterLayer@, but have some additional properties that you need to use in your own functions (S4 methods). See Chambers (2009) and the help pages of the Methods package for more info. Below is an example:
+
+<<raster-132>>=
+setClass ('myRaster',
+ contains = 'RasterLayer',
+ representation (
+ important = 'data.frame',
+ essential = 'character'
+ ) ,
+ prototype (
+ important = data.frame(),
+ essential = ''
+ )
+)
+
+r = raster(nrow=10, ncol=10)
+
+m <- as(r, 'myRaster')
+m at important <- data.frame(id=1:10, value=runif(10))
+m at essential <- 'my own slot'
+m[] <- 1:ncell(m)
+@
+
+<<raster-133>>=
+setMethod ('show' , 'myRaster',
+ function(object) {
+ callNextMethod(object) # call show(RasterLayer)
+ cat('essential:', object at essential, '\n')
+ cat('important information:\n')
+ print( object at important)
+ })
+
+m
+@
+
+
+
+\section{References}
+
+\begin{hangparas}{3em}{1}
+
+\noindent Bivand, R.S., E.J. Pebesma and V. Gomez-Rubio, 2008. Applied Spatial Data Analysis with \R. Springer. 378p.
+
+\noindent Chambers, J.M., 2009. Software for Data Analysis: Programming with \R. Springer. 498p.
+
+\end{hangparas}
+
+
+\end{document}
diff --git a/vignettes/functions.Rnw b/vignettes/functions.Rnw
new file mode 100644
index 0000000..b3c5804
--- /dev/null
+++ b/vignettes/functions.Rnw
@@ -0,0 +1,416 @@
+\documentclass{article}
+
+\usepackage{natbib}
+\usepackage{graphics}
+\usepackage{amsmath}
+\usepackage{indentfirst}
+\usepackage[utf8]{inputenc}
+\usepackage{hyperref}
+
+%\VignetteIndexEntry{Writing functions for large raster files}
+
+\newcommand{\R}{{\normalfont\textsf{R }}{}}
+
+\SweaveOpts{keep.source=TRUE}
+
+\begin{document}
+
+
+\title{Writing functions with the "raster" package}
+\author{Robert J. Hijmans}
+\maketitle
+
+
+\section{Introduction}
+
+The '\verb at raster@' package has a number of 'low-level' functions (e.g. to read and write files) that allow you to write your own 'high-level' functions. Here I explain how to use these low-level functions in developing 'memory-safe' high-level functions. With 'memory-safe' I refer to function that can process raster files that are too large to be loaded into memory. To understand the material discussed in this vignette you should be already somewhat familiar with the raster package. It [...]
+
+I should also note that if you are not sure, you probably do not need to read this vignette, or use the functions described herein. That is, the high-level functions in the raster package are already based on these techniques, and they are very flexible. It is likely that you can accomplish your goals with the functions already available in 'raster' and that you do not need to write your own.
+
+\section{How not to do it}
+
+Let's start with two simple example functions, f1 and f2, that are NOT memory safe. The purpose of these simple example functions is to add a numerical constant 'a' to all values of RasterLayer 'x'.
+
+To test the functions, we create a RasterLayer with 100 cells and values 1 to 100.
+<<code-1>>=
+library(raster)
+r <- raster(ncol=10, nrow=10)
+r[] <- 1:100
+r
+@
+
+Below is a simple function, f1, that we use to add 5 to all cell values of 'r'
+
+<<code-2>>=
+f1 <- function(x, a) {
+ x at data@values <- x at data@values + a
+ return(x)
+}
+s <- f1(r, 5)
+s
+@
+
+f1 is a really bad example. It looks efficient but it has several problems. First of all, the slot x at data@values may be empty, which is typically the case when a raster object is derived from a file on disk. But even if all values are in memory the returned object will be invalid. This is because the values of a multiple slots need to be adjusted when changing values. For example, the returned 'x' may still point to a file (now incorrectly, because the values no longer correspond to it). [...]
+
+<<code-3>>=
+f2 <- function(x, a) {
+ v <- getValues(x)
+ v <- v + a
+ x <- setValues(x, v)
+ return(x)
+}
+s <- f2(r, 5)
+s
+@
+
+f2 is much better than f1. Function {\bf getValues} gets the cell values whether they are on disk or in memory (and will return NA values if neither is the case). {\bf setValues} sets the values to the RasterLayer object assuring that other slots are updated as well.
+
+However, this function could fail when used with very large raster files, depending on the amount of RAM your computer has and that \R can access, because all values are read into memory at once. Processing data in chunks circumvents this problem.
+
+
+\section{Row by row}
+
+The next example shows how you can read, process, and write values row by row.
+
+<<code-4>>=
+f3 <- function(x, a, filename) {
+ out <- raster(x)
+ out <- writeStart(out, filename, overwrite=TRUE)
+ for (r in 1:nrow(out)) {
+ v <- getValues(x, r)
+ v <- v + a
+ out <- writeValues(out, v, r)
+ }
+ out <- writeStop(out)
+ return(out)
+}
+s <- f3(r, 5, filename='test')
+s
+@
+
+Note how, in the above example, first a new empty RasterLayer, 'out' is created using the {bf raster} function. 'out' has the same extent and resolution as 'x', but it does not have the values of 'x'.
+
+
+\section{Multiple rows at once}
+
+Row by row processing is easy to do but it can be a bit inefficient because there is some overhead associated with each read and write operation. An alternative is to read, calculate, and write by block; here defined as a number of rows (1 or more). The function {bf blockSize} is a helper function to determine appropriate block size (number of rows).
+
+<<code-5>>=
+f4 <- function(x, a, filename) {
+ out <- raster(x)
+ bs <- blockSize(out)
+ out <- writeStart(out, filename, overwrite=TRUE)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ }
+ out <- writeStop(out)
+ return(out)
+}
+s <- f4(r, 5, filename='test.grd')
+blockSize(s)
+@
+
+
+\section{Filename optional}
+
+In the above examples (functions f3 and f4) you must supply a filename. However, in the raster package that is never the case, it is always optional. If a filename is provided, values are written to disk. If no filename is provided the values are only written to disk if they cannot be stored in RAM. To determine whether the output needs to be written to disk, the function {\bf canProcessInMemory} is used. This function uses the size of the output raster to determine the total memory size [...]
+
+
+First an example for row by row processing:
+
+<<code-6>>=
+f5 <- function(x, a, filename='') {
+ out <- raster(x)
+ small <- canProcessInMemory(out, 3)
+ filename <- trim(filename)
+
+ if (!small & filename == '') {
+ filename <- rasterTmpFile()
+ }
+
+ todisk <- FALSE
+ if (filename != '') {
+ out <- writeStart(out, filename, overwrite=TRUE)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ }
+
+ for (r in 1:nrow(out)) {
+ v <- getValues(x, r)
+ v <- v + a
+ if (todisk) {
+ out <- writeValues(out, v, r)
+ } else {
+ vv[,r] <- v
+ }
+ }
+ if (todisk) {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ return(out)
+}
+s <- f5(r, 5)
+@
+
+
+Now, the same function, but looping over blocks of multiple rows, instead of a single row at a time (which can make a function very slow).
+
+<<code-7>>=
+f6 <- function(x, a, filename='') {
+ out <- raster(x)
+ small <- canProcessInMemory(out, 3)
+ filename <- trim(filename)
+
+ if (! small & filename == '') {
+ filename <- rasterTmpFile()
+ }
+ if (filename != '') {
+ out <- writeStart(out, filename, overwrite=TRUE)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ todisk <- FALSE
+ }
+
+ bs <- blockSize(r)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ if (todisk) {
+ out <- writeValues(out, v, bs$row[i])
+ } else {
+ cols <- bs$row[i]:(bs$row[i]+bs$nrows[i]-1)
+ vv[,cols] <- matrix(v, nrow=ncol(out))
+ }
+ }
+ if (todisk) {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ return(out)
+}
+
+s <- f6(r, 5)
+@
+
+
+The next example is an alternative implementation that you might prefer if you wanted to optimize speed when values can be processed in memory. Optimizing for that situation is generally not that important as it tends to be relatively fast in any case. Moreover, while the below example is fine, this may not be an ideal approach for more complex functions as you would have to implement some parts of your algorithm twice. If you are not careful, your function might then give different resu [...]
+
+<<code-8>>=
+f7 <- function(x, a, filename='') {
+
+ out <- raster(x)
+ filename <- trim(filename)
+
+ if (canProcessInMemory(out, 3)) {
+ v <- getValues(x) + a
+ out <- setValues(out, v)
+ if (filename != '') {
+ out <- writeRaster(out, filename, overwrite=TRUE)
+ }
+ } else {
+ if (filename == '') {
+ filename <- rasterTmpFile()
+ }
+ out <- writeStart(out, filename)
+
+ bs <- blockSize(r)
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ }
+ out <- writeStop(out)
+ }
+ return(out)
+}
+
+s <- f7(r, 5)
+@
+
+
+\section{A complete function}
+
+Finally, let's add some useful bells and whistles. For example, you may want to specify a file format and data type, be able to overwrite an existing file, and use a progress bar. So far, default values have been used. If you use the below function, the dots '...' allow you to change these by providing additional arguments 'overwrite', 'format', and 'datatype'. (In all cases you can also set default values with the {\bf rasterOptions} function).
+
+
+<<code-9>>=
+f8 <- function(x, a, filename='', ...) {
+ out <- raster(x)
+ big <- ! canProcessInMemory(out, 3)
+ filename <- trim(filename)
+ if (big & filename == '') {
+ filename <- rasterTmpFile()
+ }
+ if (filename != '') {
+ out <- writeStart(out, filename, ...)
+ todisk <- TRUE
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ todisk <- FALSE
+ }
+
+ bs <- blockSize(x)
+ pb <- pbCreate(bs$n, ...)
+
+ if (todisk) {
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ out <- writeValues(out, v, bs$row[i])
+ pbStep(pb, i)
+ }
+ out <- writeStop(out)
+ } else {
+ for (i in 1:bs$n) {
+ v <- getValues(x, row=bs$row[i], nrows=bs$nrows[i] )
+ v <- v + a
+ cols <- bs$row[i]:(bs$row[i]+bs$nrows[i]-1)
+ vv[,cols] <- matrix(v, nrow=out at ncols)
+ pbStep(pb, i)
+ }
+ out <- setValues(out, as.vector(vv))
+ }
+ pbClose(pb)
+ return(out)
+}
+
+s <- f8(r, 5, filename='test', overwrite=TRUE)
+
+if(require(rgdal)) { # only if rgdal is installed
+ s <- f8(r, 5, filename='test.tif', format='GTiff', overwrite=TRUE)
+}
+s
+@
+
+Note that most of the additional arguments are passed on to writeStart:
+
+\texttt{out <- writeStart(out, filename, ...)}
+
+Only the \texttt{progress=} argument goes to \texttt{pbCreate}
+
+
+\section{Debugging}
+
+Typically functions are developed and tested with small (RasterLayer) objects. But you also need to test your functions for the case it needs to write values to disk. You can use a very large raster for that, but then you may need to wait a long time each time you run it. Depending on how you design your function you may be able to test alternate forks in your function by providing a file name. But this would not necessarily work for function f7. You can force functions of that type to t [...]
+
+
+\section{Methods}
+
+The raster package is build with S4 classes and methods. If you are developing a package that builds on the raster package I would advise to also use S4 classes and methods. Thus, rather than using plain functions, define generic methods (where necessary) and implement them for a RasterLayer, as in the example below (the function does not do anything; replace 'return(x)' with something meaningful along the pattern explained above.
+
+<<code-10>>=
+if (!isGeneric("f9")) {
+ setGeneric("f9", function(x, ...)
+ standardGeneric("f9"))
+}
+
+
+setMethod('f9', signature(x='RasterLayer'),
+ function(x, filename='', ...) {
+ return(x)
+ }
+)
+
+s <- f9(r)
+@
+
+
+\section{Mutli-core functions}
+
+Below is an example of an implementation of a customized raster function that can use multiple processors (cores), via the snow package. This is still very much under development, but you can try it at your own risk.
+
+First we define a snow cluster enabled function. Below is a simple example:
+
+<<code-clus1>>=
+clusfun <- function(x, filename="", ...) {
+
+ out <- raster(x)
+
+ cl <- getCluster()
+ on.exit( returnCluster() )
+
+ nodes <- length(cl)
+
+ bs <- blockSize(x, minblocks=nodes*4)
+ pb <- pbCreate(bs$n)
+
+ # the function to be used (simple example)
+ clFun <- function(i) {
+ v <- getValues(x, bs$row[i], bs$nrows[i])
+ for (i in 1:length(v)) {
+ v[i] <- v[i] / 100
+ }
+ return(v)
+ }
+
+ # get all nodes going
+ for (i in 1:nodes) {
+ sendCall(cl[[i]], clFun, i, tag=i)
+ }
+
+ filename <- trim(filename)
+ if (!canProcessInMemory(out) & filename == "") {
+ filename <- rasterTmpFile()
+ }
+
+ if (filename != "") {
+ out <- writeStart(out, filename=filename, ... )
+ } else {
+ vv <- matrix(ncol=nrow(out), nrow=ncol(out))
+ }
+ for (i in 1:bs$n) {
+ # receive results from a node
+ d <- recvOneData(cl)
+
+ # error?
+ if (! d$value$success) {
+ stop('cluster error')
+ }
+
+ # which block is this?
+ b <- d$value$tag
+ cat('received block: ',b,'\n'); flush.console();
+
+ if (filename != "") {
+ out <- writeValues(out, d$value$value, bs$row[b])
+ } else {
+ cols <- bs$row[b]:(bs$row[b] + bs$nrows[b]-1)
+ vv[,cols] <- matrix(d$value$value, nrow=out at ncols)
+ }
+
+ # need to send more data?
+ ni <- nodes + i
+ if (ni <= bs$n) {
+ sendCall(cl[[d$node]], clFun, ni, tag=ni)
+ }
+ pbStep(pb)
+ }
+ if (filename != "") {
+ out <- writeStop(out)
+ } else {
+ out <- setValues(out, as.vector(vv))
+ }
+ pbClose(pb)
+
+ return(out)
+}
+@
+
+To use snow with raster, you need to set up a cluster first, with 'beginCluster' (only once during a session). After that we can run the function:
+
+<<code-clus2>>=
+r <- raster()
+# beginCluster()
+r[] <- ncell(r):1
+# x <- clusfun(r)
+# endCluster()
+@
+
+\end{document}
diff --git a/vignettes/rasterfile.Rnw b/vignettes/rasterfile.Rnw
new file mode 100644
index 0000000..e2bd46c
--- /dev/null
+++ b/vignettes/rasterfile.Rnw
@@ -0,0 +1,141 @@
+\documentclass{article}
+
+
+%\VignetteIndexEntry{Description of the rasterfile format}
+
+\SweaveOpts{keep.source=TRUE}
+
+\begin{document}
+
+
+\title{The 'rasterfile' format}
+\author{Robert J. Hijmans}
+\maketitle
+
+
+\section{Introduction}
+
+The '\verb at raster@' package has a default 'native' file format called 'rasterfile'. This file format is used because it is simple, flexible and extensible and does not require rgdal, which may be difficult to install. The '\verb at raster@' package can read and write other formats via the '\verb at rgdal@' package.
+
+The rasterfile format is highly similar to many other formats used for raster data. It consists of two files. One file with sequential binary values (filename extention is '.gri'), and one header file (filename extension is '.grd'). The main source of variation between such file formats is in the header file, and the contents of the rasterfile header file are described here.
+
+The purpose is to standardize the format and help others to read and write files of the same format if they wish to do so. This vignette is aimed at software developers. The typical user of the '\verb at raster@' package does not need to be familiar with it.
+
+\section{ini files}
+
+The header ('.grd') file is organized as an '.ini' file. This is a simple database format that is subdivided in sections indicated with brackets '[]'. Within each section there are variables and their values seperated by the equal '=' sign.
+
+Thus, .ini files have a layout like this:
+
+[section1]
+var1=value
+
+var2=value
+
+[section2]
+
+var3=value
+
+var4=value
+
+
+Variables names must be unique within a section, but the same variable name could occur in multiple sections. This is not done for raster files (variable names are unique) such that section names could be ignored. The '\verb at raster@' package has a convenient function, {\bf readIniFile}, to read .ini files.
+
+
+\section{Sections}
+
+The rasterfile ini format has four sections (general, georeference, data, legend, description) that are discussed below
+
+\subsection{general}
+This section has two variables, 'creator' and 'created'. For example:
+
+[general]
+
+creator=R package 'raster'
+
+created= 2010-03-13 17:26:34
+
+These are metadata that are useful but not strictly required.
+
+\subsection{georeference}
+This section has the number of rows (nrows) and columns (ncols), and describes the spatial extent (bounding box) with four variables (xmin, xmax, ymin, ymax), and the coordinate reference system (projection). These variables are obviously required.
+
+The number of rows and columns are integers >= 1. The extent variables are numeric with xmin < xmax and ymin < ymax. The coordinates refer to the extremes of the outer cells (not to the centers of these cells).
+
+Resolution (cell size) is not specified (it should be derived value from the extent and the number of columns and rows).
+
+The coordinate reference system is specified with the variable 'projection'. Its value should be a string with the PROJ4 syntax. This value can be missing, but that is not recommended!
+
+[georeference]
+
+nrows=100
+
+ncols=100
+
+xmin=-180
+
+ymin=-90
+
+xmax=180
+
+ymax=90
+
+projection=+proj=longlat +datum=WGS84
+
+
+\subsection{data}
+This subsection has information about the file type as well as the cell values. Here is an example
+
+[data]
+
+datatype=FLT4S
+
+nodatavalue=-3.4e+38
+
+byteorder=little
+
+nbands=3
+
+bandorder=BIL
+
+minvalue=1:0:5
+
+maxvalue=255:200:255
+
+
+
+datatype is required. Its values must be one of 'LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT8S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S'.
+The first three letters indicate the type of number that is stored (logical, integer, or float). The fourth character determines how many bytes are used to store these. The last letter inidcates, if applicable, whether the values are singed or not (i.e. whether negative values are possible).
+
+nodatavalue is optional (but necessary if there are nodata (NA) values). It can be any value. But in the raster package the lowest possible value is used for signed integer and float data types and the highest integer is used for unsigned integer types (this is to avoid using 0 as the nodata value).
+
+byteorder is optional but recommended. It should be either 'big' or 'little'. If absent, the raster package assumes that the platform byte order is used.
+
+nbands is required. It indicates the number of layers (bands) stored in the file and hence its values should be an integer >= 1. If absent, the raster package assumes it is 1.
+
+bandorder is required if nbands > 1 and ignored when nbands=1. Values can be 'BIL' (band interleaved by line), 'BIP' (band interleaved by pixel) and 'BSQ' (band sequential). BIL is recommended for most cases.
+
+minvalue and maxvalue indicate the minimum or maximum value in the each layer (excluding NA). If there are mulitple layers, the value are seperated by a colon.
+
+If the values are integers representing a class (e.g. land cover types such as 'forest', 'urban', 'agriculture') four additional keys are required to indicate that these are categorical data and to provide three columns for a 'Raster Attribute Table'. In this case there are three variables (ID, landocver and code). ID refers to the actual cell value, the following are attributed linked to these values. rattypes describe the data type. ID and would normally be 'integer'. Other values allo [...]
+
+categorical=TRUE
+
+ratnames=ID:landcover:code
+
+rattypes=integer:character:numeric
+
+ratvalues=1:2:3:Pine:Oak:Meadow:12:25:30
+
+
+
+\subsection{description}
+
+This section only has the layer names. As above, these are separated by colons. Therefore, colons are not allowed in the layer names. If they occur, they could be replaced with at dot '.'.
+
+[description]
+
+layername=red:green:blue
+
+
+\end{document}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-raster.git
More information about the debian-med-commit
mailing list