raster/0000755000176200001440000000000014742252332011556 5ustar liggesusersraster/tests/0000755000176200001440000000000014507510157012721 5ustar liggesusersraster/tests/tinytest.R0000644000176200001440000000013114507510157014722 0ustar liggesusers if ( requireNamespace("tinytest", quietly=TRUE) ){ tinytest::test_package("raster") } raster/MD50000644000176200001440000006541314742252332012077 0ustar liggesusers58ebf3b3795e6883b4ce447e77308bcc *DESCRIPTION d66a84574cd91d32c37ed8a4f10d706d *NAMESPACE 8dcbed71a3de20745a92b411189e0398 *NEWS 8cc868c6b5aefe4c2d43d28df06ede95 *R/AAAClasses.R 2ad39a4b357fad908e9568c87f2c892a *R/AAgeneric_functions.R bdd38fe1ee6177b894741b0d2f7779b0 *R/GDALtransient.R e9be7d6f6093d51eb006adcc3ff6f5be *R/Geary.R fe01bec82c22c54a2ffa4d8ddddd6855 *R/RGB.R df3f3ecf9b19d54e06065502e34a0764 *R/RcppExports.R c51935729854642e8cbd6a51e4b7eccd *R/addFiles.R f78c7ce654675617fced68c54a511024 *R/addLayer.R 7e8f2597647a57a1a151f618f7fe9290 *R/adjacency.R a6f85067ab105536e60cbf3d74a9962e *R/adjacent.R 789b01453c33327c1b6af37bfbe58bfe *R/aggregate_3d.R 3aef05d1312d25646dfb9911d409ed24 *R/aggregate_sp.R 6b9e5faf768bcbbacad11d17e9961250 *R/alignExtent.R a2b9797ace151bf46f5ec612f80b7270 *R/animate.R 16d9da4e472f2ae5128eaaca57f3d84e *R/approxNA.R 7e389eb50ff7ef26fc6c8bc697258ea5 *R/area.R bbed25b501e68958aed4ac898568ba23 *R/arith.R cc52079cb4feeb5dd1564c4582ccd83e *R/arith_sp.R cd4df8e3b1e1de9ccdacbfe2b9cfe26f *R/as.array.R 362aee0cb00a7c0f02c2e9e0f3bb5996 *R/as.character.R dbb997a9c1a0832b8faf62c995a8df2f *R/as.data.frame.R b83216d0c661886a5f3b795b18725de6 *R/as.logical.R 5b794e08cf5c430b9b53abdfdc32f613 *R/as.matrix.R 87a80da41628a2dc00503f87a930eb42 *R/as.raster.R f09b9a34fda9e88e8822352b88c589a6 *R/as.spatial.R 32427756619914f282a37ec8d3bdb68e *R/atan2.R 74df13a8c6f109c219b020a34e3faaca *R/bands.R 5d878edcaaf951bb8cb113b9fd38a731 *R/barplot.R e53330cd88710f53cca710b92aecabbd *R/bbox.R 8d0910b435b2dd11caaf30f55521c9c9 *R/bilinearValue.R 55996ae7d0edb3b00973b05e05de3f43 *R/bind.R 8e408927e0e6a5803e75ea60af7d7d6a *R/blend.R 1229aa69975f7aa2b67b8fa1e2d1aaf4 *R/blockSize.R 8f7c2f9d11395eee21ba25b18a168bf3 *R/boundaries.R 703f82b94094b789d8197ce2073f06df *R/boxplot.R 2668c61e147dee61ad524e9c12c8fb12 *R/brick.R 5db46386258dc5701dfc9675e0c0d80f *R/buffer.R 347753f9c53dc707896afede7f588354 *R/calc.R 40daef4f755f53c7009e60e88807318a *R/canProcessInMemory.R 2677c4ead9323299ca5d6a37b9e46c1f *R/cellFromLine.R b4c2b52babc61b0cea524298e9c53f53 *R/cellFromPolygon.R beeeb5b74571c0a2bc8df2c7df025c38 *R/cellRowCol.R a919953d7fd8890698c0b83e53c4a402 *R/cellStats.R 96913e2acad82027f029c512e59d33c6 *R/cellValues.R 94cee21eaa23a6ebafe63ff224443e15 *R/cellsFromExtent.R a923bbded975e2e9310c9347341e5935 *R/clamp.R 5a3b23c88d2843a3e09ba21e3da20760 *R/clearValues.R aa25fdab6a595011f6fce25d025a44fd *R/click.R 9795a18891818eb4f1a1ba68dfe26c7e *R/clump.R 42f4ce4c4c63b11e53075a31b0c13ceb *R/clusterR.R 211d03d38c6df560db7394443e6b663f *R/coerce.R 64718da05b72235575db2b4a9c5c23a7 *R/col2RGB.R bf4d69cac9d779c34c8ea0c35fcefec6 *R/colortable.R a11cba46329452f8813d48eebceefb32 *R/commonDataType.R 418b0aaab08e7f3af11c0d04e066a8b0 *R/compare.R 401d6087406938ecc7aaa3d58953f35d *R/compareCRS.R 9b3dc2715fd3105f3da0ce9a79e0a45d *R/compare_Logical.R 35f4db1ce9e083ef9b3786842b453681 *R/connection.R ef5effb9e013341247a4fe8bd3e47a7a *R/contour.R b54d7e4e9b31c6075615f45bf8304915 *R/cor.R 953caa71000a0fb4889d8cc6bc2e41ab *R/corLocal.R bbc8681c9461635f15b1b965eb609c08 *R/cover.R 8204fd77d30f32df54ca8f5b55a8688a *R/coverBrick.R aebb6384cbbbf47486a33b61fe576b8d *R/coverPolygons.R aef3601f556a5c009ad9245deab3d9a0 *R/crop.R 2e9bad7e9079b9c8ec839c33d4b8fc97 *R/cropSpatial.R 3e3ea90a3cc24fe2e2e7223371124732 *R/crosstab.R 9febb856577bfbef35d40632f050b3c2 *R/cut.R 39462dfa3794b8860497a72121108825 *R/cv.R d2088612a4c3b76b4c1409e6433414a2 *R/dataProperties.R fce0a585eb60252ca07d1a8641d28b79 *R/dataType.R 29df00fbb45f13d863ee88d9027df7ea *R/density.R aab0d72ad0bd3b0f9a11f7b68627ed6e *R/destair.R 37ce1eb45febcae0212bb3dd1d971731 *R/dim.R 19e5d47f2a8cc0a5e443d088c69c6e80 *R/direction.R 70e8936672cb1bb85ff7799f19372375 *R/disaggregate.R 0c96fa2470e1408a74fc24b6829182e9 *R/distance.R f38618128176ff52b77fad41c780f9ad *R/distanceFromPoints.R e0501aa78e2d837b3939a6056accb671 *R/distanceRows.R e36ee96215a7f7e6b602674076e5b899 *R/distanceToEdge.R 0adbef47d9d6f345aed342b2c57299c6 *R/dotdens.R 547cf183130685d67af207251bc5c594 *R/drawExtent.R 694a3526a7177f28c913b40863eb9175 *R/drawPoly.R 4217378f859c2b61a5e5b2e283525c59 *R/drivers.R abd25e3b1b3dd6bc67bfa17f9af4a44d *R/dropLayer.R a558ea54d7effa1fc673864fc523eb0a *R/erase.R 9518955d37c71d791d9c92381de3a9e2 *R/extend.R 8ecfd7be89623b38d9159e6a3ca9dbc3 *R/extension.R 4ac894034adace1dbe307f908ef382f4 *R/extent.R 113d601affb77cb5fac96cfc541590fd *R/extentUnion.R f5835b58cd079b37c9743e11b0ea6ae4 *R/extract.R 0baebbdfa2754f989ce7ed4099a890c2 *R/extractExtent.R 33ce64a38c87515519d0c46e7a1df30b *R/extractLines.R 173838317b7f92c1e34cc69b8cbaedb9 *R/extractPoints.R 99b7073c741eb7a7149bab528fb4b715 *R/extractPoints_sp.R cb5f680f596f1d7a2e2460ad28cc8baa *R/extractPolygons.R 5924c8bd8f4de97895665d4212abc0d6 *R/factor.R ced51495b35ddfd6f3cf6d4eed84da1a *R/fasterize.R ac2798eb848a610fee8159d7f80b3ca1 *R/filler.R f66383989c35322c0f67b18ac5a61e78 *R/fixDBFnames.R a4199e55ff641dad69227df0cb954413 *R/flip.R d1dcb179d3099d7fb36765e5061cbe70 *R/flowpath.R 754e1c069503256d7e5f70c6a94b2b72 *R/focal.R d9e423f2f087717358a143b3e3783182 *R/focalFun.R 39b150a3849e88fccf9f2079ebfe114c *R/focalWeight.R 5e20afddf7023000a05e26aa2c69742d *R/fourCellsFromXY.R 09a1535c1676be195510d41af716a474 *R/frbind.R 1b16b6a48cd1736713d73d9afae7204d *R/freq.R 0fc481f1a2b13a75ad18a7a1bc18e0f8 *R/fullFileName.R 2524eedbd9fb8d8305e647d711ae58c9 *R/gainoffset.R df748c28cef50ea3cbb394c0cdf37c7a *R/gdal.R e287001bfef2ccf762ba8bc699a472ce *R/gdalFormats.R 1ae7377892ef1ed123d059a662685317 *R/geom.R 318989174d8d8f761e1b5ec13031fab9 *R/getData.R c5b10dfa091157a1e06cf895770d1855 *R/getValues.R 19e6b95c32096e06597017822aa0196b *R/getValuesBlock.R 56e8aa51ba1f14da020d9b7ca2bf3b74 *R/getValuesFocal.R 54fba0bab24ce860b1bfffb3ebbc8373 *R/getValuesRows.R be02b7dba9297ce29c3f7be4fc08bf40 *R/gridDistance.R 08e867073b352c0d40e1d010f2aeaab4 *R/gridDistance2.R 307cbdce2d470849f6db371e37955e4d *R/hdr.R 881d2def4fe536acabe68ededfa7f89a *R/hdrBIL.R 0e4c4eb367e1c5ea5dc29d0e58de33da *R/hdrBov.R 40c57e6dd6fc9fbe6ea85f1e2a7b2957 *R/hdrEnvi.R fc25d54f57671b8dccb6101abd399c42 *R/hdrErdasRaw.R 6cefc7d393a6d927e6a455371c217fba *R/hdrIDRISI.R 23d88b4fdf0a63f7e84ea6fc533f2f94 *R/hdrPRJ.R baab4f8f25972031aefadbf40995dc2f *R/hdrRaster.R 17f18f8b2c8397122599ea183f331bc7 *R/hdrSAGA.R 497d9b6b1be765c1205872557bacd851 *R/hdrVRT.R 3bc4fb6a1e5214ba795544701cc47555 *R/hdrWorldFile.R 8bb9bef933f5b55642b48e263e2cb559 *R/head.R c3fe1b1abb2c95d149f3128a11397e04 *R/hillShade.R aa30cd82f9c58d0cd8120df6008d5543 *R/hist.R 8371f37d36958b5b3c4976c11620ee21 *R/idwValue.R c738e101d3842b0368dbb727abc156e8 *R/ifelse.R 073c7f2d822210ad7ae48aa95f1b5720 *R/image.R 2f64b4b173dae4e7fa869be04d502cdc *R/imageplot.R 2b1cc24c7c71ae4bce890e14cbd73ae1 *R/imageplot2.R 3da8458a1b1b5632c94e3b29c77c6a18 *R/index.R 912413c378f229629f4b908cb273ea26 *R/indexReplace.R 9ca5ef6a3e39a86242bde964e19c5092 *R/indexReplaceBrick.R 4bd700e14d459eb3d7ff7822452b553e *R/inifile.R 75f7176063ce0e87d18cc5f43f559faa *R/init.R dc741a0f1e83bdf0b5cf9debf4f5ee6e *R/intDataType.R a81ab526fd0e5ea72dbdd492f1b057e7 *R/interpolate.R dc4b3f8b96fd32090d35abe4ad5041b4 *R/intersect.R b41a43a8b9cfecb6012e05b8c2bb1f12 *R/intersect_sp.R 24a728cd03c8d0329c8684096b0e9be6 *R/is.na.R 6258c4619144dcb352df76cba1b28f0b *R/isLonLat.R 99218468dc41649a4ca8d9bf458ac9b0 *R/kernelDens.R 9a22a08812d5ec34bc054b8573e3f47d *R/kernelDensity.R aa4646ec28f45cf0050be53d3801b98c *R/kml.R d3945880430f12d7854215d60c663528 *R/kml_multiple.R 5bb95b7ca0bfdf4e5a30f4384ae1b426 *R/labels.R 4ac2a785232349a5520632676bdac0e3 *R/layerStats.R ceef0b028f19bb8ed50ac753a1becfa5 *R/layerize.R 40425b9bd8dc0ad58fe855c7c72813c5 *R/localFun.R 0eafbadb487800caae5f1dfc3305aa03 *R/makeProjString.R 500cca436f2b2a61cc01f9b818b21bce *R/makeRasterList.R ea301a6d7f47d650163628113c4cb2e8 *R/makeTiles.R 55eff58ff5cfda39a1056585b13ad6e4 *R/mask.R 3c2ba9fe977a570c9c6ef9c18e742d22 *R/match.R 1e6b8a1dd2a1e9f2c96e98bcfed50ff7 *R/math.R a67444cce8d3e8822291af72803d8700 *R/maxDataType.R 2a705a467653576955d05a02fb6a8b07 *R/mean.R 7b0c35190fadaf02898f816af5beded7 *R/median.R ce66ad9fbe5e3bf8ad63512c62042497 *R/merge.R 97cb04589727f7bd14b4415be50cfeec *R/metadata.R 5f6415d1178ef70f1e0505fc93ebce23 *R/minValue.R ac047a32b240c25bf9bd56c76e7778a8 *R/modal.R fb4dd829e7cb53ac3a9c50c0e7fbe992 *R/modalRaster.R 6fb7120010fdb597521a946a786dd99a *R/moran.R c9efde827f7ed0059a6eeb1e5ce8a7c4 *R/mosaic.R 2740b9caec2b9c3dfb0d830f2c4eeb0f *R/movingFun.R bb31c0c2988b37ade71a1dfb4ead82a4 *R/multiCore.R 0fa95802bbe583a98ef8b05ab26d437c *R/naValue.R 9783b474008796951411c3cf620ca838 *R/names.R 46e642d1f3f4b47b2475d746302c7cee *R/ncell.R 6f39b9e80c25107a64c456e9699f844a *R/netCDFread.R 0b45255587a112c6a11a9a83eebdfff8 *R/netCDFreadCells.R 39424fbff1c06380467fe0ba5bef912e *R/netCDFtoRasterCD.R 6689657ec2f6ee8f452d8518c85048f5 *R/netCDFtoRasterGMT.R e3d175453f106a173c6468aac9d8b221 *R/netCDFtoStack.R 9d390903127668d44bd0e8d8a28f58fd *R/netCDFutil.R e47ad4d2dbf446eba4ece542c54fd519 *R/netCDFwriteCD.R 37522b26afb24d01cfa59da00bff77be *R/newPLot.R a237e75cc8df7a7dd461de127c7edd3e *R/nlayers.R 41009ec66bcfc072b8b48b2a1024b4e8 *R/notused.R 1fb86b3fb6557e92d8ca95a413d3b4e6 *R/nsidcICE.R 497d7eba342ff2f9aa0b78a1db726096 *R/origin.R 8968e03f253f1d3c01a25f1026fa8c9a *R/overlay.R 97a017630cfa9d395e99ebfe731d0a11 *R/pairs.R 4c65f9f931268f894993b5c2178a9c62 *R/persp.R f7271e23bdd9a81b642f70e3084dd619 *R/plot.R e77957ceac177fcdbf120b363640515d *R/plot2rasters.R b5bbe22b29653076ee1852bd4d76b2e6 *R/plotCT.R 6b60d543ecf727768ad0bf172169ae1d *R/plotExent.R 5e4f8cfef82350ed75a7549eb6ab6232 *R/plotRGB.R dc6ed749ed85dbbb3bf861df9e07cd96 *R/plotRaster.R 4be6cdc2e5e1ba93a9795767180409c1 *R/plotRaster2.R 635a0c0267733918b2fe4e816743417c *R/pointdistance.R beff5e80db5f57fd70eb476d87a3d32e *R/predict.R 316ebd38ac20fc87bc176d00e8cc1cca *R/print.R ab68164b12c9c658b155e3d59c8289ad *R/progressBar.R d01f731a51c9800321c7bb9489612ff0 *R/project.R 9c1a57f334e06ddffd4d6354b9b13b34 *R/projectRaster.R 648c2a0e4846c15a6deca7651adf11bc *R/projection.R 3ce8fd020413e71202f1e29de8604a01 *R/properties.R c126b01a725630014b349313fb3a8bde *R/quad.R 95b29f77d650c98773a298f50be12238 *R/quantile.R e33733f012e4c0301210c3507da2b1b9 *R/randomize.R 556aaf7db457486cb7df6897f1c8ad4e *R/range.R aa4f50e0ff7535d01d4b54208d052799 *R/raster.R a2055ed091243612e7808add0efca0bc *R/rasterFromASCII.R cc61a03d30a2ea21038f583739ef2824 *R/rasterFromBIL.R 3d507ee8905b1d9a6ecbc693c1b00230 *R/rasterFromCells.R d8f4dab32e4a6c4d5e2afe0a57484155 *R/rasterFromFile.R fa7b12069744eb66d8683a4f6cc362ae *R/rasterFromGDAL.R 2185c54b649441070057362c1e74405f *R/rasterFromIDRISI.R 0697310be1e94ae77f795174f4aa55ce *R/rasterFromRasterFile.R f4187c536c35a1d94c20a147ea3f522b *R/rasterFromSAGA.R fe883680e25c30f78844496145fda25c *R/rasterFromSurferFile.R 3130ed17d8815398351678e515db275e *R/rasterFromXYZ.R bf1cb43b9b8338265f8451c6a01807c0 *R/rasterOptions.R 298c4e8a7ae4c8b6f3723ff795f0041c *R/rasterToPoints.R a854f83acef2f67ae5566d1d27180702 *R/rasterToPolygons.R 7b1a27950892e65174eecb4a41d44618 *R/rasterize.R 6b455faaa8d7f3a29a80b863c08e30ce *R/rasterizeLines.R 9c656156ba644c6cdcbaa9f670f6d3b5 *R/rasterizePoints.R eca9f76afe04df7a034cff4a0007e5cd *R/rasterizePointsNGB.R a0971e5f84e67d1903a3ac04c10ca6f5 *R/rasterizePolygons.R db5df9e924e6a2caf0bd583519234366 *R/ratify.R 80a9f55b0da0b61ac3f66f19b2589312 *R/read.R e5eeba12c0546889b643d4ec145ce954 *R/readAscii.R 32948efe78d1dbe42c0288875d40b387 *R/readCells.R d610efd44d68c3f622f3ac35a20aaa45 *R/readCellsGDAL.R 201109e98f245874b33bb7a6b6bf2a9d *R/readRasterBrick.R 7319f7bc45a8e1cd4c873bb542cae51a *R/readRasterLayer.R 8fa239227c10246f83a9162dcf92fe79 *R/reclassify.R fa3842b61535a885f8eb44beea6efff9 *R/rectify.R c27defa5a0b27e5c300d67a17a1be896 *R/replaceProperties.R 3fa5839eb6b372a5ce83c4e38f899a5f *R/resample.R 88a304f110fb4f83e4a1cb4620155f88 *R/rotate.R 571417a2a9793d45077191c84473cb7d *R/roundExtent.R 573794d457d36a832dbfb451a82af5a8 *R/rowMinMax.R 18eb3406a1b503284216d1ca0f760e64 *R/rowSums.R 59726f7b671039716613249f231b0b21 *R/sampleAlong.R e0f01fc658ffba0b898dc426d96fecd5 *R/sampleInt.R 841fc96f4e58b5fd3e4a0a3d5b63566b *R/sampleRandom.R c9562c996d5190998dad979871eb0cd1 *R/sampleRegular.R b57e0570ee534df86ba31b32cc4a23fa *R/sampleStratified.R 6fd6b5c97e52efab9b522c9d8e069d83 *R/scale.R f8faed753d78fd16836ab2c09c2a6308 *R/scalebar.R 3f4382c069da429eaba7c1f6d9bb788a *R/select.R babf7319fc1ab8c04bf41a2ca00b84a2 *R/setCV.R 59067a91c201d1c5098ecb0dabf5bf6b *R/setExtent.R 0c7c890c3b230288d88d6f1886c07757 *R/setFileExt.R 995a3f23cea1eddd994573710c8b2967 *R/setMinMax.R 24540d989aceff87ab7d6f7808793932 *R/setValues.R 2d35b076ab7eacc338e085e5480f319d *R/setZ.R 4fca6993f025fb373802369b5dbe5f6c *R/sf.R 6f4df31a7896b1146a236d5208111438 *R/shift.R 7cb15422812be261a1e817b8ac6908a2 *R/show.R b4e8c63e2249b3412db59bca9db33169 *R/shp.R 128d259b66c03bb66ff890a0342a58a9 *R/simplifyPols.R a83a743bf981620346965e0992dbd1be *R/slopeAspect.R d4ab936465aacdad621923b19ba876d9 *R/sparse.R db3a11bb5f115fcd9ec93ac93d129433 *R/speasy.R 9c4a8a932b8c0eb4a73ce7c2fffbfd3e *R/spplot.R d6ebdb1fd4de9dc9eb585002d7508e4d *R/srs.R c76df8ec8dc8d29ad97de6026eac2639 *R/stack.R 3bf2e85974e58af70238df250c8bd8b1 *R/stackApply.R b6539f806e3cbfc726bbc74ba3d719be *R/stackFile.R c6438e8abdb940280a0fd75bd50fa42b *R/stackQuick.R 3d60c8f76cbd872ed7fe383bb6e62f13 *R/stackSelect.R ad6d0e028ef8b3427b20f1a91b4595c3 *R/stretch.R e8d4816c11c4bdc2301c73fe169b24a5 *R/subs.R 5d7a6a263b8fc3d86eb534acd991bf77 *R/subset.R bb48a95ed4207a6f2dd5d85a0968f43e *R/summary-methods.R c29ac521281a8e3b30eede2164671b03 *R/summary.R 70337cf2275fb920fb2da9e373085e14 *R/symdif.R aff72d6d95bc0e8170fd7c9cffc77e0c *R/terrain.R 98dd435f8c493809b86c6cec486401ce *R/text.R 87e667948fe1fe82d189e516b3adb597 *R/tmpFile.R d6efcadaa4810cc2f63a187b49004eb0 *R/transpose.R 2281687a5cba53b8bb6faffc44c1acc5 *R/trim.R d922cf1148ba27dc424473c40b6d20b5 *R/union.R e885f0d79d5c62d7bf2e7c3ee93f40d9 *R/union_sp.R 02ef2c0bb782c1846716f6f5b13383b3 *R/unique.R c84710d9519e0a02d129aec1f5acee5a *R/unstack.R 116bfa2086b56340afffb25a2ed26dcd *R/update.R 91f4b83b6a65f9c8e97859f142e3794a *R/validCell.R 3803832478502b4ac61d5c2390e5624a *R/values.R 05b6a1e101f0604ed4b9ed77096fcf9d *R/weighted.mean.R dba02134d6b62c2a7a45e1c8f3b4855f *R/which.R 1e7b2ca654f61ee038caee4240502ab0 *R/which.max.R d491f4a320eca9c0492159e1af236894 *R/whiches.max.R 326d8c64f703d11c8a73927b2b60d7ab *R/writeAllAscii.R 420475b13f5f379840dbccd46027a130 *R/writeAllGDAL.R a321dcb2a3233d4f4a0c2f28164b81f7 *R/writeAllRaster.R 63056e8f9aa5e12e1756129db1622360 *R/writeRaster.R 6b8f3699942545055604fb07840ea82c *R/writeStartStop.R 42ac06c70c37349c13a2f373fe3cd305 *R/writeStartStopAscii.R 2b8cc77c4a7661ee5c2f5efd6e05494f *R/writeStartStopGDAL.R 911c3ded9e17fddf71166fdef1de3787 *R/writeStartStopRaster.R de31eba8750c6037d0361f458f5d9181 *R/writeValues.R 5be486ce39ef552e142e72632ac6b1dc *R/xyCell.R 0eb07acac214834163b216c338aa9d72 *R/xyMinMax.R 3c908ce2647fd927f4a4c4d4419e456a *R/xyResolution.R dfe961c20842808597dc8b76765685db *R/xyValuesBuffer.R d9397fdb238463ae0c9929aad0347658 *R/zApply.R b9cc0e22fcbdd704f6199fecaf8a4382 *R/zonal.R 227cc9e91a64d5685fc5f6eeac885ee2 *R/zoom.R cae0440f702e35b1a156006c63c84a0b *R/zzz.R 1dda19015f0aa969acee990c150e3ac9 *build/partial.rdb 836fc2bffa338d9f9a721e00d9cd6078 *inst/external/countries.rds c85d689dcf4c7101db48cbab30338201 *inst/external/lux.dbf e729936bf5360b37a15365fc295a1901 *inst/external/lux.prj c6fbaf5566eecb7bb8538e818f9a79d8 *inst/external/lux.rds 4ae2847099f7574e36516738dc411a0f *inst/external/lux.shp 5d6304a3bc11ffe01ffdda30514d15df *inst/external/lux.shx 0ff613aebb15fdf2bc0da2945bae874a *inst/external/rlogo.grd b3ed7227bb04142c4a36cbe25067d5ac *inst/external/rlogo.gri 92e7d96043d934c23d2ebab93c560c77 *inst/external/test.grd cb22d2072ca597b022e481bb86f9f989 *inst/external/test.gri 50ea0d3c36e5a46c239a220ac26f654c *inst/tinytest/test_getvaluesblock.R 4e570bcb00705c47cc82605cd2da2282 *inst/tinytest/test_rasterize.R 6bc63247c1a5c4a98fe3d45831332565 *inst/tinytest/test_sf-coercion.R 5e8be4c45ed0f3d02bf1c863fe8e823e *inst/tinytest/test_subset.R 2a511d2025ac23a550c359677d32b049 *inst/tinytest/test_wkt_grd.R c05f06da76f4a94136c5f8e84af67576 *inst/tinytest/tinytest.R f869def93bd156864dc1c177a0011c58 *man/Arith-methods.Rd 283cd94b7132f736f737548410c08467 *man/Compare-methods.Rd d6075d8d52377f3ade673813dbbd542b *man/Extent-class.Rd 97b4c605d6486afac9102a092b6c380e *man/KML.Rd e4aec17e97093ad758ffb96ea74d4c69 *man/Logic-methods.Rd 61564b898e845c41f202b39df9a21cba *man/Math-methods.Rd 2cc408f5443433750f9e34745b536f34 *man/NAvalue.Rd 3d7d83c4b98da4cbed294dc052d28fa4 *man/RGB.Rd 45b3b44cd1a23e61691917b65f9e02b3 *man/Raster-classes.Rd cd28d6c0f6917c1bf17c7d628aee3894 *man/Rcpp-classes.Rd 0b2da8d4dcec3056eb9fc67456081e3a *man/Summary-methods.Rd 06828671e2cbb873d6439288f4212d45 *man/addLayer.Rd cb636b0edba455724fc681c10726d5af *man/adjacent.Rd 0bbbf9ee98db991e7705824c9784651d *man/aggregate.Rd 0f62d928e427ccc4fb1ee9b6ec8957ce *man/alignExtent.Rd 28de086318b7555483572fd0cb758a69 *man/animate.Rd 0c0384a7882a562183a863976baf9bf4 *man/approxNA.Rd bf5ce3b05d450bf9cffcf469b905d564 *man/area.Rd b364be87c40450752f5f1a478cb395e9 *man/as.character.Rd 8062557b94159e445163b56125481b9b *man/as.data.frame.Rd 6be688294a4ff43863e3f0bc3cf1a536 *man/as.list.Rd 03f4061c0c0e7bce8c10f51d614307bb *man/as.logical-methods.Rd 2fe17ad82f342842760fb7867aa1ecd9 *man/as.matrix.Rd 75b90d79c07f953cc940fdcac673fd3b *man/as.raster.Rd 95fd5d812707d63ceefc8a9fa1fb3e56 *man/atan2.Rd 2394cb70e6e5dc447173ee4274af7b46 *man/autocor.Rd 1984df98cabf511b0ad3a000756e6257 *man/bands.Rd 49bc3723d6e62a44b7371582e36efe76 *man/barplot.Rd 7f67941276d0fbf7a2a4eaa9fd742094 *man/bind.Rd fcc2bb4d47e38bdb9406a904642749c0 *man/blockSize.Rd 675d75fff94bc04499b87b6d4c6ddcf9 *man/boundaries.Rd 403ff7de739838bb2fc3abc006f8588f *man/boxplot.Rd 552ff45a9338e0ca1f81422e0670d2fd *man/brick.Rd 37546cb514d6f9d8f1a208e4becc2739 *man/buffer.Rd 66f46609480e1630b3669dfa3a83eb67 *man/calc.Rd ad113eba9aada8c98055ba54e0eb5724 *man/cellFrom.Rd c18fa0a99b061e225f4c2e2a208575ab *man/cellStats.Rd ac218ddd40708fa6e1c9ac96016df147 *man/cellsFromExtent.Rd ce76904bf4fe03a9285b3fdbf7e34dae *man/clamp.Rd 0b5f3f6fce5041c673aa2eceeae8efd9 *man/clearValues.Rd 9e05c09671347dea87f44dcbed7141ef *man/click.Rd 89e91fa0857eee8fc5284ebfa2cf06b7 *man/clump.Rd 7abf528077005f095bffa36135e7f83e *man/cluster.Rd 05e1e53f9d2a2d200d6e0d31594fc4c7 *man/colortable.Rd 8390e3e76463d494d591700b91742604 *man/compare.Rd 8705d77c88137133855e4b8b65b6dc39 *man/compareCRS.Rd 922e70da80d0b198560fb42cfa10dd37 *man/contour.Rd dfc057f1ce49943386699d679d6908b5 *man/coords.Rd c86918f6608326b7e130dbf095598f43 *man/corLocal.Rd 0051f36120a94e60c85df58dd49750c7 *man/cover.Rd 17834b741e83c8c8a517b336163fedf7 *man/crop.Rd 153ddd104ed70bd02131e287952e842b *man/crosstab.Rd 575b974047dfb6e596eba5b84e4651bc *man/cut.Rd d0e1da12e2347a83cedf3667e0845ff3 *man/cv.Rd 118791b87a0f2ed3c12c92172617c015 *man/dataType.Rd c63a717785954fabcd68ec28b0315965 *man/datasource.Rd 33a8ba9f98a677c3571d79ed51802681 *man/density.Rd 781320b867b3e70b7d01b9baac40158b *man/dimensions.Rd 18f0b13a23b562374aae8584026eabe2 *man/direction.Rd 54a222f5c53563163d94b02aae4f424a *man/disaggregate.Rd ef1cea825eafaf333bbf519349043851 *man/distance.Rd d1c9d9872296ecdba2d86136d37f026b *man/distanceFromPoints.Rd a2211ba5968a68c6332a20c252057b6f *man/draw.Rd 31de133300723567aa98d97c7f61d0c2 *man/drawExtent.Rd 587cff60675ec7df1f0ef5560cc39d0e *man/erase.Rd 6925d6bc7957b6b87db4f1358a9a1587 *man/extend.Rd 3e1812cd7ab432f6c489d0a379b71e6f *man/extension.Rd a62d75d75a5463b705c677bef1f9f8c6 *man/extent.Rd 8f98c76fea3fb9a5123f93dab458c476 *man/extract.Rd 2fb4b5d1bbd2b58d86eb07b85bd5fea0 *man/extractIndex.Rd 4992ec4f3c4cf67fc729cfdfd14c235e *man/extremeValues.Rd 476d2a9a163fabd07529ee6e3517d845 *man/factor.Rd cf0ace2e5707b7d89d9aa96ec57738d0 *man/filename.Rd 463a6b2caa318781e6a030b59b2deca2 *man/filledContour.Rd b9098ce59e09b07421a1357d7aae82e9 *man/flip.Rd 14d2375c57ea64975a664a3edaea16de *man/flowpath.Rd a377c61fd6a34877273a510ab4666112 *man/focal.Rd 8bff48a2dd87fed0f0fe9925a403c411 *man/focalWeight.Rd bf4e4b4fed61e6736bc2431c3170d7cb *man/freq.Rd 6c9ea2d96231490cbcb98073aa0c6ab0 *man/gainoffset.Rd 949934a51c6e89070e1fee9294f3d83f *man/geom.Rd f783eb3bd185383708e9c489cc6d3b55 *man/getData.Rd 513b858bb6a9ab24eedd6eb2b5f75eb6 *man/getValues.Rd 772a6d5a8788870e3d080d30b8215e65 *man/getValuesBlock.Rd 1d2d02b7b6d01609620e99c9e4698324 *man/getValuesFocal.Rd 1e4b75fab3932c064d4ea45eeafb28a1 *man/gridDistance.Rd 99f6d8e81767134d112ed6cad5def120 *man/hdrFiles.Rd 67c344771513764f6a310712cd7d8964 *man/headtail.Rd a9654f73a56bd8639af3931e94d5c3ae *man/hillShade.Rd 122e387fd0d4562d493b3c31bd1072d4 *man/hist.Rd 163dde188853a5fb7d982077926457c6 *man/image.Rd 79abf72046372d5e62cbdb3b1afc27bb *man/iniFile.Rd 996d6a49b6d443cb45ed06e61603dcd5 *man/init.Rd 5b32b9473915f12a9ef5453a98faf2c6 *man/interpolate.Rd bacfd6052130ff9682a3daee25a6ad65 *man/intersect.Rd db652e2dd8d3e133bfaee972f78fe525 *man/isLonLat.Rd 73aae88051662c55ee959d9e84fed23e *man/layerStats.Rd 991023cf0704b9506af17d70ac10de28 *man/layerize.Rd 656b18e1e34cca52c2ffa7b507c34e45 *man/localFun.Rd 427bcbd566627352b4ca5776e116496c *man/mask.Rd 2465e8507c634ec7b0a195675a3eeaca *man/match.Rd b8ac838914856726a57c8fa8b2ddc228 *man/merge.Rd 356c82c8bbba4c42a1a84b4dc3480c5a *man/metadata.Rd ee98fb55e393c66c1870ee5b4561f842 *man/modal.Rd 7bcc53c5e6dcbd99ab54f7b49c67cc4a *man/mosaic.Rd a308cc58790b3f3b0a3ab81887df35a1 *man/movingFun.Rd fd1f5d5a6846b95b4094b8ca73cbc49a *man/names.Rd a735bfe56077c285b00311d1d84e8647 *man/ncell.Rd 1b5c2a6c3b2bfa19f51ab0eba26bf718 *man/nlayers.Rd c0aeaba3008ac17c21b69175835394ff *man/origin.Rd d83c6d10e7b826f81a9e6db0cfdc3c45 *man/overlay.Rd f5def9c7d1b9cf6eceec3dc0e563f2ac *man/pairs.Rd 2e012a886766e535c8495fadb7b698d1 *man/persp.Rd 8baad000228108b873a147cef94d4e59 *man/plot.Rd d0f3efa9f7d10694c7a0d9dcc36ef81c *man/plotRGB.Rd 0eb656c153bf2e7482a66ba50a4c586b *man/pointDistance.Rd d56396125595888dc90d53015b0a4f02 *man/predict.Rd 32cee2aa8565d03396a060991e5ef2ba *man/programming.Rd bc10b6371999e39d3849bd647641ab57 *man/projectRaster.Rd 1caf0fe099e717237998bc76b0197b40 *man/projection.Rd 9cfab780186321ff86fc11a25c7ebd2c *man/properties.Rd 11c6a58182a86dceea216a0b5043ec22 *man/quantile.Rd 10dd019a488d8f66c74af961032dea51 *man/raster-package.Rd dcdc942173d4152eeb736c6379f2cb55 *man/raster.Rd ab6c9c74ebd8d520d9e2e30d91c3cacb *man/rasterFromCells.Rd 618d1612c39114a43c92ca22582ebec7 *man/rasterFromXYZ.Rd 7ec73005cc36387bd149cd52f8625e24 *man/rasterOptions.Rd f77cb54fdef697309433d9066cdc7960 *man/rasterTmpFile.Rd fe479c2d51949866e2fbc6078c0a8b8f *man/rasterToContour.Rd e56492892fc210038a2c0c9311e47773 *man/rasterToPoints.Rd e4b4e10ac6e4b3bed602cca7b4f92e7d *man/rasterToPolygons.Rd e573620fb1d8294cdfa9fda44516d4b8 *man/rasterize.Rd ede30e9e24f62a4a6e88912acb5b259a *man/readAll.Rd da6e4153121f3b39b955c2cb207aa50d *man/reclassify.Rd 4f1842b2e97d657692c19863e81c1b51 *man/rectify.Rd c722bb86aef0e2afad89ee434763fbef *man/replacement.Rd 1c5a930f434fbe0934cc35f4783eef20 *man/resample.Rd 4b026c7a4bf3008a2a163a3e43ec1af4 *man/resolution.Rd 27164d5fb8d479a6bff1d061fc7e07bc *man/rotate.Rd 09ed7c259616efb1d65fa81409a84230 *man/rotated.Rd 4589c9d0a6552f89097824898b2be25d *man/round.Rd 6b51f96e062fd37a805337923767ed55 *man/roundExtent.Rd 3e22fed6060d342894407412109e231b *man/rowFromCell.Rd 71d6897790170f64aa5582a53464b645 *man/rowSums.Rd f30213aaa2464feedd5951f5cc77bea8 *man/sampleInt.Rd b4e7e3d9d414255272834bdf8e2822fa *man/sampleRandom.Rd d462abe16e0b5aa815c52a2fc9acbcd8 *man/sampleRegular.Rd 23b901feecba228ef39b5b9f3e3b9216 *man/sampleStratified.Rd 8459520385ac259271dd8b193901e285 *man/saveStack.Rd 028410f5f22bf38aaad3749b27a4dbfc *man/scale.Rd 86fbace616c9ce3afc0d5fde23818c24 *man/scalebar.Rd d4500ecc5310c99274edc5cf7f926146 *man/select.Rd 2e10626115d140e2ff097a2a0a71d6a9 *man/setExtent.Rd 6c057c3f2e1a7ffc2507e4d01f0ee014 *man/setMinMax.Rd df22072579463f81f6eeb92071555471 *man/setValues.Rd 089f80b7605a087215562de5da631a42 *man/shapefile.Rd a868d80750c1a22d890f429620d3159a *man/shift.Rd 14027fd3405fd99a33cad5dbdcef05ad *man/slopeAspect.Rd 1644ae093837b1c5c38b0dee3b624c2d *man/spEasy.Rd c542f4510fdef064e209069cb2c698aa *man/spplot.Rd f4d47f1611ebac1c4652289dd57550bb *man/stack.Rd 79f26b35c87bb4b64e5c50701ea8cbf9 *man/stackApply.Rd 6c49d520e4aead5cd297161b1b9f8dd8 *man/stackSelect.Rd 7cd3ee094ab41506473be99a913aa0b5 *man/strech.Rd 53b57dcc0a3a25e8a8e4162095969d31 *man/subs.Rd e1dc88aaa384c5d14b4bbc1b393fe923 *man/subset.Rd 03e63787f46fc69ee03cc5e3ffb5cae8 *man/summary.Rd 7cebc3ff0f84b9b08725f6173fbf6bf9 *man/symdif.Rd a14ff126872a6adced3ad700f1877769 *man/terrain.Rd 82a3a8e9c93e600e7e377e845cae05b5 *man/text.Rd 7a547a4dd038782eb213a0de1e7db06d *man/transpose.Rd 29f1f18187e8d9579a43f84a8f8cbf26 *man/trim.Rd 29487215d55d42da534d691ba0d2fc73 *man/union.Rd 923dd461246f987fe8abdcefa04452a5 *man/unique.Rd 2980f67475a05ff1ffa4800b4eecd253 *man/unstack.Rd bcab350a779bc466ccee3ae12314224f *man/update.Rd ffec69bf7eaa79778db0a8fddf6392aa *man/validCell.Rd cfa04ae792851194e2ec8a0ba4b1cb9e *man/validNames.Rd d1889453c7931e490cf2aaf2ba28531f *man/weighted.mean.Rd 7b9ef884a16bc5e3e5ffa55b5dc42378 *man/which.Rd 8125ce08149409cff1618107f48c412f *man/which.minmax.Rd b43c05afcf4e04cc1f52e02d19f65840 *man/writeFormats.Rd b0898af043a654220bdda9919ac4784f *man/writeRaster.Rd 390921ef5f028fc75fca375f01694684 *man/writeValues.Rd e33547777b8073609fd977ba55df848c *man/xyFromCell.Rd 9eade3e5aef7d8dcfee6c572a72c191c *man/zApply.Rd 5df589559aad01779f19513c02f5d7d9 *man/zonal.Rd c05ee07135abea3a5450733970a0f526 *man/zoom.Rd bfb9b462f50fdd221d69b37746f364d6 *man/zvalues.Rd fadffd1a59958998d5aa0a8ee4e44874 *src/RasterModule.cpp fe0e480c52c98688007d5ad4008b450e *src/RcppExports.cpp 169c17c28c95acb76ffb33ed01a06edf *src/aggregate.cpp ab6184e18df246510bfcb0f86b0d936d *src/aggregate.h 741e22173fba2f2928b30e204a59f0ef *src/bilinear.cpp e7912875e61e298a928371427a363db3 *src/broom.cpp 374a0ab9f7be016993bb20c602f0ab16 *src/cellRowCol.cpp 72ad5539eebfe0489d6f7cc1bb5cbe62 *src/clamp.cpp 08796267d48d3f61d95b58d0a908a997 *src/distance.cpp be72e268df1d536c022fb180556277d3 *src/distance.h b0188c0bd53304d33afaa134d49ec4cc *src/edge.cpp ba4c83076484833048d1a955a5f5f531 *src/focal_fun.cpp 0e8d74da363ce4d3694e47b1a241ea33 *src/focal_get.cpp 292b011b936b2d21a714a9cd186d427a *src/focal_sum.cpp 836471e9adb8148d6017751a9171a775 *src/geodesic.c b2030a9b42db643f6564cb3194b4544d *src/geodesic.h ddef60d0af91cb1fd0e994c69f2c7f82 *src/getPolygons.cpp 3ffac977e550f88ad3a26d3be3025d36 *src/layerize.cpp 3c4816bf723a1fbc5896895062af8642 *src/memory.cpp 8c9da6e32cc8145423a65c80eab2500e *src/memory.h 171dea5b0c4d0db0b3d2e689096d1da0 *src/modal.cpp 15d16970a4635bac1e9bf7a09393ef0f *src/ppmin.cpp 59e92c441aa707a80ac91c8204cd5b67 *src/raster_aggregate.cpp 4f6e7b0b8879a7cbe8f667e455eeffad *src/raster_distance.cpp 8cd6ef602e2ae21aa33bcc11ea4f026c *src/rasterize.cpp 51ba1081943eb2eca1945155990e2ef7 *src/reclass.cpp b9624288cf9e6e277eea0cd9ea83b2b0 *src/spat.h e4e6f9ef6da14024b9d3606f995b943f *src/terrain.cpp e8793d57c6405d2f688421d75ae5115d *src/util.cpp 02b3ab8677d52f791681845435a5252a *src/util.h 6eecc5a74b0d952ec5350934932ab19d *src/xyCell.cpp ee3095a3a08054b325cc92a21756d73a *tests/tinytest.R raster/R/0000755000176200001440000000000014533250215011753 5ustar liggesusersraster/R/extractLines.R0000644000176200001440000001560314507510157014555 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='SpatialLines'), function(x, y, fun=NULL, na.rm=FALSE, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, along=FALSE, sp=FALSE, ...){ #px <-.getCRS(x, asText=FALSE) px <-.getCRS(x) comp <- compareCRS(px,.getCRS(y), unknown=TRUE) if (!comp) { #.requireRgdal() warning('Transforming SpatialLines to the crs of the Raster object') y <- sp::spTransform(y, px) } if (missing(layer)) { layer <- 1 } if (missing(nl)) { nl <- nlayers(x) } if (!is.null(fun)) { cellnumbers <- FALSE along <- FALSE if (sp) { df <- TRUE } } else { if (sp) { sp <- FALSE warning('argument sp=TRUE is ignored if fun=NULL') } } if (along) { return(.extractLinesAlong(x, y, cellnumbers=cellnumbers, df=df, layer, nl, factors=factors, ...)) } spbb <- sp::bbox(y) rsbb <- bbox(x) addres <- 2 * max(res(x)) nlns <- length( y@lines ) res <- list() res[[nlns+1]] <- NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { if (df) { res <- matrix(ncol=1, nrow=0) colnames(res) <- 'ID' return(res) } else { return(res[1:nlns]) } } rr <- raster(x) cn <- names(x) pb <- pbCreate(nlns, label='extract', ...) if (.doCluster()) { .sendCall <- eval( parse( text="parallel:::sendCall") ) cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nlns, length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() parallel::clusterExport(cl, c('rsbb', 'rr', 'addres', 'cellnumbers'), envir=environment()) clFun <- function(i, pp) { spbb <- sp::bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # always TRUE? r <- .xyValues(x, xy, layer=layer, nl=nl) if (cellnumbers) { r <- cbind(cellFromXY(rr, xy), r) colnames(r) <- c('cell', cn) } } else { r <- NULL } } r } for (ni in 1:nodes) { .sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni) } for (i in 1:nlns) { d <- .recvOneData(cl) if (! d$value$success) { stop('cluster error at polygon: ', i) } res[[d$value$tag]] <- d$value$value ni <- ni + 1 if (ni <= nlns) { .sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni) } pbStep(pb) } } else { for (i in 1:nlns) { pp <- y[i,] spbb <- sp::bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (cellnumbers) { v <- cbind(cellFromXY(rr, xy), .xyValues(x, xy, layer=layer, nl=nl)) colnames(v) <- c('cell', cn) res[[i]] <- v } else { res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl) } } pbStep(pb) } } res <- res[1:nlns] pbClose(pb) if (! is.null(fun)) { i <- sapply(res, is.null) if (nlayers(x) > 1) { j <- matrix(ncol=nlayers(x), nrow=length(res)) j[!i] <- t(sapply(res[!i], function(x) apply(x, 2, fun, na.rm=na.rm))) colnames(j) <- names(x) } else { j <- vector(length=length(i)) j[i] <- NA j[!i] <- sapply(res[!i], fun, na.rm=na.rm) } res <- j } if (df) { if (!is.list(res)) { res <- data.frame(ID=1:NROW(res), res) } else { res <- data.frame( do.call(rbind, sapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) } lyrs <- layer:(layer+nl-1) if (cellnumbers) { colnames(res) <- c("ID", "cell", names(x)[lyrs]) } else { colnames(res) <- c("ID", names(x)[lyrs]) } if (any(is.factor(x)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } if (sp) { if (nrow(res) != nlns) { warning('sp=TRUE is ignored because fun does not summarize the values of each line to a single number') return(res) } if (!.hasSlot(y, 'data') ) { y <- sp::SpatialLinesDataFrame(y, res[, -1, drop=FALSE], match.ID=FALSE) } else { y@data <- cbind(y@data, res[, -1, drop=FALSE]) } return(y) } res } ) .extractLinesAlong <- function(x, y, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, ...){ spbb <- sp::bbox(y) rsbb <- bbox(x) addres <- 2 * max(res(x)) nlns <- length( y@lines ) res <- list() res[[nlns+1]] <- NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { if (df) { res <- matrix(ncol=1, nrow=0) colnames(res) <- 'ID' return(res) } else { return(res[1:nlns]) } } rr <- raster(x) cn <- names(x) pb <- pbCreate(nlns, label='extract', ...) y <- data.frame(geom(y) ) for (i in 1:nlns) { yp <- y[y$object == i, ] nparts <- max(yp$part) vv <- NULL for (j in 1:nparts) { pp <- yp[yp$part==j, c('x', 'y'), ] for (k in 1:(nrow(pp)-1)) { ppp <- pp[k:(k+1), ] spbb <- sp::bbox(as.matrix(ppp)) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { lns <- sp::SpatialLines(list(sp::Lines(list(sp::Line(ppp)), "1"))) rc <- crop(rr, extent(lns) + addres) rc <- .linesToRaster(lns, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] v <- cbind(row=rowFromY(rr, xy[,2]), col=colFromX(rr, xy[,1]), .xyValues(x, xy, layer=layer, nl=nl)) #up or down? updown <- c(1,-1)[(ppp[1,2] < ppp[2,2]) + 1] rightleft <- c(-1,1)[(ppp[1,1] < ppp[2,1]) + 1] v <- v[order(updown*v[,1], rightleft*v[,2]), ] #up <- ppp[1,2] < ppp[2,2] #right <- ppp[1,1] < ppp[2,1] # if (up) { # if (right) { # v <- v[order(-v[,1], v[,2]), ] # } else { # v <- v[order(-v[,1], -v[,2]), ] # } # } else { # if (!right) { # v <- v[order(v[,1], -v[,2]), ] # } # } vv <- rbind(vv, v) } } } if (cellnumbers) { vv <- cbind(cellFromRowCol(rr, vv[,1], vv[,2]), vv[,-c(1:2)]) colnames(vv) <- c('cell', names(x)) } else { vv <- vv[,-c(1:2)] if (NCOL(vv) > 1) { colnames(vv) <- names(x) } } res[[i]] <- vv pbStep(pb) } res <- res[1:nlns] pbClose(pb) if (df) { res <- data.frame( do.call(rbind, lapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) lyrs <- layer:(layer+nl-1) colnames(res) <- c('ID', names(x)[lyrs]) if (any(is.factor(x)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } res } raster/R/rasterFromIDRISI.R0000644000176200001440000000465614507510157015146 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromIDRISIFile <- function(filename, crs="", old=FALSE, ...) { if (old) { idformat <- 'IDRISIold' } else { idformat <- 'IDRISI' } valuesfile <- .setFileExtensionValues(filename, idformat) if (!file.exists(valuesfile )){ stop( paste(valuesfile, "does not exist")) } filename <- .setFileExtensionHeader(filename, idformat) ini <- readIniFile(filename, token=':') ini[,2] = toupper(ini[,2]) byteorder <- .Platform$endian nodataval <- -Inf layernames <- '' filetype <- '' for (i in 1:length(ini[,1])) { if (ini[i,2] == "MIN. X") {xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAX. X") {xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MIN. Y") {yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAX. Y") {yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MIN. VALUE") { minval <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAX. VALUE") { maxval <- as.numeric(ini[i,3]) } else if (ini[i,2] == "VALUE UNITS") { valunit <- ini[i,3] } else if (ini[i,2] == "ROWS") {nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "COLUMNS") {nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "DATA TYPE") {inidatatype <- toupper(ini[i,3]) } else if (ini[i,2] == "FILE TYPE") {filetype <- toupper(ini[i,3]) } else if (ini[i,2] == "FILE TITLE") {layernames <- ini[i,3] } else if (ini[i,2] == "FLAG VALUE") { suppressWarnings(nodataval <- try(as.numeric(ini[i,3], silent=TRUE))) if (!is.numeric(nodataval)) {nodataval <- -Inf} } } if (filetype=='PACKED BINARY') { stop('cannot natively read packed binary files') } # attempt could be made to decipher some of the idrisi crs descriptions x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) if (nchar(layernames) > 1) { # lnams <- unlist(strsplit(layernames, ':')) lnams <- layernames } else { lnams <- gsub(" ", "_", extension(basename(filename), "")) } names(x) <- lnams x@file@name <- filename x@data@min <- minval x@data@max <- maxval x@data@haveminmax <- TRUE if (inidatatype == 'BYTE') { dataType(x) <- 'INT1U' } else if (inidatatype == 'INTEGER') { dataType(x) <- 'INT2S' } else if (inidatatype == 'REAL') { dataType(x) <- 'FLT4S' } else { stop(paste('unsupported IDRISI data type:', inidatatype)) } x@file@nodatavalue <- nodataval x@data@fromdisk <- TRUE x@file@driver <- idformat return(x) } raster/R/show.R0000644000176200001440000002021314507510157013061 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod ('show' , 'Extent', function(object) { cat('class :' , class(object), '\n') cat('xmin :' , xmin(object), '\n') cat('xmax :' , xmax(object), '\n') cat('ymin :' , ymin(object), '\n') cat('ymax :' , ymax(object), '\n') } ) setMethod ('show' , 'BasicRaster', function(object) { cat('class :' , class(object), '\n') cat('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object),' (nrow, ncol, ncell)\n', sep="" ) cat('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat('crs :' , proj4string(object), '\n') } ) setMethod ('show' , 'RasterLayer', function(object) { cat('class :' , class(object), '\n') if (rotated(object)) { cat('rotated : TRUE\n') } if (nbands(object) > 1) { cat('band :' , bandnr(object), ' (of ', nbands(object), ' bands)\n') } cat('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object),' (nrow, ncol, ncell)\n', sep="" ) cat('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat('crs :' , proj4string(object), '\n') if (hasValues(object)) { fd <- object@data@fromdisk if (fd) { cat('source :', basename(filename(object)), '\n') } else { cat('source : memory\n') } cat('names :', names(object), '\n') if (object@data@haveminmax) { cat('values : ', minValue(object), ', ', maxValue(object), ' (min, max)\n', sep="") } } if (is.factor(object)) { x <- object@data@attributes[[1]] nc <- NCOL(x) # this can actually happen, but x should be a data.frame anyway #if (nc == 1) { # this should never happen # x <- data.frame(value=x) #} maxnl <- 12 if (nc > maxnl) { x <- x[, 1:maxnl] } #nfact <- sapply(1:ncol(x), function(i) is.numeric(x[,i])) if (nrow(x) > 5) { cat('attributes :\n') r <- x[c(1, nrow(x)), ,drop=FALSE] for (j in 1:ncol(r)) { r[is.numeric(r[,j]) & !is.finite(r[,j]), j] <- NA } r <- data.frame(x=c('from:','to :'), r) a <- colnames(x) colnames(r) <- c(' fields :', a) colnames(r) <- c('', a) rownames(r) <- NULL if (nc > maxnl) { r <- cbind(r, '...'=rbind('...', '...')) } print(r, row.names=FALSE) } else { cat('attributes :\n') print(x, row.names=FALSE) } } else { z <- getZ(object) if (length(z) > 0) { name <- names(object@z) if (is.null(name)) name <- 'z-value' name <- paste(sprintf("%-11s", name), ':', sep='') cat(name, as.character(z[1]), '\n') } if (object@file@driver == 'netcdf') { z <- attr(object@data, 'zvar') if (!is.null(z)) { cat('zvar :', z, '\n') } z <- attr(object@data, 'level') if (!is.null(z)) { if (z>0) { cat('level :', z, '\n') } } } } cat ('\n') } ) setMethod ('show' , 'RasterBrick', function ( object ) { cat ('class :' , class ( object ) , '\n') if (rotated(object)) { cat('rotated : TRUE\n') } mnr <- 15 nl <- nlayers(object) cat ('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object), ', ', nl, ' (nrow, ncol, ncell, nlayers)\n', sep="" ) #cat ('ncell :' , ncell(object), '\n') cat ('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat ('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat ('crs :' , proj4string(object), '\n') ln <- names(object) if (nl > mnr) { ln <- c(ln[1:mnr], '...') } if (hasValues(object)) { fd <- object@data@fromdisk if (fd) { cat('source :', basename(filename(object)), '\n') } else { cat('source : memory\n') } if (object@data@haveminmax) { minv <- format(minValue(object)) maxv <- format(maxValue(object)) minv <- gsub('Inf', '?', minv) maxv <- gsub('-Inf', '?', maxv) if (nl > mnr) { minv <- c(minv[1:mnr], '...') maxv <- c(maxv[1:mnr], '...') } n <- nchar(ln) if (nl > 5) { b <- n > 26 if (any(b)) { mid <- floor(n/2) ln[b] <- paste(substr(ln[b], 1, 9), '//', substr(ln[b], nchar(ln[b])-9, nchar(ln[b])), sep='') } } w <- pmax(nchar(ln), nchar(minv), nchar(maxv)) m <- rbind(ln, minv, maxv) # a loop because 'width' is not recycled by format for (i in 1:ncol(m)) { m[,i] <- format(m[,i], width=w[i], justify="right") } cat('names :', paste(m[1,], collapse=', '), '\n') cat('min values :', paste(m[2,], collapse=', '), '\n') cat('max values :', paste(m[3,], collapse=', '), '\n') } else { cat('names :', paste(ln, collapse=', '), '\n') } } z <- getZ(object) if (length(z) > 0) { name <- names(object@z) if (is.null(name)) name <- 'z-value' name <- paste(sprintf("%-11s", name), ':', sep='') if (length(z) < mnr) { cat(name, paste(as.character(z), collapse=', '), '\n') } else { cat(name, paste(as.character(range(z)), collapse=', '), '(min, max)\n') } } if (object@file@driver == 'netcdf') { z <- attr(object@data, 'zvar') if (!is.null(z)) { cat('varname :', z, '\n') } z <- attr(object@data, 'level') if (!is.null(z)) { if (z>0) { cat('level :', z, '\n') } } } cat ('\n') } ) setMethod ('show' , 'RasterStack', function ( object ) { cat ('class :' , class ( object ) , '\n') if (rotated(object)) { cat('rotated : TRUE\n') } mnr <- 15 if (filename(object) != '') { cat ('filename :' , filename(object), '\n') } nl <- nlayers(object) if (nl == 0) { cat ('nlayers :' , nl, '\n') } else { cat ('dimensions : ', nrow(object), ', ', ncol(object), ', ', ncell(object), ', ', nl, ' (nrow, ncol, ncell, nlayers)\n', sep="" ) #cat ('ncell :' , ncell(object), '\n') cat ('resolution : ' , xres(object), ', ', yres(object), ' (x, y)\n', sep="") cat ('extent : ' , object@extent@xmin, ', ', object@extent@xmax, ', ', object@extent@ymin, ', ', object@extent@ymax, ' (xmin, xmax, ymin, ymax)\n', sep="") cat ('crs :' , proj4string(object), '\n') ln <- names(object) if (nl > mnr) { ln <- c(ln[1:mnr], '...') } n <- nchar(ln) if (nl > 5) { b <- n > 26 if (any(b)) { ln[b] <- paste(substr(ln[b], 1, 9), '//', substr(ln[b], nchar(ln[b])-9, nchar(ln[b])), sep='') } } minv <- minValue(object) if (all(is.na(minv))) { cat('names :', paste(ln, collapse=', '), '\n') } else { minv <- format(minv) maxv <- format(maxValue(object)) minv <- gsub('NA', '?', minv) maxv <- gsub('NA', '?', maxv) if (nl > mnr) { minv <- c(minv[1:mnr], '...') maxv <- c(maxv[1:mnr], '...') } w <- pmax(nchar(ln), nchar(minv), nchar(maxv)) m <- rbind(ln, minv, maxv) # a loop because 'width' is not recycled by format for (i in 1:ncol(m)) { m[,i] <- format(m[,i], width=w[i], justify="right") } cat('names :', paste(m[1,], collapse=', '), '\n') cat('min values :', paste(m[2,], collapse=', '), '\n') cat('max values :', paste(m[3,], collapse=', '), '\n') } } z <- getZ(object) if (length(z) > 0) { name <- names(object@z) if (is.null(name)) name <- 'z-value' if (name == '') name <- 'z-value' name <- paste(sprintf("%-12s", name), ':', sep='') if (length(z) < mnr) { cat(name, paste(as.character(z), collapse=', '), '\n') } else { z <- range(z) cat(name, paste(as.character(z), collapse=' - '), '(range)\n') } } cat ('\n') } ) setMethod ('show' , '.RasterList', function(object) { cat('class :' , class(object), '\n') cat('length : ', length(object), '\n', sep="" ) } ) raster/R/bands.R0000644000176200001440000000122014507510157013165 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("bandnr")) { setGeneric("bandnr", function(x, ...) standardGeneric("bandnr")) } setMethod('bandnr', signature(x='RasterLayer'), function(x) { return(x@data@band) } ) nbands <- function(x) { if (inherits(x, "RasterLayer") | inherits(x, "RasterBrick")) { return(x@file@nbands) } else { stop(paste("not implemented for", paste(class(x), collapse=", "), "objects")) } } .bandOrder <- function(x) { if (inherits(x, "RasterStack")) { stop(paste("not implemented for RasterStack objects")) } else { return(paste(x@file@bandorder)) } } raster/R/extractPoints.R0000644000176200001440000000642514507510157014761 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='matrix'), function(x, y, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, ...){ .xyValues(x, y, method=method, buffer=buffer, small=small, cellnumbers=cellnumbers, fun=fun, na.rm=na.rm, layer=layer, nl=nl, df=df, factors=factors, ...) }) setMethod('extract', signature(x='Raster', y='data.frame'), function(x, y, ...){ return( .xyValues(x, as.matrix(y), ...)) }) setMethod('extract', signature(x='Raster', y='SpatialPoints'), function(x, y, ..., df=FALSE, sp=FALSE){ #px <-.getCRS(x, asText=FALSE) px <-.getCRS(x) comp <- compareCRS(px,.getCRS(y), unknown=TRUE) if (!comp) { #if (!.requireRgdal()) { # warning('CRS of SpatialPoints and rater do not match') #} else { warning('Transforming SpatialPoints to the crs of the Raster') y <- sp::spTransform(y, px) #} } if (sp) { v <- .xyValues(x, sp::coordinates(y)[,1:2,drop=FALSE], ..., df=TRUE) if (!.hasSlot(y, 'data')) { y <- sp::SpatialPointsDataFrame(y, v[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, v[, -1, drop=FALSE]) } return(y) } else { .xyValues(x, sp::coordinates(y)[,1:2,drop=FALSE], ..., df=df) } }) .xyValues <- function(object, xy, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, sp=FALSE, ...) { nlyrs <- nlayers(object) if (nlyrs > 1) { if (missing(layer)) { layer <- 1 } if (missing(nl)) { nl <- nlyrs } layer <- min(max(1, round(layer)), nlyrs) nl <- min(max(1, round(nl)), nlyrs-layer+1) } else { layer <- 1 nl <- 1 } if (dim(xy)[2] != 2) { stop('xy should have 2 columns only.\nFound these dimensions: ', paste(dim(xy), collapse=', ') ) } if (! is.null(buffer)) { if (method != 'simple') { warning('method argument is ignored when a buffer is used') } res <- .xyvBuf(object, xy, buffer, fun, na.rm, layer=layer, nl=nl, cellnumbers=cellnumbers, small=small) } else if (method == 'bilinear') { res <- .bilinearValue(object, xy, layer=layer, n=nl) if (cellnumbers) { warning("'cellnumbers' does not apply for bilinear values") cellnumbers = FALSE } } else if (method=='simple') { cells <- cellFromXY(object, xy) res <- .cellValues(object, cells, layer=layer, nl=nl) if (cellnumbers) { res <- cbind(cells, res) if (ncol(res) == 2) { colnames(res)[2] <- names(object)[layer] } } } else { stop('invalid "method" argument. Should be simple or bilinear.') } if (df) { if (is.list(res)) { res <- lapply(1:length(res), function(x) if (length(res[[x]]) > 0) cbind(ID=x, res[[x]])) res <- do.call(rbind, res) rownames(res) <- NULL } else { res <- data.frame(cbind(ID=1:NROW(res), res)) } lyrs <- layer:(layer-1+nl) if (cellnumbers) { cn <- c('ID', 'cells', names(object)[lyrs]) } else { cn <- c('ID', names(object)[lyrs]) } colnames(res) <- cn if (any(is.factor(object)) & factors) { v <- res[, -1, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(object, v[,1], layer)) } else { v <- .insertFacts(object, v, lyrs) } res <- data.frame(res[,1,drop=FALSE], v) } } res } raster/R/getValuesBlock.R0000644000176200001440000000777314507510157015033 0ustar liggesusers # Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("getValuesBlock")) { setGeneric("getValuesBlock", function(x, ...) standardGeneric("getValuesBlock")) } setMethod('getValuesBlock', signature(x='RasterStack'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) { stopifnot(hasValues(x)) stopifnot(row <= x@nrows) stopifnot(col <= x@ncols) stopifnot(nrows > 0) stopifnot(ncols > 0) row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 nlyrs <- nlayers(x) if (missing(lyrs)) { lyrs <- 1:nlyrs } else { lyrs <- lyrs[lyrs %in% 1:nlyrs] if (length(lyrs) == 0) { stop("no valid layers selected") } nlyrs <- length(lyrs) x <- x[[lyrs, drop=FALSE]] } startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) nc <- ncol(x) res <- matrix(ncol=nlyrs, nrow=nrows * ncols) inmem <- sapply(x@layers, function(x) x@data@inmemory) if (any(inmem)) { if (col==1 & ncols==nc) { cells <- startcell:lastcell } cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol) } for (i in 1:nlyrs) { xx <- x@layers[[i]] if ( inMemory(xx) ) { res[,i] <- xx@data@values[cells] } else { res[,i] <- .readRasterLayerValues(xx, row, nrows, col, ncols) } } colnames(res) <- names(x) res } ) setMethod('getValuesBlock', signature(x='RasterBrick'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) { stopifnot(hasValues(x)) row <- max(1, round(row)) col <- max(1, round(col)) stopifnot(row <= x@nrows) stopifnot(col <= x@ncols) nrows <- min(round(nrows), x@nrows-row+1) ncols <- min((x@ncols-col+1), round(ncols)) stopifnot(nrows > 0) stopifnot(ncols > 0) nlyrs <- nlayers(x) if (missing(lyrs)) { lyrs <- 1:nlyrs } else { lyrs <- lyrs[lyrs %in% 1:nlyrs] if (length(lyrs) == 0) { stop("no valid layers") } nlyrs <- length(lyrs) } if ( inMemory(x) ){ lastrow <- row + nrows - 1 if (col==1 & ncols==x@ncols) { rnge <- cellFromRowCol(x, c(row, lastrow), c(1, ncol(x))) res <- x@data@values[rnge[1]:rnge[2], , drop=FALSE] } else { lastcol <- col + ncols - 1 res <- x@data@values[cellFromRowColCombine(x, row:lastrow, col:lastcol), , drop=FALSE] } if (NCOL(res) > nlyrs) { res <- res[, lyrs, drop=FALSE] } colnames(res) <- names(x)[lyrs] } else if ( fromDisk(x) ) { res <- .readRasterBrickValues(x, row, nrows, col, ncols) if (NCOL(res) > nlyrs) { res <- res[, lyrs, drop=FALSE] } } else { # no data res <- ( matrix(rep(NA, nrows * ncols * nlyrs), ncol=nlyrs) ) colnames(res) <- names(x)[lyrs] } return(res) } ) setMethod('getValuesBlock', signature(x='RasterLayer'), function(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), format='', ...) { row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) if (!(validRow(x, row))) { stop(paste(row, 'is not a valid rownumber')) } if ( inMemory(x) ) { if (col==1 & ncols==ncol(x)) { res <- x@data@values[startcell:lastcell] } else { cells <- cellFromRowColCombine(x, row:lastrow, col:lastcol) res <- x@data@values[cells] } } else if ( fromDisk(x)) { res <- .readRasterLayerValues(x, row, nrows, col, ncols) } else { # no values res <- rep(NA, nrows * ncols) } if (format=='m') { res <- matrix(res) } else if (format=='matrix') { res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE ) colnames(res) <- col:lastcol rownames(res) <- row:lastrow } res } ) raster/R/clusterR.R0000644000176200001440000001160714507510157013713 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 clusterR <- function(x, fun, args=NULL, export=NULL, filename='', cl=NULL, m=2, ...) { if (is.null(cl)) { cl <- getCluster() on.exit( returnCluster() ) } if (!is.null(export)) { parallel::clusterExport(cl, export) } .sendCall <- eval( parse( text="parallel:::sendCall") ) nodes <- length(cl) out <- raster(x) m <- max(1, round(m)) tr <- blockSize(x, minblocks=nodes*m ) if (tr$n < nodes) { nodes <- tr$n } tr$row2 <- tr$row + tr$nrows - 1 pb <- pbCreate(tr$n, label='clusterR', ...) if (!is.null(args)) { stopifnot(is.list(args)) clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) getValues(r) } } for (i in 1:nodes) { .sendCall(cl[[i]], clusfun, list(fun, i), tag=i) } if (canProcessInMemory(x)) { for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { print(d$value$value) stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } res <- matrix(NA, nrow=ncell(out), ncol=nl) } j <- d$value$tag res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } pbClose(pb) return(out) } else { for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } out <- writeStart(out, filename=filename, ...) } out <- writeValues(out, d$value$value, tr$row[d$value$tag]) ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- writeStop(out) pbClose(pb) return(out) } } .clusterR2 <- function(x, fun, args=NULL, filename='', cl=NULL, m=2, ...) { if (is.null(cl)) { cl <- getCluster() on.exit( returnCluster() ) } nodes <- length(cl) out <- raster(x) m <- max(1, round(m)) tr <- blockSize(x, minblocks=max(nodes+1, nodes*m)) nodes <- min(nodes, tr$n-1) tr$row2 <- tr$row + tr$nrows - 1 pb <- pbCreate(tr$n, label='clusterR', ...) canPiM <- canProcessInMemory(x) .sendCall <- eval( parse( text="parallel:::sendCall") ) if (!is.null(args)) { stopifnot(is.list(args)) if (canPiM) { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- do.call(fun, c(r, args)) writeValues(out, getValues(r), tr$row[i]) return(i) } } } else { if (canPiM) { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) getValues(r) } } else { clusfun <- function(fun, i) { r <- crop(x, extent(out, r1=tr$row[i], r2=tr$row2[i], c1=1, c2=ncol(out))) r <- fun(r) writeValues(out, getValues(r), tr$row[i]) return(i) } } } if (canPiM) { for (i in 1:nodes) { .sendCall(cl[[i]], clusfun, list(fun, i), tag=i) } for (i in 1:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { stop('cluster error') } if (i ==1) { nl <- NCOL(d$value$value) if (nl > 1) { out <- brick(out, nl=nl) } res <- matrix(NA, nrow=ncell(out), ncol=nl) } j <- d$value$tag res[cellFromRowCol(out, tr$row[j], 1):cellFromRowCol(out, tr$row2[j], ncol(out)), ] <- d$value$value ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } pbClose(pb) return(out) } else { r <- crop(x, extent(out, r1=tr$row[1], r2=tr$row2[1], c1=1, c2=ncol(out))) r <- fun(values(r)) nl <- NCOL(r) if (nl > 1) { out <- brick(out, nl=nl) } out <- writeStart(out, filename=filename, ...) out <- writeValues(out, r, 1) for (i in 1:nodes) { .sendCall(cl[[i]], clusfun, list(fun, i+1), tag=i+1) } for (i in 2:tr$n) { pbStep(pb, i) d <- .recvOneData(cl) if (! d$value$success ) { stop('cluster error') } ni <- nodes + i if (ni <= tr$n) { .sendCall(cl[[d$node]], clusfun, list(fun, ni), tag=ni) } } out <- writeStop(out) pbClose(pb) return(out) } } raster/R/xyCell.R0000644000176200001440000001100314507510157013336 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 setMethod("yFromRow", signature(object="Raster", row="missing"), function(object, row) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } row=1:nrow(object) ymax(object) - ((row-0.5) * yres(object)) } ) setMethod("yFromRow", signature(object="Raster", row="numeric"), function(object, row) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } row <- round(as.vector(row)) row[row < 1 | row > object@nrows] <- NA ymax(object) - ((row-0.5) * yres(object)) } ) .yFromRow <- function(object, rownr) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } ymax(object) - ((rownr-0.5) * yres(object)) } setMethod("xFromCol", signature(object="Raster", col="numeric"), function(object, col=1:ncol(object)) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } col <- round(as.vector(col)) col[col < 1 | col > object@ncols] <- NA xmin(object) + (col - 0.5) * xres(object) } ) setMethod("xFromCol", signature(object="Raster", col="missing"), function(object, col=1:ncol(object)) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } col=1:ncol(object) xmin(object) + (col - 0.5) * xres(object) } ) .xFromCol <- function(object, colnr) { if (rotated(object)) { stop('this function is not supported for rotated rasters') } xmin(object) + (colnr - 0.5) * xres(object) } setMethod("cellFromXY", signature(object="BasicRaster", xy="ANY"), function(object, xy) { if (inherits(xy, 'SpatialPoints')) { xy <- sp::coordinates(xy)[,1:2,drop=FALSE] x <- xy[,1] y <- xy[,2] } else if (is.null(dim(xy))) { x <- xy[1] y <- xy[2] } else { x <- xy[,1] y <- xy[,2] } if (rotated(object)) { cr <- object@rotation@transfun(xy, inv=TRUE) cell <- (cr[,2]-1) * object@ncols + cr[,1] } else { cell <- .doCellFromXY( object@ncols, object@nrows, object@extent@xmin, object@extent@xmax, object@extent@ymin, object@extent@ymax, x, y) } return(cell) } ) setMethod("colFromX", signature(object="BasicRaster", x="numeric"), function ( object, x ) { # from pre-generic # if (inherits(x, 'Spatial')) { # x <- x@coords[,1] # } if (rotated(object)) { stop('this function is not supported for rotated rasters') } colnr <- trunc((x - xmin(object)) / xres(object)) + 1 colnr[ x == xmax(object) ] <- object@ncols colnr[ x < xmin(object) | x > xmax(object) ] <- NA return(as.vector(colnr)) } ) setMethod("rowFromY", signature(object="BasicRaster", y="numeric"), function(object, y) { # from pre-generic # if (inherits(y, 'Spatial')) { # y <- y@coords[,2] # } if (rotated(object)) { stop('this function is not supported for rotated rasters') } rownr <- 1 + (trunc((ymax(object) - y) / yres(object))) rownr[y == ymin(object) ] <- object@nrows rownr[y > ymax(object) | y < ymin(object)] <- NA return(as.vector(rownr)) } ) setMethod("xyFromCell", signature(object="BasicRaster", cell="ANY"), function(object, cell, spatial=FALSE, ...) { if (rotated(object)) { xy <- object@rotation@transfun( cbind(x=colFromCell(object, cell), y=rowFromCell(object, cell)) ) } else { e <- object@extent xy <- .doXYFromCell( object@ncols, object@nrows, e@xmin, e@xmax, e@ymin, e@ymax, cell ) dimnames(xy) <- list(NULL, c("x", "y")) } if (spatial) { xy <- sp::SpatialPoints(stats::na.omit(xy), crs(object)) } return(xy) } ) if (!isGeneric("coordinates")) { setGeneric("coordinates", function(obj, ...) standardGeneric("coordinates")) } setMethod("coordinates", signature(obj="Raster"), function(obj, ...){ xyFromCell(obj, cell=1:ncell(obj), ...) } ) setMethod("coordinates", signature(obj="Extent"), function(obj, ...){ e <- as.vector(obj) rbind(cbind(e[1], e[3:4]), cbind(e[2], e[4:3])) } ) setMethod("yFromCell", signature(object="Raster",cell="numeric"), function(object, cell) { if (rotated(object)) { xy <- xyFromCell(object, cell) return(xy[,2]) } else { rows <- rowFromCell(object, cell) return( .yFromRow(object, rows) ) } } ) setMethod("xFromCell", signature(object="Raster",cell="numeric"), function(object, cell) { if (rotated(object)) { xy <- xyFromCell(object, cell) return(xy[,1]) } else { cols <- colFromCell(object, cell) return( .xFromCol(object, cols) ) } } ) raster/R/plot.R0000644000176200001440000000762114507510157013067 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod("plot", signature(x='Raster', y='ANY'), function(x, y, maxpixels=500000, col, alpha=NULL, colNA=NA, add=FALSE, ext=NULL, useRaster=TRUE, interpolate=FALSE, addfun=NULL, nc, nr, maxnl=16, main, npretty=0, ...) { hasNoCol <- missing(col) if (hasNoCol) { col <- rev(terrain.colors(255)) } if (!is.null(alpha)) { if (inherits(alpha, 'RasterLayer')) { if (!compareRaster(x, alpha)) { alpha <- NULL } } else { alpha <- pmax(pmin(alpha, 1), 0) if (length(alpha) == 1) { alpha <- alpha * 255 + 1 a <- c(0:9, LETTERS[1:6]) alpha <- paste(rep(a, each=16), rep(a, times=16), sep='')[alpha] col <- paste(substr(col, 1, 7), alpha, sep="") alpha <- NULL } } } nl <- nlayers(x) if (nl == 0) { stop('Raster object has no cell values') } if (nl == 1) { if (inherits(x, 'RasterStackBrick')) { x <- raster(x, 1) } facvar <- 0 if (!missing(y)) { if (is.factor(x)) { facvar <- max(y, 0) } } if ( (length(x@legend@colortable) > 0) & hasNoCol) { .plotCT(x, maxpixels=maxpixels, ext=ext, interpolate=interpolate, main=main, add=add, addfun=addfun, ...) } else if (! useRaster) { .plotraster(x, col=col, maxpixels=maxpixels, add=add, ext=ext, main=main, addfun=addfun, ...) } else { .plotraster2(x, col=col, maxpixels=maxpixels, add=add, ext=ext, interpolate=interpolate, colNA=colNA, main=main, addfun=addfun, facvar=facvar, alpha=alpha, npretty=npretty, ...) #.plot2(x, col=col, maxpixels=maxpixels, ...) } return(invisible(NULL)) } if (missing(main)) { main <- names(x) } if (missing(y)) { y <- 1:nl if (length(y) > maxnl) { y <- 1:maxnl } } else { if (is.character(y)) { y <- match(y, names(x)) } y <- unique(as.integer(round(y))) y <- stats::na.omit(y) } if (length(y) == 1) { x <- raster(x, y) if ( (length(x@legend@colortable) > 0) & hasNoCol) { .plotCT(x, maxpixels=maxpixels, ext=ext, interpolate=interpolate, main=main[y], addfun=addfun, ...) } else if (useRaster) { .plotraster2(x, col=col, colNA=colNA, maxpixels=maxpixels, main=main[y], ext=ext, interpolate=interpolate, addfun=addfun, , alpha=alpha, ...) } else { .plotraster(x, col=col, maxpixels=maxpixels, main=main[y], ext=ext, addfun=addfun, ...) } } else { nl <- length(y) if (missing(nc)) { nc <- ceiling(sqrt(nl)) } else { nc <- max(1, min(nl, round(nc))) } if (missing(nr)) { nr <- ceiling(nl / nc) } else { nr <- max(1, min(nl, round(nr))) nc <- ceiling(nl / nr) } old.par <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(old.par)) graphics::par(mfrow=c(nr, nc), mar=c(2, 2, 2, 4)) xa='n' rown=1 coln=0 maxpixels=maxpixels/nl if (missing(main)) { main <- names(x) } for (i in 1:nl) { coln = coln + 1 if (coln > nc) { coln <- 1 rown = rown + 1 } if (rown==nr) xa='s' if (coln==1) ya='s' else ya='n' obj <- raster(x, y[i]) if ((length(obj@legend@colortable) > 0) & hasNoCol) { .plotCT(obj, maxpixels=maxpixels, ext=ext, interpolate=interpolate, main=main, addfun=addfun, ...) } else if (useRaster) { .plotraster2(obj, col=col, maxpixels=maxpixels, xaxt=xa, yaxt=ya, main=main[y[i]], ext=ext, interpolate=interpolate, colNA=colNA, addfun=addfun, alpha=alpha, ...) } else { .plotraster(obj, col=col, maxpixels=maxpixels, xaxt=xa, yaxt=ya, main=main[y[i]], ext=ext, interpolate=interpolate, addfun=addfun, ...) } } } return(invisible(NULL)) } ) setMethod("lines", signature(x='RasterLayer'), function(x, ...) { if(prod(dim(x)) < 50000) { stop('too many lines') } x <- as(x, 'SpatialPolygons') lines(x, ...) } ) setMethod("lines", signature(x='Extent'), function(x, ...) { plot(x, add=TRUE, ...) } ) raster/R/commonDataType.R0000644000176200001440000000142514507510157015031 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2011 # Version 1.0 # Licence GPL v3 .commonDataType <- function(dtype) { dtype <- as.vector(unlist(dtype, use.names = FALSE)) dtype <- unique(dtype) if (length(dtype)==1) { datatype <- dtype } else { dsize <- dataSize(dtype) dtype <- .shortDataType(dtype) if (any(dtype == 'FLT')) { dsize <- max(dsize[dtype=='FLT']) datatype <- paste('FLT', dsize, 'S', sep='') } else { signed <- dataSigned(dtype) dsize <- max(dsize) if (all(signed)) { datatype <- paste('INT', dsize, 'S', sep='') } else if (all(!signed)) { datatype <- paste('INT', dsize, 'U', sep='') } else { dsize <- ifelse(dsize == 1, 2, ifelse(dsize == 2, 4, 8)) datatype <- paste('INT', dsize, 'S', sep='') } } } datatype } raster/R/sampleInt.R0000644000176200001440000000170214507510157014037 0ustar liggesusers# Author: Robert J. Hijmans # Date : Febrary 2009 # Version 0.9 # Licence GPL v3 sampleInt <- function(n, size, replace=FALSE) { n <- round(n[1]) size <- round(size[1]) stopifnot(n > 0) stopifnot(size > 0) if (!replace) { switched <- FALSE done <- FALSE if (size > (0.66 * n)) { if (size > n ) { warning('size changed to n because it cannot be larger than n when replace is FALSE') size <- n } if (size == n) { done <- TRUE } switched <- TRUE size <- n - size } samp <- NULL while (! done) { f <- ceiling(stats::runif(size * 1.1) * n) samp <- unique(c(samp, f)) if (length(samp) >= size) { samp <- samp[1:size] done <- TRUE } } if (switched) { if (!is.null(samp)) { samp <- (1:n)[-samp] lsp <- length(samp) samp <- samp[sample.int(lsp)] } else { samp <- sample.int(n) } } } else { samp <- ceiling(stats::runif( size ) * n) } return( samp ) } raster/R/crosstab.R0000644000176200001440000000640214507510157013725 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 1.0 # Licence GPL v3 # revised April 2011 setMethod('crosstab', signature(x='Raster', y='Raster'), function(x, y, digits=0, long=FALSE, useNA=FALSE, progress='', ...) { x <- stack(x, y) crosstab(x, digits=digits, long=long, useNA=useNA, progress=progress, ...) } ) setMethod('crosstab', signature(x='RasterStackBrick', y='missing'), function(x, digits=0, long=FALSE, useNA=FALSE, progress='', ...) { nl <- nlayers(x) if (nl < 2) { stop('crosstab needs at least 2 layers') } nms <- names(x) if (canProcessInMemory(x)) { res <- getValues(x) res <- lapply(1:nl, function(i) round(res[, i], digits=digits)) res <- do.call(table, c(res, useNA='ifany')) res <- as.data.frame(res) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='crosstab', progress=progress) res <- NULL for (i in 1:tr$n) { d <- getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) d <- lapply(1:nl, function(i) round(d[, i], digits=digits)) d <- do.call(table, c(d, useNA='ifany')) d <- as.data.frame(d) res <- rbind(res, d) pbStep(pb, i) } pbClose(pb) res <- res[res$Freq > 0, ,drop=FALSE] # some complexity to aggregate keeping # variables that are NA if (useNA) { for (i in 1:(ncol(res)-1)) { if (any(is.na(res[,i]))) { res[,i] <- factor(res[,i], levels=c(levels(res[,i]), NA), exclude=NULL) } } } res <- aggregate(res[, ncol(res), drop=FALSE], res[, 1:(ncol(res)-1), drop=FALSE], sum) } for (i in 1:(ncol(res)-1)) { # get rid of factors res[,i] <- as.numeric(as.character(res[,i])) } if (nrow(res) == 0) { res <- data.frame(matrix(nrow=0, ncol=length(nms)+1)) } colnames(res) <- c(nms, 'Freq') if (! useNA ) { i <- apply(res, 1, function(x) any(is.na(x))) res <- res[!i, ,drop=FALSE] } if (!long) { f <- eval(parse(text=paste('Freq ~ ', paste(nms , collapse='+')))) res <- stats::xtabs(f, data=res, addNA=useNA) } else { res <- res[res$Freq > 0, ,drop=FALSE] res <- res[order(res[,1], res[,2]), ] rownames(res) <- NULL } return(res) } ) .oldcrosstab <- function(x, y, digits=0, long=FALSE, progress, ...) { # old function, not used any more compareRaster(c(x, y)) if (missing(progress)) { progress <- .progress() } if (canProcessInMemory(x, 3) | ( inMemory(x) & inMemory(y) )) { res <- table(first=round(getValues(x), digits=digits), second=round(getValues(y), digits=digits), ...) } else { res <- NULL tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='crosstab', progress=progress) for (i in 1:tr$n) { d <- table( round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), round(getValuesBlock(y, row=tr$row[i], nrows=tr$nrows[i]), digits=digits), ...) if (length(dim(d))==1) { first = as.numeric(names(d)) second = first d <- matrix(d) } else { first = as.numeric(rep(rownames(d), each=ncol(d))) second = as.numeric(rep(colnames(d), times=nrow(d))) } count = as.vector(t(d)) res = rbind(res, cbind(first, second, count)) pbStep(pb, i) } pbClose(pb) res <- stats::xtabs(count~first+second, data=res) } if (long) { return( as.data.frame(res) ) } else { return(res) } } raster/R/project.R0000644000176200001440000000321314507510157013550 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2014 # Version 1.0 # Licence GPL v3 .proj4string <- function(x) { if (inherits(x, "Spatial")) { suppressWarnings(sp::proj4string(x)) } else { # x@crs@projargs terra::crs(terra::crs(x@srs), proj=TRUE) } } .spCRS <- function(...) { # crs <- suppressWarnings(sp::CRS(...)) crs <- try(sp::CRS(...), silent=TRUE) if (inherits(crs, "try-error")) { sp::CRS() } else { crs } } if (!isGeneric(".project")) { setGeneric(".project", function(x, ...) standardGeneric(".project")) } setMethod('.project', signature(x='Raster'), function(x, to=NULL, res=NULL, crs=NULL, method="bilinear", alignOnly=FALSE, over=FALSE, filename="", ...) { projectRaster(x, to=to, res=res, crs=crs, method=method, alignOnly=alignOnly, over=over, filename=filename, ...) } ) setMethod('.project', signature(x='SpatialGrid'), function(x, ...) { y <- brick(x) #.requireRgdal() dots <- list(...) if (!is.null(dots$CRSobj) & is.null(dots$crs)) { y <- projectRaster(y, crs=dots$CRSobj, ...) } else { y <- projectRaster(y, ...) } as(y, class(x)) } ) setMethod('.project', signature(x='SpatialPixels'), function(x, ...) { y <- brick(x) #.requireRgdal() dots <- list(...) if (!is.null(dots$CRSobj) & is.null(dots$crs)) { y <- projectRaster(y, crs=dots$CRSobj, ...) } else { y <- projectRaster(y, ...) } as(y, class(x)) } ) setMethod('.project', signature(x='Spatial'), function(x, crs, ...) { #.requireRgdal() if (!is.null(list(...)$CRSobj)) { crs <- list(...)$CRSobj } v <- project(x, projection(crs)) as(v, "Spatial") #sp::spTransform(x, CRSobj=crs(crs), ...) } ) raster/R/dim.R0000644000176200001440000000332714507510157012661 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('dim', signature(x='BasicRaster'), function(x){ return(c(nrow(x), ncol(x), 1)) } ) setMethod('dim', signature(x='RasterStackBrick'), function(x){ return(c(nrow(x), ncol(x), nlayers(x))) } ) setMethod('nrow', signature(x='BasicRaster'), function(x){ return(x@nrows)} ) setMethod('ncol', signature(x='BasicRaster'), function(x){ return(x@ncols) } ) setMethod('dim<-', signature(x='BasicRaster'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x)) } value <- as.integer(pmax(round(value[1:2]), c(1,1))) x@nrows <- value[1] x@ncols <- value[2] return(x) } ) setMethod('dim<-', signature(x='RasterLayer'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x)) } else if (length(value) > 2) { value <- value[1:2] } value <- as.integer(pmax(round(value), c(1,1))) if (value[1] != nrow(x) | value[2] != ncol(x)) { x <- clearValues(x) x <- .clearFile(x) x@nrows <- value[1] x@ncols <- value[2] } return(x) } ) setMethod('dim<-', signature(x='RasterBrick'), function(x, value) { if (length(value) == 1) { value <- c(value, ncol(x), nlayers(x)) } else if (length(value) == 2) { value <- c(value, nlayers(x)) } else if (length(value) > 3) { warning('value should have length 1, 2, or 3. Additional values ignored') value <- value[1:3] } value <- as.integer(pmax(round(value), c(1,1,1))) if (value[1] != nrow(x) | value[2] != ncol(x) | value[3] != nlayers(x)) { x <- clearValues(x) x <- .clearFile(x) x@nrows <- value[1] x@ncols <- value[2] x@data@nlayers <- value[3] } return(x) } ) raster/R/maxDataType.R0000644000176200001440000000043014507510157014321 0ustar liggesusers .maxDatatype <- function(x) { x <- sort(x) x <- x[substr(x, 1, 3)== substr(x[1], 1, 3)] size <- max(as.integer(substr(x, 4, 4))) if (substr(x[1], 1, 3) == 'FLT') { return( paste('FLT', size, 'S', sep="") ) } else { # need to do better than this return( 'INT4S' ) } }raster/R/rasterize.R0000644000176200001440000000473714507510157014126 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('rasterize', signature(x='matrix', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...){ .pointsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, na.rm=na.rm, ...) } ) setMethod('rasterize', signature(x='data.frame', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...){ x <- as.matrix(x) .pointsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, na.rm=na.rm, ...) } ) setMethod('rasterize', signature(x='sf', y='Raster'), function(x, y, ...) { x <- .sf2sp(x) #if (is.list(x)) {} rasterize(x, y, ...) } ) setMethod('rasterize', signature(x='SpatialPoints', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...){ .pointsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, na.rm=na.rm, ...) } ) setMethod('rasterize', signature(x='SpatialLines', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", ...){ .linesToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, ...) } ) setMethod('rasterize', signature(x='SpatialPolygons', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", getCover=FALSE, silent=TRUE, ...){ .polygonsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, getCover=getCover, silent=silent, ...) } ) setMethod('rasterize', signature(x='Extent', y='Raster'), function(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", getCover=FALSE, silent=TRUE, ...){ # this could be done much more efficiently. x <- as(x, 'SpatialPolygons') .polygonsToRaster(x, y, field=field, fun=fun, background=background, mask=mask, update=update, updateValue=updateValue, filename=filename, getCover=getCover, silent=silent,...) } ) raster/R/erase.R0000644000176200001440000001043414507510157013204 0ustar liggesusers # .gDif <- function(x, y, type='polygons') { # xln <- length(x) # yln <- length(y) # if (xln==0 | yln==0) { # return(x) # } # rn <- row.names(x) # for (i in xln:1) { # z <- x[i,] # for (j in 1:yln) { # z <- rgeos::gDifference(z, y[j,], drop_lower_td=TRUE) # if (is.null(z)) { # break # } # } # if (is.null(z)) { # x <- x[-i,] # rn <- rn[-i] # } else { # if (type=='polygons') { # x@polygons[i] <- z@polygons # } else { # x@lines[i] <- z@lines # } # } # if (length(rn) > 0) { # row.names(x) <- rn # } # } # if ((type=='polygons') & (length(x) > 0)) { # w <- getOption('warn') # on.exit(options('warn' = w)) # options('warn'=-1) # j <- rgeos::gIsValid(x, byid=TRUE, reason=FALSE) # #j <- which(gArea(x, byid=TRUE) > 0) # if (!all(j)) { # bad <- which(!j) # for (i in bad) { # # it could be that a part of a polygon is a sliver, but that other parts are OK # a <- sp::disaggregate(x[i, ]) # if (length(a) > 1) { # jj <- which(rgeos::gIsValid(a, byid=TRUE, reason=FALSE)) # a <- a[jj, ] # if (length(a) > 0) { # x@polygons[i] <- aggregate(a)@polygons # j[i] <- TRUE # } # } # } # x <- x[j,] # rn <- rn[j] # } # if (length(rn) > 0) { # row.names(x) <- rn # } # } # x # } setMethod(erase, signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ...){ # warning("this method will be removed. You can use 'terra::erase' instead") z <- erase(vect(x), vect(y)) return(as(z, "Spatial")) # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # if (!.hasSlot(x, "data")) { # d <- data.frame(erase_dissolve_ID=1:length(x)) # rownames(d) <- row.names(x) # x <- sp::SpatialPolygonsDataFrame(x, data=d) # dropframe <- TRUE # } else { # dropframe <- FALSE # x$erase_dissolve_ID <- 1:nrow(x) # } # y <- aggregate(y) # int <- rgeos::gIntersects(x, y, byid=TRUE) # int1 <- apply(int, 2, any) # int2 <- apply(int, 1, any) # if (sum(int1) == 0) { # no intersections # return(x) # } # if (all(int1)) { # part1 <- NULL # } else { # part1 <- x[!int1,] # } # part2 <- .gDif(x[int1,], y[int2,]) # part2 <- sp::SpatialPolygonsDataFrame(part2, x@data[match(row.names(part2), rownames(x@data)), ,drop=FALSE]) # if (!is.null(part1)) { # part2 <- rbind(part1, part2) # } # if (length(part2@polygons) > 1) { # part2 <- aggregate(part2, colnames(part2@data)) # } # part2@proj4string <- prj # if (dropframe) { # return( as(part2, 'SpatialPolygons') ) # } else { # part2@data$erase_dissolve_ID <- NULL # return( part2 ) # } } ) setMethod(erase, signature(x='SpatialLines', y='SpatialPolygons'), function(x, y, ...){ # warning("this method will be removed. You can use 'terra::erase' instead") z <- erase(vect(x), vect(y)) return(as(z, "Spatial")) # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # if (!.hasSlot(x, 'data')) { # d <- data.frame(ID=1:length(x)) # rownames(d) <- row.names(x) # x <- sp::SpatialLinesDataFrame(x, data=d) # dropframe <- TRUE # } else { # dropframe <- FALSE # } # y <- aggregate(y) # int <- rgeos::gIntersects(x, y, byid=TRUE) # int1 <- apply(int, 2, any) # int2 <- apply(int, 1, any) # if (sum(int1) == 0) { # no intersections # return(x) # } # if (all(int1)) { # part1 <- NULL # } else { # part1 <- x[!int1,] # } # part2 <- .gDif(x[int1,], y[int2,], 'lines') # part2 <- sp::SpatialLinesDataFrame(part2, x@data[match(row.names(part2), rownames(x@data)), ,drop=FALSE], match.ID = FALSE) # if (!is.null(part1)) { # part2 <- rbind(part1, part2) # } # if (length(part2@lines) > 1) { # part2 <- aggregate(part2, colnames(part2@data)) # } # part2@proj4string <- prj # if (dropframe) { # return( as(part2, 'SpatialLines') ) # } else { # return( part2 ) # } } ) raster/R/rasterOptions.R0000644000176200001440000003735214507510157014771 0ustar liggesusers# Author: Robert J. Hijmans # September 2009 # Version 1.0 # Licence GPL v3 rasterOptions <- function(format, overwrite, datatype, tmpdir, tmptime, progress, timer, chunksize, minmemory, maxmemory, memfrac, todisk, setfileext, tolerance, standardnames, depracatedwarnings, addheader, default=FALSE) { setFiletype <- function(format) { if (.isSupportedFormat(format)) { options(rasterFiletype = format) } else { warning(paste('Cannot set filetype to unknown or unsupported file format:', format, '. See writeFormats()')) } } setOverwrite <- function(overwrite) { if (is.logical(overwrite)) { options(rasterOverwrite = overwrite) } else { warning(paste('Could not set overwrite. It must be a logical value')) } } setDataType <- function(datatype) { if (datatype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT4U', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S')) { options(rasterDatatype = datatype) } else { warning(paste('Cannot set datatype to unknown type:',datatype)) } } setTmpdir <- function(tmpdir) { if (!missing(tmpdir)) { tmpdir <- trim(tmpdir) if (tmpdir != '') { lastchar = substr(tmpdir, nchar(tmpdir), nchar(tmpdir)) if (lastchar != "/" & lastchar != '\\') { tmpdir <- paste(tmpdir, '/', sep='') } #res <- file.exists(substr(tmpdir, 1, nchar(tmpdir)-1)) #if (!res) { # res <- dir.create(tmpdir, recursive=TRUE, showWarnings = FALSE) #} #if (res) { options(rasterTmpDir = tmpdir) #} else { # warning(paste('could not create tmpdir:', tmpdir)) #} } } } setTmpTime <- function(tmptime) { if (is.numeric(tmptime)) { if (tmptime > 1) { options(rasterTmpTime = tmptime) } else { warning(paste('Could not set tmptime. It must be > 1')) } } else { warning(paste('Could not set tmptime. It must be a numerical value')) } } setProgress <- function(progress) { if (is.character(progress)) { progress <- tolower(trim(progress)) if (progress %in% c('window', 'tcltk', 'windows')) { progress <- 'window' } if (! progress %in% c('text', 'window', '')) { warning('invalid value for progress. Should be "window", "text", or ""') } else { options(rasterProgress = progress ) } } else { warning('progress must be a character value') } } setTimer <- function(timer) { if (is.logical(timer)) { options(rasterTimer = timer ) } else { warning(paste('timer must be a logical value')) } } setToDisk <- function(todisk) { if (is.logical(todisk)) { options(rasterToDisk = todisk ) } else { warning(paste('todisk argument must be a logical value')) } } setChunksize <- function(chunksize) { chunksize <- max(1, round(chunksize[1])) #chunksize <- min(chunksize, 10^7) options(rasterChunkSize = chunksize ) } setFileExt <- function(setfileext) { options(rasterSetFileExt = as.logical(setfileext) ) } setMaxMemorySize <- function(maxmemory) { maxmemory = max(10000, round(maxmemory[1])) options(rasterMaxMemory = maxmemory ) } setMinMemorySize <- function(minmemory) { minmemory = max(10000, round(minmemory[1])) options(rasterMinMemory = minmemory ) } setMemfrac <- function(memfrac) { if (memfrac >= 0.1 & memfrac <= 0.9) { options(rasterMemfrac = memfrac ) } else { warning(paste('memfrac argument must be a value between 0.1 and 0.9')) } } setTolerance <- function(x) { x <- max(0.000000001, min(x, 0.5)) options(rasterTolerance = x) } setStandardNames <- function(x) { if (is.logical(x)) { if (is.na(x)) { x <- TRUE } options(rasterStandardNames = x) } } depracatedWarnings <- function(x) { if (is.logical(x)) { if (is.na(x)) { x <- TRUE } options(rasterDepracatedWarnings = x) } } addHeader <- function(x) { x <- x[1] if (is.character(x)) { x <- toupper(trim(x)) if (nchar(x) < 3) { x <- '' } options(rasterAddHeader = x) } } cnt <- 0 if (default) { cnt <- 1 options(rasterFiletype = 'raster') options(rasterOverwrite = FALSE) options(rasterDatatype = 'FLT4S') options(rasterProgress = 'none') options(rasterTimer = FALSE) options(rasterTmpDir = tmpDir(create=FALSE)) options(rasterTmpTime = 24*7) options(rasterToDisk = FALSE) options(rasterSetFileExt = TRUE) options(rasterChunkSize = 10^9) options(rasterChunk = 10^9) options(rasterMaxMemory = 2e+10) options(rasterMinMemory = 8e+6) options(rasterMemfrac = 0.6) options(rasterTolerance = 0.1) options(rasterStandardNames = TRUE) options(rasterDepracatedWarnings = TRUE) options(rasterAddHeader = '') v <- utils::packageDescription('raster')[["Version"]] # fn <- paste(options('startup.working.directory'), '/rasterOptions_', v, sep='') # if (file.exists(fn)) { file.remove(fn) } } if (!missing(format)) { setFiletype(format); cnt <- cnt+1 } if (!missing(overwrite)) { setOverwrite(overwrite); cnt <- cnt+1 } if (!missing(datatype)) { setDataType(datatype); cnt <- cnt+1 } if (!missing(progress)) { setProgress(progress); cnt <- cnt+1 } if (!missing(timer)) { setTimer(timer); cnt <- cnt+1 } if (!missing(tmpdir)) { setTmpdir(tmpdir); cnt <- cnt+1 } if (!missing(tmptime)) { setTmpTime(tmptime); cnt <- cnt+1 } if (!missing(todisk)) { setToDisk(todisk); cnt <- cnt+1 } if (!missing(setfileext)) { setFileExt(setfileext); cnt <- cnt+1 } if (!missing(minmemory)) { setMinMemorySize(minmemory); cnt <- cnt+1 } if (!missing(maxmemory)) { setMaxMemorySize(maxmemory); cnt <- cnt+1 } if (!missing(memfrac)) { setMemfrac(memfrac); cnt <- cnt+1 } if (!missing(chunksize)) { setChunksize(chunksize); cnt <- cnt+1 } if (!missing(tolerance)) { setTolerance(tolerance); cnt <- cnt+1 } if (!missing(standardnames)) { setStandardNames(standardnames); cnt <- cnt+1 } if (!missing(depracatedwarnings)) { depracatedWarnings(depracatedwarnings); cnt <- cnt+1 } if (!missing(addheader)) {addHeader(addheader) ; cnt <- cnt+1 } lst <- list( format=.filetype(), overwrite=.overwrite(), datatype=.datatype(), tmpdir= tmpDir(create=FALSE), tmptime=.tmptime(), progress=.progress(), timer=.timer(), chunksize=.chunksize(), maxmemory=.maxmemory(), minmemory=.minmemory(), memfrac = .memfrac(), todisk=.toDisk(), setfileext=.setfileext(), tolerance=.tolerance(), standardnames=.standardnames(), depwarning=.depracatedwarnings(), addheader=.addHeader() ) save <- FALSE if (save) { v <- utils::packageDescription('raster')[["Version"]] fn <- paste(options('startup.working.directory'), '/rasterOptions_', v, sep='') oplst <- NULL oplst <- c(oplst, paste("rasterFiletype='", lst$format, "'", sep='')) oplst <- c(oplst, paste("rasterOverwrite=", lst$overwrite, sep='')) oplst <- c(oplst, paste("rasterDatatype='", lst$datatype, "'", sep='')) oplst <- c(oplst, paste("rasterTmpDir='", lst$tmpdir, "'", sep='')) oplst <- c(oplst, paste("rasterTmpTime='", lst$tmptime, "'", sep='')) oplst <- c(oplst, paste("rasterProgress='", lst$progress, "'", sep='')) oplst <- c(oplst, paste("rasterTimer=", lst$timer, sep='')) oplst <- c(oplst, paste("rasterChunkSize=", lst$chunksize, sep='')) oplst <- c(oplst, paste("rasterMaxMemory=", lst$maxmemory, sep='')) oplst <- c(oplst, paste("rasterMinMemory=", lst$minmemory, sep='')) oplst <- c(oplst, paste("rasterMemfrac=", lst$memfrac, sep='')) oplst <- c(oplst, paste("rasterSetFileExt=", lst$setfileext, sep='')) oplst <- c(oplst, paste("rasterTolerance=", lst$tolerance, sep='')) oplst <- c(oplst, paste("rasterStandardNames=", lst$standardnames, sep='')) oplst <- c(oplst, paste("rasterDepracatedWarnings=", lst$depwarning, sep='')) oplst <- c(oplst, paste("rasterAddHeader=", lst$addheader, sep='')) r <- try( write(unlist(oplst), fn), silent = TRUE ) cnt <- 1 } if (cnt == 0) { cat('format :', lst$format, '\n' ) cat('datatype :', lst$datatype, '\n') cat('overwrite :', lst$overwrite, '\n') cat('progress :', lst$progress, '\n') cat('timer :', lst$timer, '\n') cat('chunksize :', lst$chunksize, '\n') cat('minmemory :', lst$minmemory, '\n') cat('maxmemory :', lst$maxmemory, '\n') cat('memfrac :', lst$memfrac, '\n') cat('tmpdir :', lst$tmpdir, '\n') cat('tmptime :', lst$tmptime, '\n') cat('setfileext :', lst$setfileext, '\n') cat('tolerance :', lst$tolerance, '\n') cat('standardnames :', lst$standardnames, '\n') cat('warn depracat.:', lst$depwarning, '\n') if (lst$addheader == '') { cat('header : none\n') } else { cat('header :', lst$addheader, '\n') } if (lst$todisk) { cat('todisk : TRUE\n') } } invisible(lst) } .loadOptions <- function(f) { if (file.exists(f)) { dd <- readLines(f) for (d in dd) { try(eval(parse(text=paste("options(", d, ")")))) } } } .addHeader <- function() { d <- getOption('rasterAddHeader') if (is.null(d)) { return( '' ) } else { return(trim(d)) } } .depracatedwarnings <- function() { d <- getOption('rasterDepracatedWarnings') if (is.null(d)) { return( TRUE ) } else { return(as.logical(d)) } } .dataloc <- function() { d <- getOption('rasterDataDir') if (is.null(d) ) { d <- getwd() } else { d <- trim(d) if (d=='') { d <- getwd() } } return(d) } .tmpdir <- function(...) { tmpDir(...) } tmpDir <- function(create=TRUE) { d <- getOption('rasterTmpDir') if (is.null(d)) { d <- .tmppath() } #lastchar <- substr(d, nchar(d), nchar(d)) # if (lastchar == '/' | lastchar == '\\') { # d <- substr( d, 1, nchar(d)-1 ) #} if (!file.exists(d) & create) { dir.create( d, recursive=TRUE, showWarnings=FALSE ) } return(d) } .setfileext <- function() { d <- getOption('rasterSetFileExt') if (is.null(d)) { return( TRUE ) } return(as.logical(d)) } .tmptime <- function() { d <- getOption('rasterTmpTime') if (is.null(d)) { d <- 24 * 7 } else { d <- as.numeric(d) if (d < 0) { d <- 24 * 7 } } return(d) } .memfrac <- function() { default <- 0.6 d <- getOption('rasterMemfrac') if (is.null(d)) { return( default ) } else { return(d) } } .maxmemory <- function() { default <- 5e+9 d <- getOption('rasterMaxMemory') if (is.null(d)) { return( default ) } d <- round(as.numeric(d[1])) if (is.na(d) | d < 1e+6) { d <- 1e+6 } return(d) } .minmemory <- function() { default <- 8e+6 d <- getOption('rasterMinMemory') if (is.null(d)) { return( default ) } d <- round(as.numeric(d[1])) if (is.na(d) | d < 10000) { d <- 8e+6 } return(d) } .chunksize <- function(){ default <- 10^8 d <- getOption('rasterChunkSize') if (is.null(d)) { return( default ) } d <- round(as.numeric(d[1])) if (is.na(d) | d < 10000) { d <- default } return(d) } .chunk <- function(){ d <- getOption('rasterChunk') if (is.null(d)) { return( .chunksize() ) } if (is.na(d) | d < 10000) { return( .chunksize() ) } return(d) } .tolerance <- function() { d <- getOption('rasterTolerance') if (is.null(d)) { d <- 0.1 } else { d <- max(0.000000001, min(d, 0.5)) } return(d) } .overwrite <- function(..., overwrite) { if (missing(overwrite)) { overwrite <- getOption('rasterOverwrite') if (is.null(overwrite)) { return(FALSE) } else { if (is.logical(overwrite)) { return(overwrite) } else { return(FALSE) } } } else { if (is.logical(overwrite)) { return(overwrite) } else { return(FALSE) } } } .datatype <- function(datatype=NULL, ...) { # if (missing(datatype) && !missing(dataType)) { # warning('argument "datatype" misspelled as "dataType"') # datatype <- dataType def <- getOption('rasterDatatype') if (is.null(def)) def <- "FLT4S" if (missing(datatype)) { datatype <- def } else if (is.na(datatype) || is.null(datatype)) { datatype <- def } if (! datatype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'INT4U', 'FLT4S', 'FLT8S')) { warning(datatype, ' is an invalid datatype value, changed to "FLT4S"') datatype <- 'FLT4S' } datatype } .getFormat <- function(filename) { ext <- tolower(extension(filename, maxchar=5)) if (nchar(ext) < 3) { return('') } else { if (ext == '.tif' | ext == '.tiff') { return('GTiff') } else if (ext == '.grd') { return('raster') } else if (ext == '.asc') { return('ascii') } else if (ext == '.nc' | ext == '.cdf' | ext == '.ncdf') { return('CDF') } else if (ext == '.kml') { return('KML') } else if (ext == '.kmz') { return('KML') # } else if (ext == '.big') { return('big.matrix') } else if (ext == '.sgrd') { return('SAGA') } else if (ext == '.sdat') { return('SAGA') } else if (ext == '.bil') { return('BIL') } else if (ext == '.bsq') { return('BSQ') } else if (ext == '.bip') { return('BIP') } else if (ext == '.bmp') { return('BMP') } else if (ext == '.gen') { return('ADRG') } else if (ext == '.bt') { return('BT') } else if (ext == '.envi') { return('ENVI') } else if (ext == '.ers') { return('ERS') } else if (ext == '.img') { return( 'HFA') } else if (ext == '.rst') { return('RST') } else if (ext == '.mpr') { return('ILWIS') } else if (ext == '.rsw') { return('RMF') } else if (ext == '.flt') { return('EHdr') } else { warning('extension ', ext, ' is unknown. Using default format.') return('') } } } .filetype <- function(format, filename='', ...) { if (missing(format)) { format <- .getFormat(filename) if (format != '') { return(format) } format <- getOption('rasterFiletype') if (is.null(format)) { return('raster') } else { return(format) } } else { return(format) } } .progress <- function(..., progress) { if (missing(progress)) { progress <- getOption('rasterProgress') if (is.null(progress)) { return('none') } else { if (is.character(progress)) { if (progress[1] %in% c('text', 'window', 'tcltk', 'windows')) { return(progress[1]) } else { return('none') } } else { return('none') } } } else { if (is.character(progress)) { if (progress[1] %in% c('text', 'window', 'tcltk', 'windows')) { return(progress[1]) } else { return('none') } } else { return('none') } } } .timer <- function(..., timer) { if (missing(timer)) { timer <- getOption('rasterTimer') if (is.null(timer)) { return(FALSE) } else { return( as.logical(timer) ) } } else { return(as.logical(timer)) } } .standardnames <- function(..., standardnames) { if (missing(standardnames)) { standardnames <- getOption('rasterStandardNames') if (is.null(standardnames)) { return(TRUE) # the default } else { try (todisk <- as.logical(standardnames)) if (is.logical(standardnames)) { return(standardnames) } else { return(TRUE) } } } else { if (is.logical(todisk)) { return(todisk) } else { return(TRUE) } } } .toDisk <- function(..., todisk) { if (missing(todisk)) { todisk <- getOption('rasterToDisk') if (is.null(todisk)) { return(FALSE) # the default } else { try (todisk <- as.logical(todisk)) if (is.logical(todisk)) { return(todisk) } else { return(FALSE) } } } else { if (is.logical(todisk)) { return(todisk) } else { return(FALSE) } } } .usecluster <- function(...) { usecluster <- list(...)$usecluster if (is.null(usecluster)) { usecluster <- getOption('rasterUseCluster') if (is.null(usecluster)) { return(FALSE) # the default } else { try (usecluster <- as.logical(usecluster), silent=TRUE) if (isTRUE(usecluster)) { return(TRUE) } else { return(FALSE) } } } else { if (is.logical(usecluster)) { return(usecluster) } else { return(FALSE) } } } .removeRasterOptions <- function(x) { y <- list() for (i in seq(along.with=x)) { if (!trim(x[[i]]) == "# Options for the 'raster' package" & !substr(trim(x[[i]]),1,14) == 'options(raster') { y <- c(y, x[[i]]) } } return(y) } .tmppath <- function() { file.path(tempdir(), 'raster', '/') } raster/R/unstack.R0000644000176200001440000000066614507510157013563 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("unstack")) { setGeneric("unstack", function(x, ...) standardGeneric("unstack")) } setMethod("unstack", signature(x='RasterStack'), function(x) { return(x@layers) } ) setMethod("unstack", signature(x='RasterBrick'), function(x) { if (nlayers(x) == 0) { list() } else { lapply(1:nlayers(x), function(i) raster(x, i)) } } ) raster/R/kernelDensity.R0000644000176200001440000000072214507510157014724 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2016 # Version 0.1 # Licence GPL v3 .kernelDensity <- function(xy, r, bandwidth) { requireNamespace("MASS") lims <- as.vector(extent(r)) + rep(res(r), each=2) * c(0.5,-0.5) n <- rev(dim(r)[1:2]) xy <- .pointsToMatrix(xy) k <- raster( MASS::kde2d(xy[,1], xy[,2], h=bandwidth, n=n, lims=lims) ) # to avoid possible small changes due to floating point math and to transfer crs setValues(r, getValues(k)) } raster/R/plotRaster.R0000644000176200001440000000372014507510157014244 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 0.9 # Licence GPL v3 .plotraster <- function(object, col=rev(terrain.colors(25)), maxpixels=100000, axes=TRUE, xlab='', ylab='', ext=NULL, asp, xlim, ylim, add=FALSE, addfun=NULL, main, ...) { if (missing(asp)) { if (couldBeLonLat(object, warnings=FALSE)) { # ym <- mean(object@extent@ymax + object@extent@ymin) # asp <- min(5, 1/cos((ym * pi)/180)) asp = NA } else { asp = 1 } } if (missing(main)) { main <- '' #names(object)[1] } if ( ! inMemory(object) ) { if ( ! fromDisk(object) ) { stop('no values associated with this RasterLayer') } } maxpixels <- max(1, maxpixels) if (is.null(ext)) { e <- extent(object) } else { e <- ext <- intersect(extent(object), ext) } if (! missing(xlim) | ! missing(ylim )) { if (!missing(xlim)) { if (xlim[1] >= xlim[2]) stop('invalid xlim') if (xlim[1] < e@xmax) e@xmin <- xlim[1] if (xlim[2] > e@xmin) e@xmax <- xlim[2] } if (!missing(ylim)) { if (ylim[1] >= ylim[2]) stop('invalid ylim') if (ylim[1] < e@ymax) e@ymin <- ylim[1] if (ylim[2] > e@ymin) e@ymax <- ylim[2] } } leg <- object@legend object <- sampleRegular(object, size=maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) x <- (0:ncol(object)) * xres(object) + xmin(object) y <- (0:nrow(object)) * yres(object) + ymin(object) if (length(leg@color) > 0) { breaks <- leg@values object <- cut(object, breaks) col <- leg@color lab.breaks <- as.character(breaks) } z <- t(as.matrix(object)[object@nrows:1,]) if (nrow(z) == 1 | ncol(z) == 1) z <- t(z) z[is.infinite(z)] <- NA if (length(leg@color) > 0) { .imageplot(x, y, z, col=col, axes=axes, xlab=xlab, ylab=ylab, asp=asp, breaks=breaks, lab.breaks=lab.breaks, add=add, main=main, ...) } else { .imageplot(x, y, z, col=col, axes=axes, xlab=xlab, ylab=ylab, asp=asp, add=add, main=main, ...) } if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } } raster/R/minValue.R0000644000176200001440000000571014507510157013666 0ustar liggesusers# raster package # Authors: Robert J. Hijmans # Date : September 2009 # Version 1.0 # Licence GPL v3 if (!isGeneric("minValue")) { setGeneric("minValue", function(x, ...) standardGeneric("minValue")) } setMethod('minValue', signature(x='RasterLayer'), function(x, layer=-1, warn=TRUE) { if ( x@data@haveminmax ) { v <- x@data@min if (isTRUE( v == Inf)) { v <- NA } else { if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } } return(v) } else { if (warn) warning('min value not known, use setMinMax') return(NA) } } ) setMethod('minValue', signature(x='RasterBrick'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] if (layer < 1) { if ( x@data@haveminmax ) { v <- x@data@min v[v == Inf] <- NA if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } return(v) } else { warning('min value not known, use setMinMax') return(rep(NA, nlayers(x))) } } else { if ( x@data@haveminmax ) { v <- x@data@min[layer] * x@data@gain + x@data@offset v[v == Inf] <- NA return(v) } else { warning('min value not known, use setMinMax') return(NA) } } } ) setMethod('minValue', signature(x='RasterStack'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] nl <- nlayers(x) if (layer < 1) { v <- vector(length=nl) for (i in 1:nl) { v[i] <- minValue(x@layers[[i]], warn=warn) } } else { if (layer <= nl) { v <- minValue(x@layers[[layer]]) } else { stop('incorrect layer number') } } return(v) } ) if (!isGeneric("maxValue")) { setGeneric("maxValue", function(x, ...) standardGeneric("maxValue")) } setMethod('maxValue', signature(x='RasterLayer'), function(x, layer=-1, warn=TRUE) { if ( x@data@haveminmax ) { v <- x@data@max if (isTRUE( v == -Inf)) { v <- NA } else { if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } } return(v) } else { if (warn) warning('max value not known, use setMinMax') return(NA) } } ) setMethod('maxValue', signature(x='RasterBrick'), function(x, layer=-1, warn=FALSE) { if ( x@data@haveminmax ) { v <- x@data@max v[!is.finite(v)] <- NA if (! inMemory(x) ) { v <- v * x@data@gain + x@data@offset } return(v) } else { if (warn) warning('max value not known, use setMinMax') v <- rep(NA, nlayers(x)) } layer <- round(layer)[1] if (layer > 0) { if (layer <= nlayers(x)) { v <- v[layer] } else { stop('invalid layer selected') } } return(v) } ) setMethod('maxValue', signature(x='RasterStack'), function(x, layer=-1, warn=FALSE) { layer <- round(layer)[1] nl <- nlayers(x) if (layer < 1) { v <- vector(length=nl) for (i in 1:nl) { v[i] <- maxValue(x@layers[[i]], warn=warn) } } else { if (layer <= nl) { v <- maxValue(x@layers[[layer]]) } else { stop('incorrect layer number') } } return(v) } ) raster/R/moran.R0000644000176200001440000000331314507510157013217 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 ..moran <- function(x, directions=8) { stopifnot(directions %in% c(4,8)) # not memory safe adj <- adjacent(x, 1:ncell(x), target=1:ncell(x), directions=8, pairs=TRUE) z <- x - cellStats(x, mean) wZiZj <- stats::na.omit(z[adj[,1]] * z[adj[,2]]) z2 <- cellStats(z*z, sum) NS0 <- (ncell(z)-cellStats(z, 'countNA')) / length(wZiZj) mI <- NS0 * sum(wZiZj) / z2 return(mI) } Moran <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3) ) { z <- x - cellStats(x, mean) wZiZj <- focal(z, w=w, fun='sum', na.rm=TRUE, pad=TRUE) wZiZj <- overlay(wZiZj, z, fun=function(x,y){ x * y }) wZiZj <- cellStats(wZiZj, sum) z2 <- cellStats(z*z, sum) n <- ncell(z) - cellStats(z, 'countNA') # weights if (sum(! unique(w) %in% 0:1) > 0) { zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal( zz, w=w, fun='sum', na.rm=TRUE, pad=TRUE) } else { w2 <- w w2[w2==0] <- NA W <- focal( z, w=w2, fun=function(x, ...){ as.double(sum(!is.na(x))) }, pad=TRUE) } NS0 <- n / cellStats(W, sum) mI <- NS0 * wZiZj / z2 return(mI) } MoranLocal <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3)) { z <- x - cellStats(x, mean) #weights #w <- .getFilter(w) if (sum(! unique(w) %in% 0:1) > 0) { zz <- calc(z, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal( zz, w=w, na.rm=TRUE, pad=TRUE) } else { w2 <- w w2[w2==0] <- NA W <- focal( z, w=w2, fun=function(x, ...){ sum(!is.na(x)) }, na.rm=TRUE, pad=TRUE) } lz <- focal(z, w=w, na.rm=TRUE, pad=TRUE) / W n <- ncell(x) - cellStats(x, 'countNA') s2 <- cellStats(x, 'sd')^2 # adjust variance denominator from n-1 to n #s2 <- (s2 * (n-1)) / n (z / s2) * lz } raster/R/fullFileName.R0000644000176200001440000000117514507510157014452 0ustar liggesusers# raster package # Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 # this function adds the working directory to a filename, if the filename has no path name # and, thus, presumably exists in the working directory. # Storing the full file name is to avoid that a filename becomes invalid if the working directory # changes during an R session .fullFilename <- function(x, expand=FALSE) { x <- trim(x) if (identical(basename(x), x)) { # exclude PG:xxx and perhaps others if (length(grep(":", x)) == 0) { x <- file.path(getwd(), x) } } if (expand) { x <- path.expand(x) } return(x) } raster/R/focalFun.R0000644000176200001440000000305614507510157013644 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2014 # Version 1.0 # Licence GPL v3 #if ( !isGeneric("focalFun") ) { # setGeneric("focalFun", function(x, ...) # standardGeneric("focalFun")) #} #setMethod('focalFun', signature(x='Raster'), .focalFun <- function(x, fun, ngb=5, filename='', ...) { out <- raster(x) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) if (canProcessInMemory(x)) { v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE) v <- parallel::parApply(cl, v, 1, fun) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='focalFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE) v <- parallel::parApply(cl, v, 1, fun) out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } else { if (canProcessInMemory(x)) { v <- getValuesFocal(x, 1, nrow(x), ngb=ngb, array=TRUE) v <- apply(v, 1, fun) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='focalFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb, array=TRUE) v <- apply(v, 1, fun) out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } #) raster/R/sampleStratified.R0000644000176200001440000000505514507510157015410 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2012 # Version 2.0 # Licence GPL v3 setMethod('sampleStratified', signature(x='RasterLayer'), function(x, size, exp=10, na.rm=TRUE, xy=FALSE, ext=NULL, sp=FALSE, ...) { stopifnot(hasValues(x)) size <- round(size) stopifnot(size <= ncell(x)) stopifnot(size > 0) if (!is.null(ext)) { oldx <- raster(x) x <- crop(x, ext) } if (canProcessInMemory(x)) { v <- cbind(1:ncell(x), round(getValues(x))) if (na.rm) { v <- v[!is.na(v[,2]), ] } f <- table(v[,2], useNA='ifany') f <- cbind(as.integer(names(f)), f) ys <- list() for (i in 1:nrow(f)) { if (is.na(f[i,1])) { y <- v[is.na(v[, 2]), ,drop=FALSE] } else { y <- v[v[, 2] == f[i,1], ,drop=FALSE] } if (nrow(y) < size) { warning("only ", nrow(y), " cells found for stratum ", f[i,1]) } else { if (nrow(y) > size) { y <- y[sample(nrow(y), size), ,drop=FALSE] } } # bug fix by Antoine Stevens ys[[i]] <- y } } else { # unique would suffice, unless to check whether a sample _can_ be obtained for a stratum f <- freq(x) if (na.rm) { na <- which(is.na(f[,1])) if (length(na) > 0) { f <- f[-na, ,drop=FALSE] } } exp <- max(1, exp) ss <- exp * size * nrow(f) if (ss < 1000) { ss <- 1000 } if (ss > ncell(x)) { ss <- ncell(x) } sr <- sampleRandom(x, ss, na.rm=na.rm, ext=NULL, cells=TRUE, rowcol=FALSE, sp=FALSE) ys <- list() for (i in seq_len(nrow(f))) { y <- sr[sr[, 2] == f[i,1], ,drop=FALSE] if (nrow(y) == 0) { warning("no samples found for value: ", i, ". Perhaps increase the value of 'ext'") } else { if (nrow(y) > size) { y <- y[sample(nrow(y), size), ,drop=FALSE] } ys[[i]] <- y } } } res <- do.call(rbind, ys) colnames(res) <- c('cell', names(x)) ta <- tapply(res[,1], res[,2], length) tanm <- names(ta)[which(ta < size)] if (length(tanm)== 1) { warning('fewer samples than requested found for stratum: ', tanm) } else if (length(tanm) > 1) { warning('fewer samples than requested found for strata: ', paste(tanm, collapse=', ')) } if (!is.null(ext)) { pts <- xyFromCell(x, res[,1]) res[,1] <- cellFromXY(oldx, pts) if (xy) { res <- cbind(res[,1,drop=FALSE], pts, res[,2,drop=FALSE]) } } else if (xy) { pts <- xyFromCell(x, res[,1]) res <- cbind(res[,1,drop=FALSE], pts, res[,2,drop=FALSE]) } if (sp) { if (!xy & is.null(ext)) { pts <- xyFromCell(x, res[,1]) } res <- sp::SpatialPointsDataFrame(pts, data.frame(res), proj4string=.getCRS((x))) } return(res) } ) raster/R/getData.R0000644000176200001440000003140314642777523013471 0ustar liggesusers# Download geographic data and return as R object # Author: Robert J. Hijmans # License GPL3 # Version 0.9 # October 2008 getData <- function(...) { stop("getData has been removed. Please use the geodata package instead.") } .getData <- function(name='GADM', download=TRUE, path='', ...) { message("getData will stop working soon!\n. Please use the geodata package instead.\n Going to sleep for 15 seconds...") Sys.sleep(15) path <- .getDataPath(path) tout <- getOption("timeout") on.exit(options(timeout = tout)) options(timeout = max(600, tout)) if (name=='GADM') { .GADM(..., download=download, path=path) } else if (name=='SRTM') { .SRTM(..., download=download, path=path) } else if (name=='alt') { .raster(..., name=name, download=download, path=path) } else if (name=='worldclim') { .worldclim(..., download=download, path=path) } else if (name=='CMIP5') { .cmip5(..., download=download, path=path) } else if (name=='ISO3') { ccodes()[,c(2,1)] } else if (name=='countries') { .countries(download=download, path=path, ...) } else { stop(name, ' not recognized as a valid name.') } } .download <- function(aurl, filename) { fn <- paste(tempfile(), '.download', sep='') res <- utils::download.file(url=aurl, destfile=fn, quiet = FALSE, mode = "wb", cacheOK = TRUE) if (res == 0) { w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) if (! file.rename(fn, filename) ) { # rename failed, perhaps because fn and filename refer to different devices file.copy(fn, filename) file.remove(fn) } } else { stop('could not download the file' ) } } .ISO <- function() { ccodes() } ccodes <- function() { path <- system.file(package="raster") #d <- utils::read.csv(paste(path, "/external/countries.csv", sep=""), stringsAsFactors=FALSE, encoding="UTF-8") readRDS(file.path(path, "external/countries.rds")) } .getCountry <- function(country='') { country <- toupper(trim(country[1])) cs <- ccodes() cs <- sapply(cs, toupper) cs <- data.frame(cs, stringsAsFactors=FALSE) nc <- nchar(country) if (nc == 3) { if (country %in% cs$ISO3) { return(country) } else { stop('unknown country') } } else if (nc == 2) { if (country %in% cs$ISO2) { i <- which(country==cs$ISO2) return( cs$ISO3[i] ) } else { stop('unknown country') } } else if (country %in% cs[,1]) { i <- which(country==cs[,1]) return( cs$ISO3[i] ) } else if (country %in% cs[,4]) { i <- which(country==cs[,4]) return( cs$ISO3[i] ) } else if (country %in% cs[,5]) { i <- which(country==cs[,5]) return( cs$ISO3[i] ) } else { stop('provide a valid name name or 3 letter ISO country code; you can get a list with "ccodes()"') } } .getDataPath <- function(path) { path <- trim(path) if (path=="") { path <- .dataloc() } else { if (substr(path, nchar(path)-1, nchar(path)) == '//' ) { p <- substr(path, 1, nchar(path)-2) } else if (substr(path, nchar(path), nchar(path)) == '/' | substr(path, nchar(path), nchar(path)) == '\\') { p <- substr(path, 1, nchar(path)-1) } else { p <- path } if (!file.exists(p) & !file.exists(path)) { stop('path does not exist: ', path) } } if (substr(path, nchar(path), nchar(path)) != '/' & substr(path, nchar(path), nchar(path)) != '\\') { path <- paste(path, "/", sep="") } return(path) } .GADM <- function(country, level, download, path, version=3.6, type='sp') { # if (!file.exists(path)) { dir.create(path, recursive=T) } country <- .getCountry(country) if (missing(level)) { stop('provide a "level=" argument; levels can be 0, 1, or 2 for most countries, and higher for some') } if (version > 3) { if (type == 'sf') { filename <- file.path(path, paste0('gadm36_', country, '_', level, "_sf.rds")) } else { filename <- file.path(path, paste0('gadm36_', country, '_', level, "_sp.rds")) } } else { filename <- paste(path, 'GADM_', version, '_', country, '_', level, ".rds", sep="") } if (!file.exists(filename)) { if (download) { baseurl <- paste0("https://biogeo.ucdavis.edu/data/gadm", version) if (version == 2.8) { theurl <- paste(baseurl, '/rds/', country, '_adm', level, ".rds", sep="") } else { if (type == 'sf') { theurl <- paste(baseurl, '/Rsf/gadm36_', country, '_', level, "_sf.rds", sep="") } else { theurl <- paste(baseurl, '/Rsp/gadm36_', country, '_', level, "_sp.rds", sep="") } } .download(theurl, filename) if (!file.exists(filename)) { message("\nCould not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } if (file.exists(filename)) { x <- readRDS(filename) # avoid pesky warnings if (type != 'sf') { crs(x) <- "+proj=longlat +datum=WGS84" } return(x) } else { return(NULL) } } .countries <- function(download, path, type='sp', ...) { if (type == 'sf') { f <- "countries_gadm36_sf.rds" } else { f <- "countries_gadm36_sp.rds" } filename <- file.path(path, f) if (!file.exists(filename)) { if (download) { theurl <- paste0("https://biogeo.ucdavis.edu/data/gadm3.6/", f) .download(theurl, filename) if (!file.exists(filename)) { message("\nCould not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } if (file.exists(filename)) { #thisenvir = new.env() #data <- get(load(filename, thisenvir), thisenvir) data <- readRDS(filename) crs(data) <- "+proj=longlat +datum=WGS84" return(data) } } .cmip5 <- function(var, model, rcp, year, res, lon, lat, path, download=TRUE) { if (!res %in% c(0.5, 2.5, 5, 10)) { stop('resolution should be one of: 2.5, 5, 10') } if (res==2.5) { res <- '2_5m' } else if (res == 0.5) { res <- "30s" } else { res <- paste(res, 'm', sep='') } var <- tolower(var[1]) vars <- c('tmin', 'tmax', 'prec', 'bio') stopifnot(var %in% vars) var <- c('tn', 'tx', 'pr', 'bi')[match(var, vars)] model <- toupper(model) models <- c('AC', 'BC', 'CC', 'CE', 'CN', 'GF', 'GD', 'GS', 'HD', 'HG', 'HE', 'IN', 'IP', 'MI', 'MR', 'MC', 'MP', 'MG', 'NO') stopifnot(model %in% models) rcps <- c(26, 45, 60, 85) stopifnot(rcp %in% rcps) stopifnot(year %in% c(50, 70)) #m <- matrix(c(0,1,1,0,1,1,1,1,1,1,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,0,0,1,0,1,1,1,0,0,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1), ncol=4) m <- matrix(c(0,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,0,0,0,1,1,1,0,1,0,1,1,1,1,0,1,1,1,1,1,0,1,1,0,1,1,1,1,1,1,1,1,1,1,1,1), ncol=4) i <- m[which(model==models), which(rcp==rcps)] if (!i) { warning('this combination of rcp and model is not available') return(invisible(NULL)) } path <- paste(path, '/cmip5/', res, '/', sep='') dir.create(path, recursive=TRUE, showWarnings=FALSE) zip <- tolower(paste(model, rcp, var, year, '.zip', sep='')) theurl <- paste('https://biogeo.ucdavis.edu/data/climate/cmip5/', res, '/', zip, sep='') zipfile <- paste(path, zip, sep='') if (var == 'bi') { n <- 19 } else { n <- 12 } tifs <- paste(extension(zip, ''), 1:n, '.tif', sep='') files <- paste(path, tifs, sep='') fc <- sum(file.exists(files)) if (fc < n) { if (!file.exists(zipfile)) { if (download) { .download(theurl, zipfile) if (!file.exists(zipfile)) { message("\n Could not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } utils::unzip(zipfile, exdir=dirname(zipfile)) } stack(paste(path, tifs, sep='')) } #.cmip5(var='prec', model='BC', rcp=26, year=50, res=10, path=getwd()) .worldclim <- function(var, res, lon, lat, path, download=TRUE) { if (!res %in% c(0.5, 2.5, 5, 10)) { stop('resolution should be one of: 0.5, 2.5, 5, 10') } if (res==2.5) { res <- '2-5' } stopifnot(var %in% c('tmean', 'tmin', 'tmax', 'prec', 'bio', 'alt')) path <- paste(path, 'wc', res, '/', sep='') dir.create(path, showWarnings=FALSE) if (res==0.5) { lon <- min(180, max(-180, lon)) lat <- min(90, max(-60, lat)) rs <- raster(nrows=5, ncols=12, xmn=-180, xmx=180, ymn=-60, ymx=90 ) row <- rowFromY(rs, lat) - 1 col <- colFromX(rs, lon) - 1 rc <- paste(row, col, sep='') zip <- paste(var, '_', rc, '.zip', sep='') zipfile <- paste(path, zip, sep='') if (var == 'alt') { bilfiles <- paste(var, '_', rc, '.bil', sep='') hdrfiles <- paste(var, '_', rc, '.hdr', sep='') } else if (var != 'bio') { bilfiles <- paste(var, 1:12, '_', rc, '.bil', sep='') hdrfiles <- paste(var, 1:12, '_', rc, '.hdr', sep='') } else { bilfiles <- paste(var, 1:19, '_', rc, '.bil', sep='') hdrfiles <- paste(var, 1:19, '_', rc, '.hdr', sep='') } theurl <- paste('https://biogeo.ucdavis.edu/data/climate/worldclim/1_4/tiles/cur/', zip, sep='') } else { zip <- paste(var, '_', res, 'm_bil.zip', sep='') zipfile <- paste(path, zip, sep='') if (var == 'alt') { bilfiles <- paste(var, '.bil', sep='') hdrfiles <- paste(var, '.hdr', sep='') } else if (var != 'bio') { bilfiles <- paste(var, 1:12, '.bil', sep='') hdrfiles <- paste(var, 1:12, '.hdr', sep='') } else { bilfiles <- paste(var, 1:19, '.bil', sep='') hdrfiles <- paste(var, 1:19, '.hdr', sep='') } theurl <- paste('https://biogeo.ucdavis.edu/data/climate/worldclim/1_4/grid/cur/', zip, sep='') } files <- c(paste(path, bilfiles, sep=''), paste(path, hdrfiles, sep='')) fc <- sum(file.exists(files)) if ( fc < length(files) ) { if (!file.exists(zipfile)) { if (download) { .download(theurl, zipfile) if (!file.exists(zipfile)) { message("\n Could not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } utils::unzip(zipfile, exdir=dirname(zipfile)) for (h in paste(path, hdrfiles, sep='')) { x <- readLines(h) x <- c(x[1:14], 'PIXELTYPE SIGNEDINT', x[15:length(x)]) writeLines(x, h) } } if (var == 'alt') { st <- raster(paste(path, bilfiles, sep='')) } else { st <- stack(paste(path, bilfiles, sep='')) } projection(st) <- "+proj=longlat +datum=WGS84" return(st) } .raster <- function(country, name, mask=TRUE, path, download, keepzip=FALSE, ...) { country <- .getCountry(country) path <- .getDataPath(path) if (mask) { mskname <- '_msk_' mskpath <- 'msk_' } else { mskname<-'_' mskpath <- '' } filename <- paste(path, country, mskname, name, ".grd", sep="") if (!file.exists(filename)) { zipfilename <- filename extension(zipfilename) <- '.zip' if (!file.exists(zipfilename)) { if (download) { theurl <- paste("https://biogeo.ucdavis.edu/data/diva/", mskpath, name, "/", country, mskname, name, ".zip", sep="") .download(theurl, zipfilename) if (!file.exists(zipfilename)) { message("\nCould not download file -- perhaps it does not exist") } } else { message("File not available locally. Use 'download = TRUE'") } } ff <- utils::unzip(zipfilename, exdir=dirname(zipfilename)) if (!keepzip) { file.remove(zipfilename) } } if (file.exists(filename)) { rs <- raster(filename) } else { #patrn <- paste(country, '.', mskname, name, ".grd", sep="") #f <- list.files(path, pattern=patrn) f <- ff[substr(ff, nchar(ff)-3, nchar(ff)) == '.grd'] if (length(f)==0) { warning('something went wrong') return(NULL) } else if (length(f)==1) { rs <- raster(f) } else { rs <- sapply(f, raster) message('returning a list of RasterLayer objects') return(rs) } } projection(rs) <- "+proj=longlat +datum=WGS84" return(rs) } .SRTM <- function(lon, lat, download, path) { stopifnot(lon >= -180 & lon <= 180) stopifnot(lat >= -60 & lat <= 60) rs <- raster(nrows=24, ncols=72, xmn=-180, xmx=180, ymn=-60, ymx=60 ) rowTile <- rowFromY(rs, lat) colTile <- colFromX(rs, lon) if (rowTile < 10) { rowTile <- paste('0', rowTile, sep='') } if (colTile < 10) { colTile <- paste('0', colTile, sep='') } baseurl <- "https://srtm.csi.cgiar.org/wp-content/uploads/files/srtm_5x5/TIFF/" f <- paste0("srtm_", colTile, "_", rowTile, ".zip") zipfilename <- file.path(path, f) tiffilename <- file.path(path, gsub(".zip$", ".tif", f)) if (!file.exists(tiffilename)) { if (!file.exists(zipfilename)) { if (download) { theurl <- paste0(baseurl, f) test <- try (.download(theurl, zipfilename) , silent=TRUE) if (inherits(test, "try-error")) { stop("cannot download the file") } } else {message("file not available locally, use download=TRUE") } } if (file.exists(zipfilename)) { utils::unzip(zipfilename, exdir=dirname(zipfilename)) file.remove(zipfilename) } } if (file.exists(tiffilename)) { rs <- raster(tiffilename) projection(rs) <- "+proj=longlat +datum=WGS84" return(rs) } else { stop('file not found') } } #.SRTM(lon=5.5, lat=44.5, TRUE, ".") raster/R/RcppExports.R0000644000176200001440000000642414507510157014402 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 .doBilinear <- function(xy, x, y, v) { .Call(`_raster_doBilinear`, xy, x, y, v) } .broom <- function(d, f, dm, dist, down) { .Call(`_raster_broom`, d, f, dm, dist, down) } .doCellFromRowCol <- function(nrow, ncol, rownr, colnr) { .Call(`_raster_doCellFromRowCol`, nrow, ncol, rownr, colnr) } .clamp <- function(d, r, usevals) { .Call(`_raster_do_clamp`, d, r, usevals) } .edge <- function(d, dim, classes, edgetype, dirs) { .Call(`_raster_do_edge`, d, dim, classes, edgetype, dirs) } .focal_fun <- function(d, w, dim, fun, naonly) { .Call(`_raster_do_focal_fun`, d, w, dim, fun, naonly) } .focal_get <- function(d, dim, ngb) { .Call(`_raster_do_focal_get`, d, dim, ngb) } .focal_sum <- function(d, w, dim, narm, naonly, bemean) { .Call(`_raster_do_focal_sum`, d, w, dim, narm, naonly, bemean) } .getPolygons <- function(xyv, res, nodes) { .Call(`_raster_getPolygons`, xyv, res, nodes) } .layerize <- function(d, cls, falsena) { .Call(`_raster_layerize`, d, cls, falsena) } .availableRAM <- function(ram) { .Call(`_raster_availableRAM`, ram) } .getMode <- function(values, ties) { .Call(`_raster_getMode`, values, ties) } .doSpmin <- function(x, y) { .Call(`_raster_doSpmin`, x, y) } .doSpmax <- function(x, y) { .Call(`_raster_doSpmax`, x, y) } .ppmin <- function(x, y, narm) { .Call(`_raster_ppmin`, x, y, narm) } .ppmax <- function(x, y, narm) { .Call(`_raster_ppmax`, x, y, narm) } .doRowMin <- function(x, narm) { .Call(`_raster_doRowMin`, x, narm) } .doRowMax <- function(x, narm) { .Call(`_raster_doRowMax`, x, narm) } .aggregate_get <- function(d, dims) { .Call(`_raster_aggregate_get`, d, dims) } .aggregate_fun <- function(d, dims, narm, fun) { .Call(`_raster_aggregate_fun`, d, dims, narm, fun) } .get_area_polygon <- function(d, lonlat) { .Call(`_raster_get_area_polygon`, d, lonlat) } .point_distance <- function(p1, p2, lonlat, a, f) { .Call(`_raster_point_distance`, p1, p2, lonlat, a, f) } .distanceToNearestPoint <- function(d, p, lonlat, a, f) { .Call(`_raster_distanceToNearestPoint`, d, p, lonlat, a, f) } .directionToNearestPoint <- function(d, p, lonlat, degrees, from, a, f) { .Call(`_raster_directionToNearestPoint`, d, p, lonlat, degrees, from, a, f) } .dest_point <- function(xybd, lonlat, a, f) { .Call(`_raster_dest_point`, xybd, lonlat, a, f) } .reclassify <- function(d, rcl, dolowest, doright, doleftright, NAonly, NAval) { .Call(`_raster_reclassify`, d, rcl, dolowest, doright, doleftright, NAonly, NAval) } .terrain <- function(d, dim, res, unit, option, geo, gy) { .Call(`_raster_do_terrains`, d, dim, res, unit, option, geo, gy) } .doCellFromXY <- function(ncols, nrows, xmin, xmax, ymin, ymax, x, y) { .Call(`_raster_doCellFromXY`, ncols, nrows, xmin, xmax, ymin, ymax, x, y) } .doXYFromCell <- function(ncols, nrows, xmin, xmax, ymin, ymax, cell) { .Call(`_raster_doXYFromCell`, ncols, nrows, xmin, xmax, ymin, ymax, cell) } .doFourCellsFromXY <- function(ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat) { .Call(`_raster_doFourCellsFromXY`, ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat) } raster/R/layerize.R0000644000176200001440000001012014507510157013721 0ustar liggesusers# Author: Robert J. Hijmans # Date : August 2012 # Version 1.0 # Licence GPL v3 setMethod('layerize', signature(x='RasterLayer', y='missing'), function(x, classes=NULL, falseNA=FALSE, filename='', ...) { doC <- list(...)$doC if (is.null(doC)) doC <- TRUE if (is.null(classes)) { classes <- as.integer( sort(unique(x)) ) } else { classes <- as.integer(classes) } out <- raster(x) if (length(classes) > 1) { out <- brick(out, nl=length(classes)) } names(out) <- classes if (canProcessInMemory(out)) { v <- as.integer(getValues(x)) if (doC) { v <- .layerize(v, as.integer(classes), falseNA) v <- matrix(v, ncol=length(classes)) } else { v <- t( apply(matrix(v), 1, function(x) x == classes) ) if (falseNA) { v[!v] <- NA } } # alternative approach (assuming sorted classes) # alternative approach (assuming sorted classes) # vv <- cbind(1:length(v), as.integer(as.factor(v))) # if (falseNA) { # v <- matrix(NA, nrow=ncell(out), ncol=nlayers(out)) # } else { # v <- matrix(0, nrow=ncell(out), ncol=nlayers(out)) # } # v[vv] <- 1 out <- setValues(out, v*1) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } # else to disk ## out <- writeStart(out, filename=filename, datatype='INT2S', ...) # } else { out <- writeStart(out, filename=filename, ...) # } tr <- blockSize(out) pb <- pbCreate(tr$n, label='layerize', ...) #fNA <- as.integer(falseNA) if (doC) { for (i in 1:tr$n) { v <- as.integer(getValues(x, tr$row[i], tr$nrows[i])) v <- .layerize(v, classes, falseNA) v <- matrix(v, ncol=length(classes)) out <- writeValues(out, v*1, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- t( apply(matrix(v, ncol=1), 1, function(x) x == classes) ) if (falseNA) { v[!v] <- NA } out <- writeValues(out, v*1, tr$row[i]) pbStep(pb, i) } } pbClose(pb) writeStop(out) } ) setMethod('layerize', signature(x='RasterLayer', y='RasterLayer'), function(x, y, classes=NULL, filename='', ...) { resx <- res(x) resy <- res(y) if (! all( resy > resx) ) { stop("x and y resolution of object y should be (much) larger than that of object x") } int <- intersect(extent(x), extent(y)) if (is.null(int)) { return(raster(y)) } if (is.null(classes)) { classes <- as.integer( sort(unique(x))) } out <- raster(y) if (length(classes) > 1) { out <- brick(out, nl=length(classes)) } names(out) <- paste('count_', as.character(classes), sep='') if (canProcessInMemory( out )) { b <- crop(x, int) xy <- xyFromCell(b, 1:ncell(b)) mc <- cellFromXY(out, xy) b <- as.integer(getValues(b)) if (!is.null(classes)) { b[! b %in% classes] <- NA } v <- table(mc, b) cells <- as.integer(rownames(v)) m <- match(cells, 1:ncell(out)) cn <- as.integer(colnames(v)) res <- matrix(NA, nrow=ncell(out), ncol=length(cn)) for (i in 1:length(cn)) { res[m,i] <- v[,i] } names(out) <- paste('count_', as.character(cn), sep='') out <- setValues(out, res) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } # else out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='layerize', ...) for(i in 1:tr$n) { e <- extent(xmin(y), xmax(y), yFromRow(y, tr$row[i]+tr$nrows[i]-1) - 0.5 * yres(y), yFromRow(y, tr$row[i])+0.5 * yres(y)) int <- intersect(e, extent(x)) res <- matrix(NA, nrow=tr$nrows[i] * ncol(y), ncol=length(classes)) if (!is.null(int)) { b <- crop(x, int) xy <- xyFromCell(b, 1:ncell(b)) mc <- cellFromXY(y, xy) v <- table(mc, as.integer(getValues(b))) cells <- as.integer(rownames(v)) modcells <- cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+ tr$nrows[i]-1, ncol(y)) m <- match(cells, modcells) cn <- as.integer(colnames(v)) mm <- match(cn, classes) for (j in 1:length(cn)) { res[, mm[j]] <- v[, j] } } out <- writeValues(out, res, tr$row[i]) } out <- writeStop(out) pbClose(pb) out } ) raster/R/stack.R0000644000176200001440000001214214507510157013210 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2008 # Version 0.9 # Licence GPL v3 setMethod("stack", signature(x='missing'), function(x) { return(methods::new("RasterStack")) } ) setMethod("stack", signature(x='Raster'), function(x, ..., layers=NULL) { rlist <- list(x, ...) if ( length(rlist) == 1 ) { if (inherits(x, 'RasterLayer')) { stack(rlist) } else if (inherits(x, 'RasterBrick')) { return( .stackFromBrick(x, bands=layers) ) } else { # RasterStack return(x) } } else { stack( .makeRasterList(rlist) ) } } ) setMethod("stack", signature(x='character'), function(x, ..., bands=NULL, varname="", native=FALSE, RAT=TRUE, quick=FALSE) { if (length(x) == 0) { stop("no filenames supplied") } rlist <- c(x, list(...)) if ( varname != "") { if (length(rlist) == 1) { return(.stackCDF(x, varname=varname, bands=bands)) } else { s <- stack(sapply(rlist, function(i) stack(i, varname=varname, bands=bands))) return(s) } } else { if (length(rlist) == 1) { return(.quickStackOneFile(x, bands=bands, native=native)) } else if (quick) { if (!is.null(bands)) { stop("cannot do 'quick' if bands is not NULL") } return(.quickStack(rlist, native=native)) } return(stack(rlist, bands=bands, native=native, RAT=RAT)) } } ) setMethod("stack", signature(x='list'), function(x, bands=NULL, native=FALSE, RAT=TRUE, ...) { if (inherits(x, 'data.frame')) { return(utils::stack(x, ...)) } lstnames <- names(x) if (is.null(lstnames)) { namesFromList <- FALSE } else { lstnames <- validNames(lstnames) namesFromList <- TRUE } # first try simplest case, all RasterLayer objects cls <- sapply(x, function(i) inherits(i, 'RasterLayer')) if (all(cls)) { hd <- sapply(x, function(i) hasValues(i) ) if (!all(hd)) { if (sum(hd) == 0) { s <- methods::new("RasterStack") s@nrows <- x[[1]]@nrows s@ncols <- x[[1]]@ncols s@extent <- x[[1]]@extent crs(s) <- crs(x[[1]]) return(s) } warning('RasterLayer objects without cell values were removed') x <- x[hd] } if (length(x) > 1) { compareRaster(x) } s <- methods::new("RasterStack") s@nrows <- x[[1]]@nrows s@ncols <- x[[1]]@ncols s@extent <- x[[1]]@extent crs(s) <- crs(x[[1]]) s@layers <- x if (namesFromList) { names(s) <- lstnames } else { names(s) <- sapply(x, names) } return(s) } r <- list() if (is.character(x[[1]])) { first <- raster(x[[1]], native=native, RAT=RAT, ...) } else { first <- raster(x[[1]]) } if (!is.null(bands)) { lb <- length(bands) bands <- bands[bands %in% 1:nbands(first)] if (length(bands) == 0) { stop('no valid bands supplied') } if (length(bands) < lb) { warning('invalid band numbers ignored') } } j <- 1 for (i in seq(along.with=x)) { if (is.character(x[[i]])) { if (!is.null(bands)) { for (b in bands) { r[[j]] <- raster(x[[i]], band=b, native=native, RAT=RAT, ...) if (namesFromList) { names(r[[j]]) <- paste(lstnames[i], '_', b, sep='') } j <- j + 1 } } else { r[[j]] <- raster(x[[i]], band=1, native=native, RAT=RAT, ...) bds <- nbands(r[[j]]) if (namesFromList) { if (bds > 1) { names(r[[j]]) <- paste(lstnames[i], '_1', sep='') } else { names(r[[j]]) <- lstnames[i] } } j <- j + 1 if (bds > 1) { for (b in 2:bds) { r[[j]] <- raster(x[[i]], band=b, native=native, RAT=RAT, ...) if (namesFromList) { names(r[[j]]) <- paste(lstnames[i], '_', b, sep='') } j <- j + 1 } } } } else if (methods::extends(class(x[[i]]), "Raster")) { if (inherits(x[[i]], 'RasterStackBrick')) { # commented on 2012/11/21 because bands should # only refer to files, not to layers in Raster objects # if (!is.null(bands)) { # for (b in bands) { # r[j] <- raster(x[[i]], b) # j <- j + 1 # } # } else { if (inherits(x[[i]], 'RasterBrick')) { x[[i]] <- stack(x[[i]]) } r <- c(r, x[[i]]@layers) j <- j + nlayers(x[[i]]) # } } else { r[[j]] <- x[[i]] if (namesFromList) { names(r[[j]]) <- lstnames[i] } j <- j + 1 } } else { stop("Arguments should be Raster* objects or filenames") } } if ( length(r) == 1 ) { r <- r[[1]] if ( hasValues(r) ) { return( addLayer( methods::new("RasterStack"), r) ) } else { x <- methods::new("RasterStack") x@nrows <- r@nrows x@ncols <- r@ncols x@extent <- r@extent crs(x) <- crs(r) if(rotated(r)) { x@rotated = r@rotated x@rotation = r@rotation } return(x) } } else { return(addLayer(methods::new("RasterStack"), r)) } } ) setMethod("stack", signature(x='SpatialGridDataFrame'), function(x, ...) { .stackFromBrick(brick(x), ...) } ) setMethod("stack", signature(x='SpatialPixelsDataFrame'), function(x, ...) { x <- as(x, 'SpatialGridDataFrame') .stackFromBrick(brick(x), ...) } ) setMethod('stack', signature(x='kasc'), function(x) { as(x, 'RasterStack') } ) setMethod('stack', signature(x='SpatRaster'), function(x) { x <- as(x, "Raster") stack(x) } ) raster/R/hdrSAGA.R0000644000176200001440000000315114507510157013314 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrSAGA <- function(x) { hdrfile <- filename(x) hdrfile <- .setFileExtensionHeader(hdrfile, 'SAGA') thefile <- file(hdrfile, "w") # open an txt file connectionis cat("NAME\t=", names(x), "\n", file = thefile) cat("DESCRIPTION\t= \n", file = thefile) cat("UNIT\t= \n", file = thefile) dtype <- .shortDataType(x@file@datanotation) dsize <- dataSize(x@file@datanotation) if (dtype == 'INT' ) { if (dsize == 1) { pixtype <- "BYTE" } else if (dsize == 2) { pixtype <- "SHORTINT" } else if (dsize == 4) { pixtype <- "INTEGER" } if (! dataSigned(x@file@datanotation)) { pixtype <- paste(pixtype, "_UNSIGNED", sep="") } } else if ( x@file@datanotation == 'FLT4S' ) { pixtype <- "FLOAT" } else { stop(paste('cannot write SAGA file with data type:', x@file@datanotation)) } cat("DATAFORMAT\t=", pixtype, "\n", file = thefile) cat("DATAFILE_OFFSET\t= 0\n", file = thefile) cat("BYTEORDER_BIG\t=", x@file@byteorder != 'little', "\n", file = thefile) cat("POSITION_XMIN\t= ", as.character(xmin(x) + 0.5 * xres(x)), "\n", file = thefile) cat("POSITION_YMIN\t= ", as.character(ymin(x) + 0.5 * yres(x)), "\n", file = thefile) cat("CELLCOUNT_Y\t= ", nrow(x), "\n", file = thefile) cat("CELLCOUNT_X\t= ", ncol(x), "\n", file = thefile) cat("CELLSIZE\t= ", xres(x), "\n", file = thefile) cat("Z_FACTOR\t= 1.000000\n", file = thefile) cat("NODATA_VALUE\t=", .nodatavalue(x), "\n", file = thefile) cat("TOPTOBOTTOM\t= TRUE", "\n", file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/print.R0000644000176200001440000000707114507510157013244 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 setMethod ('print', 'Raster', function(x, ...) { if (inherits(x, 'RasterStack')) { show(x) } else { if (x@file@driver == 'netcdf') { nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) print(nc) ncdf4::nc_close(nc) } else if (any(is.factor(x))) { cat('factor levels (value attributes)\n') f <- x@data@attributes for (i in 1:length(f)) { ff <- f[[i]] if (!is.null(ff)) { if (nrow(ff) > 15) { ff <- ff[1:15,] } print(ff) } } # cat('levels :' , paste(object@data@levels, collapse=', '), '\n') # cat('labels :' , paste(object@data@labels, collapse=', '), '\n') } else { methods::callNextMethod(x, ...) } } } ) setMethod ('show' , 'Spatial', function(object) { .printSpatial(object) } ) setMethod ('show' , 'SpatialPoints', function(object) { .printSpatial(object) } ) setMethod ('show' , 'SpatialPointsDataFrame', function(object) { .printSpatial(object) } ) setMethod ('print' , 'Spatial', function(x, ...) { .printSpatial(x) } ) .printSpatial <- function(x, ...) { cat('class :' , class(x), '\n') isRaster <- hasData <- FALSE nc <- 0 if (.hasSlot(x, 'data')) { nc <- ncol(x@data) hasData <- TRUE } ln <- 1 if (inherits(x, 'SpatialPixels')) { isRaster <- TRUE cr <- x@grid@cells.dim cat ('dimensions : ', cr[2], ', ', cr[1], ', ', nrow(x@coords), ', ', nc, ' (nrow, ncol, npixels, nlayers)\n', sep="" ) cs <- x@grid@cellsize cat ('resolution : ', cs[1], ', ', cs[2], ' (x, y)\n', sep="") } else if (inherits(x, 'SpatialGrid')) { isRaster <- TRUE cr <- x@grid@cells.dim cat ('dimensions : ', cr[2], ', ', cr[1], ', ', prod(cr), ', ', nc, ' (nrow, ncol, ncell, nlayers)\n', sep="" ) cs <- x@grid@cellsize cat ('resolution : ', cs[1], ', ', cs[2], ' (x, y)\n', sep="") } else { nf <- length(x) cat('features :' , nf, '\n') } e <- sp::bbox(x) if (nf > 0) { cat('extent : ' , e[1,1], ', ', e[1,2], ', ', e[2,1], ', ', e[2,2], ' (xmin, xmax, ymin, ymax)\n', sep="") } cat('crs :' , x@proj4string@projargs, '\n') if (hasData) { x <- x@data maxnl <- 15 if (! isRaster) { cat('variables : ', nc, '\n', sep="" ) } if (nc > 0) { if (nc > maxnl) { x <- x[, 1:maxnl] } ln <- colnames(x) if (nc > maxnl) { ln <- c(ln[1:maxnl], '...') x <- x[, 1:maxnl] } wrn <- getOption('warn') on.exit(options('warn' = wrn)) options('warn'=-1) # r <- apply(x, 2, range, na.rm=TRUE) # can give bad sorting (locale dependent) # because as.matrix can add whitespace to numbers rangefun <- function(x) { if(is.factor(x)) { range(as.character(x), na.rm=TRUE) } else { range(x, na.rm=TRUE) } } r <- sapply(x, rangefun) i <- r[1,] == "Inf" r[,i] <- NA minv <- as.vector(r[1, ]) maxv <- as.vector(r[2, ]) if (nc > maxnl) { minv <- c(minv, '...') maxv <- c(maxv, '...') } w <- pmax(nchar(ln), nchar(minv), nchar(maxv)) w[is.na(w)] <- 2 m <- rbind(ln, minv, maxv) # a loop because 'width' is not recycled by format for (i in 1:ncol(m)) { m[,i] <- format(m[,i], width=w[i], justify="right") } cat('names :', paste(m[1,], collapse=', '), '\n') if (nf > 1) { cat('min values :', paste(m[2,], collapse=', '), '\n') cat('max values :', paste(m[3,], collapse=', '), '\n') } else if (nf == 1) { cat('value :', paste(m[2,], collapse=', '), '\n') } } } } raster/R/rasterizePolygons.R0000644000176200001440000004355514507510157015662 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 2.0 # Licence GPL v3 .getPutVals <- function(obj, field, n, mask) { if (mask) { return( data.frame(v=rep(1, length=n)) ) } else if (missing(field)) { if (.hasSlot(obj, 'data')) { putvals <- obj@data cn <- validNames(c('ID', colnames(putvals))) cn[1] <- 'ID' putvals <- data.frame(ID=1:nrow(putvals), putvals) colnames(putvals) <- cn } else { putvals <- data.frame(v=as.integer(1:n)) } return(putvals) } else if (isTRUE (is.na(field))) { return( data.frame(v=rep(NA, n)) ) } else if (is.character(field) ) { if (.hasSlot(obj, 'data')) { nms <- names(obj) if (length(field) <= length(nms)) { m <- match(field, nms) if (!all(is.na(m))) { m <- stats::na.omit(m) return(obj@data[, m, drop=FALSE]) } } } } if (NROW(field) == n) { if (is.null(nrow(field))) { return(data.frame(field, stringsAsFactors=FALSE)) } else { return(field) } } if (is.numeric(field)) { putvals <- rep(field, length.out=n) return(data.frame(field=putvals)) } stop('invalid value for field') } .intersectSegments <- function(x1, y1, x2, y2, x3, y3, x4, y4) { # Translated by RH from LISP code by Paul Reiners # http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/linesegments.lisp # Which was translated from the algorithm by Paul Bourke given here: http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ denom <- ((y4 - y3) * (x2 - x1)) - ((x4 - x3) * (y2 - y1)) ua_num <- ((x4 - x3) *(y1 - y3)) - ((y4 - y3) * (x1 - x3)) ub_num <- ((x2 - x1) *(y1 - y3)) - ((y2 - y1) * (x1 - x3)) # If the denominator and numerator for the equations for ua and ub are 0 then the two lines are coincident. if ( denom == 0 ) { if (ua_num == 0 & ub_num == 0) { xmin <- max(x1, x3) if (xmin==x1) {ymin <- y1} else {ymin <- y3} xmax <- min(x2, x4) if (xmax==x2) {ymax <- y2} else {ymax <- y4} # RH: for coincident line (segments) returning two intersections : start and end return(rbind(c(xmin, ymin), c(xmax, ymax))) } #else { # If the denominator for the equations for ua and ub is 0 then the two lines are parallel. # return(c(NA, NA)) # } } else { ua <- round(ua_num / denom, 12) ub <- round(ub_num / denom, 12) if ((ua >= 0 & ua <= 1) & (ub >= 0 & ub <= 1) ) { x <- x1 + ua * (x2 - x1) y <- y1 + ua * (y2 - y1) return(c(x, y)) } } return(c(NA, NA)) } .intersectLinePolygon <- function(line, poly) { resxy <- matrix(NA, ncol=2, nrow=0) miny <- min(line[,2]) maxy <- max(line[,2]) xyxy <- cbind(poly, rbind(poly[-1,], poly[1,])) xyxy <- subset(xyxy, !( (xyxy[,2] > maxy & xyxy[,4] > maxy ) | (xyxy[,2] < miny & xyxy[,4] < miny)) ) if (nrow(xyxy) == 0) { return(resxy) } for (i in 1:nrow(xyxy)) { xy <- .intersectSegments(xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4], line[1,1], line[1,2], line[2,1], line[2,2] ) if (!is.na(xy[1])) { resxy <- rbind(resxy, xy) } } return((resxy)) } .polygonsToRaster <- function(p, rstr, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue="all", getCover=FALSE, filename="", silent=TRUE, faster=TRUE, ...) { npol <- length(p@polygons) pvals <- .getPutVals(p, field, npol, mask) putvals <- pvals[,1] if (ncol(pvals) > 1) { rstr@data@isfactor <- TRUE rstr@data@attributes <- list(pvals) if (!is.character(fun)) { stop('when rasterizing multiple fields you must use "fun=first" or "fun=last"') } else if (!(fun %in% c('first', 'last'))) { stop('when rasterizing multiple fields you must use "fun=first" or "fun=last"') } } if (getCover) { nc <- ncell(rstr) # high precision for possibly small polygons #https://stackoverflow.com/questions/53854910/issue-with-estimating-weighted-mean-from-raster-for-a-polygon-shape-in-r/ fctr <- ifelse(nc < 5, 100, ifelse(nc < 17, 20, 10)) rstr <- disaggregate(raster(rstr), fctr) r <- .fasterize(p, rstr, rep(1, npol), background=0, datatype="INT1U") return( aggregate(r, fctr, mean, na.rm=TRUE, filename=filename, ...) ) } ### new code if (is.character(fun) && (ncol(pvals) == 1) && faster) { if (fun == "last") { if (mask || update) { if (mask && update) stop("either use 'mask' OR 'update'") background = NA r <- .fasterize(p, rstr, pvals[,1], background) if (! hasValues(r)) { if (mask) { warning('there are no values to mask') } else { warning('there are no values to update') } return(r) } if (mask) { r <- mask(rstr, r) } else { if (updateValue[1]=="all") { r <- cover(r, rstr) } else if (updateValue[1]=="NA") { r <- cover(rstr, r, ...) } else if (updateValue[1]=="!NA") { r <- mask(cover(r, rstr), rstr, ...) } else { s <- stack(r, rstr) r <- overlay(rstr, r, fun=function(x,y){ i = (x %in% updateValue & !is.na(y)); x[i] <- y[i]; x }, ... ) } } return(r) } else { return( .fasterize(p, rstr, pvals[,1], background, filename, ...) ) } } } ### end new code leftColFromX <- function ( object, x ) { colnr <- (x - xmin(object)) / xres(object) i <- colnr %% 1 == 0 colnr[!i] <- trunc(colnr[!i]) + 1 colnr[colnr <= 0] <- 1 colnr } rightColFromX <- function ( object, x ) { colnr <- trunc((x - xmin(object)) / xres(object)) + 1 colnr[ colnr > ncol(object) ] <- object@ncols colnr } if (! inherits(p, 'SpatialPolygons') ) { stop('The first argument should be an object of the "SpatialPolygons*" lineage') } filename <- trim(filename) if (!canProcessInMemory(rstr, 3) && filename == '') { filename <- rasterTmpFile() } if (mask & update) { stop('use either "mask" OR "update"') } else if (mask) { oldraster <- rstr #update <- TRUE } else if (update) { oldraster <- rstr if (!is.numeric(updateValue)) { if (is.na(updateValue)) { updateValue <- 'NA' } else if (!(updateValue == 'NA' | updateValue == '!NA' | updateValue == 'all')) { stop('updateValue should be either "all", "NA", "!NA"') } } } rstr <- raster(rstr) if (!is.na(projection(p))) { projection(rstr) <-.getCRS(p) } # check if bbox of raster and p overlap spbb <- sp::bbox(p) rsbb <- bbox(rstr) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # instead of a warning return( init(rstr, function(x) NA) ) # so that clusterR can use this function (overlap with some chunks might be NULL) } npol <- length(p@polygons) pvals <- .getPutVals(p, field, npol, mask) putvals <- pvals[,1] if (ncol(pvals) > 1) { rstr@data@isfactor <- TRUE rstr@data@attributes <- list(pvals) if (!is.character(fun)) { stop('when rasterizing multiple values you must use "fun=first" or "fun=last"') } else if (!(fun %in% c('first', 'last'))) { stop('when rasterizing multiple values you must use "fun=first" or "fun=last"') } } if (is.character(fun)) { if (fun=='first') { fun <- function(x, ...){ stats::na.omit(x)[1] } } else if (fun=='last') { fun <- function(x, ...){ rev(stats::na.omit(x))[1] } } else if (fun == 'count') { fun <- function(x, ...){ sum(!is.na(x)) } field <- 1 } } polinfo <- data.frame(matrix(NA, nrow=npol * 2, ncol=6)) colnames(polinfo) <- c('part', 'miny', 'maxy', 'value', 'hole', 'object') addpol <- polinfo[rep(1, 500), ] rownames(addpol) <- NULL pollist <- list() cnt <- 0 for (i in 1:npol) { nsubpol <- length(p@polygons[[i]]@Polygons) for (j in 1:nsubpol) { cnt <- cnt + 1 if (cnt > dim(polinfo)[1]) { polinfo <- rbind(polinfo, addpol) } polinfo[cnt, 1] <- cnt polinfo[cnt, 2] <- min(p@polygons[[i]]@Polygons[[j]]@coords[,2]) polinfo[cnt, 3] <- max(p@polygons[[i]]@Polygons[[j]]@coords[,2]) polinfo[cnt, 4] <- putvals[i] if ( p@polygons[[i]]@Polygons[[j]]@hole ) { polinfo[cnt, 5] <- 1 } else { polinfo[cnt, 5] <- 0 } polinfo[cnt, 6] <- i pollist[[cnt]] <- p@polygons[[i]]@Polygons[[j]] } } if (! silent) { message('Found ', npol, ' region(s) and ', cnt, ' polygon(s)') } polinfo <- subset(polinfo, polinfo[,1] <= cnt, drop=FALSE) # polinfo <- polinfo[order(polinfo[,1]),] # rm(p) lxmin <- min(spbb[1,1], rsbb[1,1]) - xres(rstr) lxmax <- max(spbb[1,2], rsbb[1,2]) + xres(rstr) # if (getCover) { # return (.polygoncover(rstr, filename, polinfo, lxmin, lxmax, pollist, ...)) # } adj <- 0.5 * xres(rstr) if (filename == "") { v <- matrix(NA, ncol=nrow(rstr), nrow=ncol(rstr)) } else { rstr <- writeStart(rstr, filename=filename, ...) } rxmn <- xmin(rstr) rxmx <- xmax(rstr) rv1 <- rep(NA, ncol(rstr)) holes1 <- rep(0, ncol(rstr)) pb <- pbCreate(nrow(rstr), label='rasterize', ...) for (r in 1:nrow(rstr)) { vals <- NULL holes <- holes1 ly <- yFromRow(rstr, r) myline <- rbind(c(lxmin,ly), c(lxmax,ly)) subpol <- subset(polinfo, !(polinfo[,2] > ly | polinfo[,3] < ly), drop=FALSE) if (length(subpol[,1]) > 0) { updateHoles <- FALSE lastpolnr <- subpol[1,6] rvtmp <- rv1 for (i in 1:nrow(subpol)) { if (i == nrow(subpol)) { updateHoles <- TRUE } else if (subpol[i+1,6] > lastpolnr) { # new polygon updateHoles <- TRUE lastpolnr <- subpol[i+1,6] } mypoly <- pollist[[subpol[i,1]]] intersection <- .intersectLinePolygon(myline, mypoly@coords) #if (nrow(intersection) %% 2 == 1) { # this is a bit speculative # not OK! # intersection <- unique(intersection) #} x <- sort(intersection[,1]) if (length(x) > 0) { if ((nrow(intersection) %% 2 == 1) || ( sum(x[-length(x)] == x[-1]) > 0 )) { # uneven number or duplicates # e.g. single node intersection going out of polygon .... spPnts <- sp::SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr)))) spPol <- sp::SpatialPolygons(list(sp::Polygons(list(mypoly), 1))) over <- sp::over(spPnts, spPol) if ( subpol[i, 5] == 1 ) { holes[!is.na(over)] <- holes[!is.na(over)] - 1 } else { rvtmp[!is.na(over)] <- subpol[i,4] holes[!is.na(over)] <- holes[!is.na(over)] + 1 } # print(paste('exit node intersection on row:', r)) } else { for (k in 1:round(nrow(intersection)/2)) { l <- (k * 2) - 1 x1 <- x[l] x2 <- x[l+1] #if (is.na(x2)) { # txt <- paste('something funny at row:', r, 'polygon:',j) # stop(txt) #} # if (x1 > rxmx) { next } # if (x2 < rxmn) { next } # adjust to skip first cell if the center is not covered by this polygon x1a <- x1 + adj x2a <- x2 - adj if (x1a > rxmx) { next } if (x2a < rxmn) { next } x1a <- min(rxmx, max(rxmn, x1a)) x2a <- min(rxmx, max(rxmn, x2a)) col1 <- leftColFromX(rstr, x1a) col2 <- rightColFromX(rstr, x2a) if (col1 > col2) { spPnts <- sp::SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr)))) spPol <- sp::SpatialPolygons(list(sp::Polygons(list(mypoly), 1))) over <- sp::over(spPnts, spPol) if ( subpol[i, 5] == 1 ) { holes[!is.na(over)] <- holes[!is.na(over)] - 1 } else { rvtmp[!is.na(over)] <- subpol[i,4] holes[!is.na(over)] <- holes[!is.na(over)] + 1 } next } if ( subpol[i, 5] == 1 ) { holes[col1:col2] <- holes[col1:col2] - 1 } else { rvtmp[col1:col2] <- subpol[i,4] holes[col1:col2] <- holes[col1:col2] + 1 } } } } if (updateHoles) { updateHoles <- FALSE rvtmp[holes < 1] <- NA vals <- cbind(vals, rvtmp) rvtmp <- rv1 holes <- holes1 } } } #print(vals) rrv <- rv1 if (!is.null(vals)) { u <- which(rowSums(is.na(vals)) < ncol(vals)) if (length(u) > 0) { if (mask) { rrv[u] <- 1 } else { rrv[u] <- apply(vals[u, ,drop=FALSE], 1, fun, na.rm=TRUE) } } } if (mask) { oldvals <- getValues(oldraster, r) ind <- which(is.na(rrv)) oldvals[ind] <- NA rrv <- oldvals } else if (update) { oldvals <- getValues(oldraster, r) if (is.numeric(updateValue)) { ind <- which(oldvals == updateValue & !is.na(rrv)) } else if (updateValue == "all") { ind <- which(!is.na(rrv)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { "!NA" ind <- which(!is.na(oldvals) & !is.na(rrv)) } oldvals[ind] <- rrv[ind] rrv <- oldvals } else { rrv[is.na(rrv)] <- background } if (filename == "") { v[,r] <- rrv } else { # print(rrv) rstr <- writeValues(rstr, rrv, r) } pbStep(pb, r) } pbClose(pb) if (filename == "") { rstr <- setValues(rstr, as.vector(v)) } else { rstr <- writeStop(rstr) } return(rstr) } #plot( .polygonsToRaster(p, rstr) ) #...polygoncover <- function(p, x, filename, ...) { # d <- disaggregate(raster(x), 10) # r <- .polygonsToRaster(p, d, filename=filename, field=1, fun='first', background=0, mask=FALSE, update=FALSE, getCover=FALSE, silent=TRUE, ...) # aggregate(r, 10, sum) #} .Old_polygoncover <- function(rstr, filename, polinfo, lxmin, lxmax, pollist, ...) { # percentage cover per grid cell polinfo[, 4] <- 1 bigraster <- raster(rstr) rxmn <- xmin(bigraster) rxmx <- xmax(bigraster) f <- 10 adj <- 0.5 * xres(bigraster)/f nc <- ncol(bigraster) * f rv1 <- rep(0, nc) holes1 <- rep(0, nc) prj <-.getCRS(bigraster) hr <- 0.5 * yres(bigraster) vv <- matrix(ncol=f, nrow=nc) if (filename == "") { v <- matrix(NA, ncol=nrow(bigraster), nrow=ncol(bigraster)) } else { bigraster <- writeStart(bigraster, filename=filename, ...) } pb <- pbCreate(nrow(bigraster), label='rasterize', ...) for (rr in 1:nrow(bigraster)) { y <- yFromRow(bigraster, rr) yn <- y - hr yx <- y + hr rstr <- raster(xmn=rxmn, xmx=rxmx, ymn=yn, ymx=yx, ncols=nc, nrows=f, crs=prj) subpol <- subset(polinfo, !(polinfo[,2] > yx | polinfo[,3] < yn), drop=FALSE) for (r in 1:f) { rv <- rv1 ly <- yFromRow(rstr, r) myline <- rbind(c(lxmin,ly), c(lxmax,ly)) holes <- holes1 if (length(subpol[,1]) > 0) { updateHoles <- FALSE lastpolnr <- subpol[1,6] rvtmp <- rv1 for (i in 1:length(subpol[,1])) { if (i == length(subpol[,1])) { updateHoles <- TRUE } else if (subpol[i+1,6] > lastpolnr) { updateHoles <- TRUE lastpolnr <- subpol[i+1,6] } mypoly <- pollist[[subpol[i,1]]] intersection <- .intersectLinePolygon(myline, mypoly@coords) x <- sort(intersection[,1]) if (length(x) > 0) { #if (length(subpol[,1]) > 3 & i ==2) { # print('4') #} if ( sum(x[-length(x)] == x[-1]) > 0 ) { # single node intersection going out of polygon .... spPnts <- sp::SpatialPoints(xyFromCell(rstr, cellFromRowCol(rstr, rep(r, ncol(rstr)), 1:ncol(rstr)))) spPol <- sp::SpatialPolygons(list(sp::Polygons(list(mypoly), 1))) over <- sp::over(spPnts, spPol) if ( subpol[i, 5] == 1 ) { holes[!is.na(over)] <- holes[!is.na(over)] - 1 } else { rvtmp[!is.na(over)] <- subpol[i,4] holes[!is.na(over)] <- holes[!is.na(over)] + 1 } } else { for (k in 1:round(nrow(intersection)/2)) { l <- (k * 2) - 1 x1 <- x[l] x2 <- x[l+1] if (x1 > rxmx) { next } if (x2 < rxmn) { next } # adjust to skip first cell if the center is not covered by this polygon x1a <- x1 + adj x2a <- x2 - adj x1a <- min(rxmx, max(rxmn, x1a)) x2a <- min(rxmx, max(rxmn, x2a)) col1 <- colFromX(rstr, x1a) col2 <- colFromX(rstr, x2a) if (col1 > col2) { next } if ( subpol[i, 5] == 1 ) { holes[col1:col2] <- holes[col1:col2] - 1 } else { rvtmp[col1:col2] <- subpol[i,4] holes[col1:col2] <- holes[col1:col2] + 1 } } } if (updateHoles) { holes <- holes < 1 rvtmp[holes] <- 0 holes <- holes1 updateHoles <- FALSE rv <- pmax(rv, rvtmp) } } } } vv[,r] <- rv } av <- colSums( matrix( rowSums(vv), nrow=f) ) if (filename == "") { v[,rr] <- av } else { bigraster <- writeValues(bigraster, av, rr) } pbStep(pb, rr) } pbClose(pb) if (filename == "") { bigraster <- setValues(bigraster, as.vector(v)) } else { bigraster <- writeStop(bigraster) } return(bigraster) } #x = .polygoncover(rstr, "", polinfo, lxmin, lxmax, pollist) .polygonsToRaster2 <- function(p, raster, field=0, filename="", ...) { # This is based on sampling by points. Should be slower except when polygons very detailed and raster has low resolution # but it could be optimized further # currently not used. Perhaps it should be used under certain conditions. # this version does not deal with polygon holes # check if bbox of raster and p overlap filename <- trim(filename) raster <- raster(raster) spbb <- sp::bbox(p) rsbb <- bbox(raster) if (spbb[1,1] > rsbb[1,2] | spbb[2,1] > rsbb[2,2]) { stop('polygon and raster have no overlapping areas') } if (inherits(p, 'SpatialPolygons') || (field == 0)) { putvals <- 1:length(p@polygons) } else { putvals <- as.vector(p@data[,field]) if (inherits(putvals, 'character')) { stop('selected field is charater type') } } if (filename == "") { v <- vector(length=0) # replace this } else { raster <- writeStart(raster, filename=filename, ...) } rowcol <- cbind(0, 1:ncol(raster)) firstrow <- rowFromY(raster, spbb[2,2]) lastrow <- rowFromY(raster, spbb[2,1]) for (r in 1:nrow(raster)) { if (r < firstrow | r > lastrow) { vals <- rep(NA, times=ncol(raster)) } else { rowcol[,1] <- r sppoints <- xyFromCell(raster, cellFromRowCol(raster, rowcol[,1], rowcol[,2]), TRUE) over <- sp::over(sppoints, p) vals <- putvals[over] } if (filename == "") { v <- c(v, vals) } else { raster <- writeValues(raster, vals) } } if (filename == "") { raster <- setValues(raster, v) } else { raster <- writeStop(raster) } return(raster) } raster/R/barplot.R0000644000176200001440000000116614507510157013552 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 setMethod('barplot', 'RasterLayer', function(height, maxpixels=1000000, digits=0, breaks=NULL, col=rainbow, ...) { x <- sampleRegular(height, maxpixels) adj <- length(x) / ncell(height) if (adj < 1) { warning('a sample of ', round(100*adj, 1), '% of the raster cells were used to estimate frequencies') } if (!is.null(digits)) { x <- round(x, digits) } if (!is.null(breaks)) { x <- cut(x, breaks) } x <- table(x) / adj if (is.function(col)) { col <- col(length(x)) } barplot(x, col=col, ...) } ) raster/R/coverBrick.R0000644000176200001440000000432014507510157014173 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('cover', signature(x='RasterStackBrick', y='Raster'), function(x, y, ..., filename=''){ rasters <- .makeRasterList(x, y, ..., unstack=FALSE) compareRaster(rasters) nl <- sapply(rasters, nlayers) un <- unique(nl) if (length(un) > 3) { stop('number of layers does not match') } else if (length(un) == 2 & min(un) != 1) { stop('number of layers does not match') } else if (nl[1] != max(un)) { stop('number of layers of the first object must be the highest') } outRaster <- brick(x, values=FALSE) compareRaster(rasters) filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(filename=filename) } else { format <- dots$format } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } else { overwrite <- dots$overwrite } if (is.null(dots$progress)) { progress <- .progress() } else { progress <- dots$progress } if (is.null(dots$datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } else { datatype <- dots$datatype } if ( canProcessInMemory(x, sum(nl)+nl[1])) { v <- getValues( rasters[[1]] ) v2 <- v for (j in 2:length(rasters)) { v2[] <- getValues( rasters[[j]] ) v[is.na(v)] <- v2[is.na(v)] } outRaster <- setValues(outRaster, v) if (filename != '') { outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } } else { if (filename == '') { filename <- rasterTmpFile() } outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite) tr <- blockSize(outRaster, sum(nl)) pb <- pbCreate(tr$n, label='cover', progress=progress) for (i in 1:tr$n) { v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] ) v2 <- v for (j in 2:length(rasters)) { v2[] <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i]) v[is.na(v)] <- v2[is.na(v)] } outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) outRaster <- writeStop(outRaster) } return(outRaster) } ) raster/R/persp.R0000644000176200001440000000122314507510157013232 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod("persp", signature(x='RasterLayer'), function(x, maxpixels=100000, ext=NULL, ...) { x <- sampleRegular(x, size=maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) value <- t((getValues(x, format='matrix'))[nrow(x):1,]) y <- yFromRow(x, nrow(x):1) x <- xFromCol(x,1:ncol(x)) persp(x=x, y=y, z=value, ...) } ) setMethod("persp", signature(x='RasterStackBrick'), function(x, y=1, maxpixels=10000, ext=NULL, ...) { if (y < 1) { y <- 1 } if (y > nlayers(x)) { y <- nlayers(x) } x <- raster(x, y) persp(x=x, maxpixels=maxpixels, ext=ext, ...) } ) raster/R/index.R0000644000176200001440000000632114507510157013214 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("[", c("Extent", "numeric", "missing"), function(x, i, j, ... ,drop=TRUE) { x <- as.vector(x) x[i] }) setMethod("[", c("Extent", "missing", "missing"), function(x, i, j, ... ,drop=TRUE) { as.vector(x) }) setMethod("[", c("Raster", "Spatial", "missing"), function(x, i, j, ... ,drop=TRUE) { if (inherits(i, 'SpatialPoints')) { i <- sp::coordinates(i)[,1:2,drop=FALSE] i <- cellFromXY(x, i) .doExtract(x, i, ..., drop=drop) } else { if (drop) { extract(x, i, ...) } else { x <- crop(x, i, ...) rasterize(i, x, mask=TRUE, ...) } } }) setMethod("[", c("Raster", "RasterLayer", "missing"), function(x, i, j, ... ,drop=TRUE) { if (! hasValues(i) ) { i <- extent(i) methods::callNextMethod(x, i=i, ..., drop=drop) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { i <- which( as.logical( getValues(i) ) ) .doExtract(x, i, drop=drop) } else { i <- intersect(extent(x), extent(i)) methods::callNextMethod(x, i=i, ..., drop=drop) } }) setMethod("[", c("Raster", "Extent", "missing"), function(x, i, j, ... ,drop=TRUE) { if (drop) { return( extract(x, i) ) } else { return( crop(x, i) ) } } ) setMethod("[", c("Raster", "missing", "missing"), function(x, i, j, ... ,drop=TRUE) { if (drop) { return(getValues(x)) } else { return(x) } }) setMethod("[", c("Raster", "numeric", "numeric"), function(x, i, j, ... ,drop=TRUE) { i <- cellFromRowColCombine(x, i, j) .doExtract(x, i, drop=drop) } ) setMethod("[", c("Raster", "missing", "numeric"), function(x, i, j, ... ,drop=TRUE) { j <- cellFromCol(x, j) .doExtract(x, j, drop=drop) }) setMethod("[", c("Raster", "numeric", "missing"), function(x, i, j, ... ,drop=TRUE) { theCall <- sys.call(-1) narg <- length(theCall) - length(match.call(call=sys.call(-1))) if (narg > 0) { i <- cellFromRow(x, i) } .doExtract(x, i, drop=drop) }) setMethod("[", c("Raster", "matrix", "missing"), function(x, i, j, ... ,drop=TRUE) { if (ncol(i) == 2) { i <- cellFromRowCol(x, i[,1], i[,2]) } else { i <- as.vector(i) } .doExtract(x, i, drop=drop) }) setMethod("[", c("Raster", "logical", "missing"), function(x, i, j, ... , drop=TRUE) { theCall <- sys.call(-1) narg <- length(theCall) - length(match.call(call=sys.call(-1))) if (narg > 0) { stop('logical indices are only accepted if only the first index is used') } i <- which(i) .doExtract(x, i, drop=drop) }) .doExtract <- function(x, i, drop) { if (length(i) < 1) return(NULL) nacount <- sum(is.na(i)) if (nacount > 0) { warning('some indices are invalid (NA returned)') } if (!drop) { i <- stats::na.omit(i) r <- rasterFromCells(x, i, values=FALSE) if (nlayers(x) > 1) { r <- brick(r) if (hasValues(x)) { newi <- cellFromXY(r, xyFromCell(x, i)) v <- matrix(NA, nrow=ncell(r), ncol=nlayers(x)) v[newi,] <- .cellValues(x, i) r <- setValues(r, v) } return(r) } else { if (hasValues(x)) { newi <- cellFromXY(r, xyFromCell(x, i)) r[newi] <- .cellValues(x, i) } return(r) } } else { if (! hasValues(x) ) { stop('no data associated with this Raster object') } return( .cellValues(x, i) ) } } raster/R/clamp.R0000644000176200001440000000445514507510157013207 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2013 # Version 1.0 # Licence GPL v3 setMethod("clamp", signature(x="Raster"), function(x, lower=-Inf, upper=Inf, useValues=TRUE, filename="", ...) { if (!hasValues(x)) return(x) useValues <- as.integer(useValues) byCol = FALSE nl <- nlayers(x) if (nl == 1) { if ((length(lower) > 1) | (length(upper) > 1)) { warning("only the first element of lower/upper is used") lower <- lower[1] upper <- upper[1] } stopifnot(lower <= upper) out <- raster(x) crange <- c(lower, upper) } else { if ((length(lower) > 1) | (length(upper) > 1)) { lower = rep_len(lower, nl) upper = rep_len(upper, nl) stopifnot(all (lower <= upper) ) byCol = TRUE crange <- cbind(lower, upper) } else { stopifnot(lower <= upper) crange <- c(lower, upper) } out <- brick(x, values=FALSE) } names(out) <- names(x) if (byCol) { if (canProcessInMemory(out)) { v <- values(x) for (i in 1:ncol(v)) { v[,i] <- .clamp(v[,i], crange[i,], useValues) } out <- setValues(out, v) if (filename != "") { writeRaster(out, filename, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label="clamp", ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) for (j in 1:ncol(vals)) { vals[,j] <- .clamp(vals[,j], crange[j,], useValues) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } } else { if (canProcessInMemory(out)) { out <- setValues(out, .clamp(values(x), crange, useValues)) if (filename != "") { writeRaster(out, filename, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label="clamp", ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) vals <- .clamp(vals, crange, useValues) if (nl > 1) { vals <- matrix(vals, ncol=nl) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } } return(out) } ) setMethod("clamp", signature(x="numeric"), function(x, lower=-Inf, upper=Inf, ...) { stopifnot(lower <= upper) x[x < lower] <- lower x[x > upper] <- upper return(x) } ) raster/R/reclassify.R0000644000176200001440000000460114507510157014250 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod('reclassify', signature(x='Raster', rcl='ANY'), function(x, rcl, filename='', include.lowest=FALSE, right=TRUE, ...) { filename <- trim(filename) if ( is.null(dim(rcl)) ) { rcl <- matrix(rcl, ncol=3, byrow=TRUE) } else if ( dim(rcl)[2] == 1 ) { rcl <- matrix(rcl, ncol=3, byrow=TRUE) } else if (is.data.frame(rcl)) { rcl <- as.matrix(rcl) } nc <- ncol(rcl) if ( nc != 3 ) { if (nc == 2) { colnames(rcl) <- c("Is", "Becomes") if (getOption('verbose')) { print(rcl) } rcl <- cbind(rcl[,1], rcl) right <- NA } else { stop('rcl must have 2 or 3 columns') } } else { colnames(rcl) <- c("From", "To", "Becomes") if (getOption('verbose')) { print(rcl) } } hasNA <- FALSE onlyNA <- FALSE valNA <- NA # if (nc == 3) { i <- which(is.na(rcl[, 1]) | is.na(rcl[, 2])) if (length(i) > 0) { valNA <- rcl[i[1],3] hasNA <- TRUE rcl <- rcl[-i, ,drop=FALSE] } # } else { # i <- which(is.na(rcl[, 1])) # if (length(i) > 1) { # valNA <- rcl[i[1], 2] # hasNA <- TRUE # rcl <- rcl[-i, ,drop=FALSE] # } # } if (dim(rcl)[1] == 0) { if (hasNA) { onlyNA <- TRUE } } else { stopifnot(all(rcl[,2] >= rcl[,1])) } nl <- nlayers(x) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) } names(out) <- names(x) include.lowest <- as.integer(include.lowest) if (is.na(right)) { leftright <- TRUE right <- TRUE } else { leftright <- FALSE } right <- as.integer(right) #hasNA <- as.integer(hasNA) onlyNA <- as.integer(onlyNA) valNA <- as.double(valNA) if (nc == 2) { rcl <- rcl[ , 2:3, drop=FALSE] } if (canProcessInMemory(out)) { out <- setValues(out, .reclassify(values(x), rcl, include.lowest, right, leftright, onlyNA, valNA)) if ( filename != "" ) { out <- writeRaster(out, filename=filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='reclassify', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vals <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) vals <- .reclassify(vals, rcl, include.lowest, right, leftright, onlyNA, valNA) if (nl > 1) { vals <- matrix(vals, ncol=nl) } out <- writeValues(out, vals, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) return(out) } } ) raster/R/rowMinMax.R0000644000176200001440000000052314507510157014024 0ustar liggesusers .rowMin <- function(x, na.rm=TRUE) { # .Call('raster_doRowMin', PACKAGE = 'raster', x, narm=na.rm) .doRowMin(x, narm=na.rm) } .rowMax <- function(x, na.rm=TRUE) { .doRowMax(x, narm=na.rm) } .colMin <- function(x, na.rm=TRUE) { .doRowMin(t(x), narm=na.rm) } .colMax <- function(x, na.rm=TRUE) { .doRowMax(t(x), narm=na.rm) } raster/R/hillShade.R0000644000176200001440000000141214507510157013776 0ustar liggesusers# Author: Andrew Bevan, Oscar Perpinan Lamigueiro, and Robert J. Hijmans # Date : March 2010 # Version 1.0 # Licence GPL v3 hillShade <- function(slope, aspect, angle=45, direction=0, filename='', normalize=FALSE, ...) { compareRaster(slope, aspect) direction <- direction * pi/180 zenith <- (90 - angle)*pi/180 #x <- cos(slope) * cos(declination) + sin(slope) * sin(declination) * cos(direction-aspect) if (normalize) { fun <- function(slp, asp) { shade <- cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) shade[shade < 0] <- 0 shade * 255 } } else { fun <- function(slp, asp) { cos(slp) * cos(zenith) + sin(slp) * sin(zenith) * cos(direction-asp) } } x <- overlay(slope, aspect, fun=fun, filename=filename, ...) return(x) } raster/R/weighted.mean.R0000644000176200001440000000302614507510157014623 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 setMethod('weighted.mean', signature(x='RasterStackBrick', w='vector'), function(x, w, na.rm=FALSE, filename='', ...) { stopifnot(length(w) == nlayers(x)) calc(x, fun=function(i) weighted.mean(i, w=w, na.rm=na.rm), filename=filename, ...) } ) setMethod('weighted.mean', signature(x='RasterStackBrick', w='RasterStackBrick'), function(x, w, na.rm=FALSE, filename='', ...) { nlx <- nlayers(x) if (nlayers(w) != nlx) { stop('nlayers of x and w should be the same') } out <- raster(x) filename <- trim(filename) sumw <- sum(w) if (canProcessInMemory(x, nlx*2)) { w <- getValues(w) x <- getValues(x) if (na.rm) { w[is.na(x)] <- NA x[is.na(w)] <- NA } sumw <- apply(w, 1, sum, na.rm=na.rm) w <- apply(w * x, 1, sum, na.rm=na.rm) / sumw w <- setValues(out, w) if (filename != '') { writeRaster(w, filename, ...) } return(w) } else { tr <- blockSize(x, n=nlx*2) pb <- pbCreate(tr$n, , label='weighted.mean', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { ww <- getValues(w, row=tr$row[i], nrows=tr$nrows[i]) xx <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (na.rm) { ww[is.na(xx)] <- NA xx[is.na(ww)] <- NA } wx <- apply(ww * xx, 1, sum, na.rm=na.rm) / apply(ww, 1, sum, na.rm=na.rm) out <- writeValues(out, wx, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/makeTiles.R0000644000176200001440000000135014507510157014020 0ustar liggesusers .makeTiles <- function(x, y, filename="", ...) { res <- res(y) xy <- xyFromCell(y, 1:ncell(y)) xy1 <- xy - 0.5 * res xy2 <- xy + 0.5 * res tiles <- list() if (length(filename) > 1) { stopifnot(length(filename) == ncell(y)) } else if (filename != '') { ext <- extension(filename) extension(filename) <- '' filename <- paste0(filename, '_', 1:ncell(y), ext) } else if (!canProcessInMemory(x)) { filename <- rasterTmpFile() ext <- extension(filename) extension(filename) <- '' filename <- paste0(filename, '_', 1:ncell(y), ext) } else { filename <- rep("", ncell(y)) } for (i in 1:ncell(y)) { e <- extent(xy1[i,1], xy2[i,1], xy1[i,2], xy2[i,2]) tiles[[i]] <- crop(x, e, filename=filename[i], ...) } tiles } raster/R/hdrPRJ.R0000644000176200001440000000057614507510157013244 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 .writeHdrPRJ <- function(x, ESRI=TRUE) { # if (.requireRgdal()) { p4s <- wkt(x) if (! inherits(p4s, "try-error")) { prjfile <- filename(x) extension(prjfile) <- '.prj' cat(p4s, file=prjfile) } else { return(FALSE) } return(invisible(TRUE)) # } else { # return(FALSE) # } } raster/R/drawPoly.R0000644000176200001440000000134214507510157013704 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 drawPoly <- function(sp=TRUE, col='red', lwd=2, ...) { xy <- graphics::locator(n=10000, type="l", col=col, lwd=lwd, ...) xy <- cbind(xy$x, xy$y) xy <- rbind(xy, xy[1,]) lines(xy[(length(xy[,1])-1):length(xy[,1]),], col=col, lwd=lwd, ...) if (sp) { return( sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(xy)), 1))) ) } else { return(xy) } } drawLine <- function(sp=TRUE, col='red', lwd=2, ...) { xy <- graphics::locator(n=10000, type="l", col=col, lwd=lwd, ...) xy <- cbind(xy$x, xy$y) if (sp) { return( sp::SpatialLines(list(sp::Lines(list(sp::Line(xy)), "1"))) ) } else { return(xy) } } raster/R/localFun.R0000644000176200001440000000221414507510157013645 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 if ( !isGeneric("localFun") ) { setGeneric("localFun", function(x, y, ...) standardGeneric("localFun")) } setMethod('localFun', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ngb=5, fun, filename='', ...) { compareRaster(x,y) out <- raster(x) nc1 <- 1:(ngb*ngb) nc2 <- ((ngb*ngb)+1):(2*(ngb*ngb)) if (canProcessInMemory(x, n=2*ngb)) { vx <- getValuesFocal(x, 1, nrow(x), ngb=ngb) vy <- getValuesFocal(y, 1, nrow(y), ngb=ngb) values(out) <- apply(cbind(vx, vy), 1, function(x, ...) fun(x[nc1], x[nc2], ...)) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='localFun', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- apply(cbind(vx, vy), 1, function(x, ...) fun(x[nc1], x[nc2], ...)) out <- writeValues(out, v, tr$row[i]) } return(writeStop(out)) } } ) raster/R/plotCT.R0000644000176200001440000000404014507510157013306 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2010 # Version 0.9 # Licence GPL v3 .plotCT <- function(x, maxpixels=500000, ext=NULL, interpolate=FALSE, axes, main, xlab='', ylab='', asp, add=FALSE, addfun=NULL, zlim=NULL, zlimcol=NULL, ...) { # plotting with a color table if (missing(main)) { main <- '' } #sethook <- FALSE if (!add) { graphics::plot.new() if (missing(axes)) { axes <- FALSE } if (!axes) { # if (main != "") { } else { old.par <- graphics::par(no.readonly = TRUE) #graphics::par(plt=c(0,1,0,1)) graphics::par(mar=c(0,0,0,0), xaxs='i',yaxs='i') #sethook <- TRUE } if (missing(asp)) { if (couldBeLonLat(x)) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } } } coltab <- colortable(x) x <- sampleRegular(x, maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) z <- getValues(x) if (!is.null(zlim)) { # not that relevant here, but for consistency.... if (is.null(zlimcol)) { z[ zzlim[2] ] <- zlim[2] } else { #if (is.na(zlimcol)) { z[zzlim[2]] <- NA } } if (NCOL(coltab) == 2) { # not implemented z <- as.numeric(cut(z, coltab[,1])) coltab <- as.vector(coltab[,2]) } z <- z + 1 z[is.na(z)] <- 1 if (! is.null(coltab) ) { z <- matrix(coltab[z], nrow=nrow(x), ncol=ncol(x), byrow=T) z <- as.raster(z) } else { z <- matrix(z, nrow=nrow(x), ncol=ncol(x), byrow=T) z <- as.raster(z, max=max(z)) #, na.rm=TRUE)) } requireNamespace("grDevices") bb <- as.vector(extent(x)) if (! add) { plot(c(bb[1], bb[2]), c(bb[3], bb[4]), type = "n", xlab=xlab, ylab=ylab, asp=asp, axes=axes, main=main, ...) } graphics::rasterImage(z, bb[1], bb[3], bb[2], bb[4], interpolate=interpolate, ...) if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } #if (sethook) { # setHook("plot.new", function(...) { # graphics::par(old.par) # setHook("plot.new", function(...) setHook("plot.new", NULL, "replace")) # }, action="replace") #} } raster/R/sampleAlong.R0000644000176200001440000000436714507510157014357 0ustar liggesusers# Based on code by Barry Rowlingson #http://r-sig-geo.2731867.n2.nabble.com/how-to-generate-perpendicular-transects-along-a-line-feature-td7583710.html # Some adaptations by Robert Hijmans .evenspace <- function(xy, sep, start=0.5*sep, direction=TRUE){ dx <- c(0,diff(xy[,1])) dy <- c(0,diff(xy[,2])) dseg <- sqrt(dx^2+dy^2) dtotal <- cumsum(dseg) linelength <- sum(dseg) pos <- seq(start,linelength, by=sep) whichseg <- unlist(lapply(pos, function(x){sum(dtotal<=x)})) x0 <- xy[whichseg,1] y0 <- xy[whichseg,2] x1 <- xy[whichseg+1,1] y1 <- xy[whichseg+1,2] dtotal <- dtotal[whichseg] further <- pos - dtotal dseg <- dseg[whichseg+1] f <- further/dseg x <- x0 + f * (x1-x0) y <- y0 + f * (y1-y0) r <- data.frame(x, y) if (direction) { r$direction <- atan2(y0-y1,x0-x1) } r } .transect <- function(pts, len){ directionT = pts$direction+pi/2 dx <- len*cos(directionT) dy <- len*sin(directionT) data.frame(x = c(pts$x + dx, pts$x - dx), y = c(pts$y + dy, pts$y - dy)) } .sampleAlong <- function(x, interval) { if (inherits(x, 'SpatialPolygons')) { line <- methods::as(line, 'SpatialLines') } if (inherits(x, 'SpatialLines')) { #requireNamespace('raster') x <- geom(x) allpts <- NULL for (p in unique(x[, 'cump'])) { y <- x[x[, 'cump']==p, c('x', 'y')] pts <- .evenspace(y, interval, direction=FALSE) allpts <- rbind(allpts, pts) } return(allpts) } else { x <- .pointsToMatrix(x) .evenspace(x, interval, direction=FALSE) } } .sampleAlongPerpendicular <- function(x, interval, pdist, np=1 ) { if (inherits(x, 'SpatialPolygons')) { line <- methods::as(line, 'SpatialLines') } if (inherits(x, 'SpatialLines')) { #requireNamespace('raster') x <- geom(x) allpts <- NULL for (p in unique(x[, 'cump'])) { y <- x[x[, 'cump']==p, c('x', 'y')] tspts <- .evenspace(y, interval, direction=TRUE) pts <- NULL for (i in 1:np) { pts1 <- .transect(tspts, i * pdist) pts <- cbind(pts, pts1) } allpts <- rbind(allpts, pts) } return(allpts) } else { x <- .pointsToMatrix(x) y <- .evenspace(x, interval, direction=TRUE) pts <- NULL for (i in 1:np) { pts1 <- .transect(y, i * pdist) pts <- rbind(pts, pts1) } return(pts) } } raster/R/bbox.R0000644000176200001440000000075214507510157013041 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("bbox", signature(obj="Extent"), function(obj) { bb <- matrix(ncol=2, nrow=2) colnames(bb) <- c("min","max") rownames(bb) <- c("s1","s2") bb[1,1] <- obj@xmin bb[1,2] <- obj@xmax bb[2,1] <- obj@ymin bb[2,2] <- obj@ymax return(bb) } ) setMethod("bbox", signature(obj="Raster"), function(obj) { e <- extent(obj) return( bbox(e) ) } ) raster/R/range.R0000644000176200001440000000313114507510157013175 0ustar liggesusers# Authors: Robert J. Hijmans # Date : May 2012 # Version 1.0 # Licence GPL v3 .range <- function(x, ..., na.rm=FALSE) { dots <- list(...) if (length(dots) > 0) { d <- sapply(dots, function(i) inherits(i, 'Raster')) if (any(d)) { x <- .makeRasterList(x, dots[d]) if (length(x) > 1) { x <- stack(x) } else { x <- x[[1]] } } add <- .addArgs(unlist(dots[!d])) } else { add <- NULL } if (nlayers(x)==1 & length(add)==0) { warning('Cannot compute a range from a single RasterLayer; see cellStats') return(x) } out <- raster(x) out <- brick(out, nl=2, values=FALSE) names(out) <- c('range_min', 'range_max') if (canProcessInMemory(x)) { if (!is.null(add)) { add <- range(add, na.rm=na.rm) x <- cbind(getValues(x), add[1], add[2]) } else { x <- getValues(x) } x <- apply(x, 1, range, na.rm=na.rm) out <- setValues(out, t(x)) return(out) } tr <- blockSize(x) out <- writeStart(out, filename="") pb <- pbCreate(tr$n, label='range',) if (!is.null(add)) { add <- range(add) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- cbind(v, add[1], add[2]) v <- apply(v, 1, FUN=range, na.rm=na.rm) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- apply(v, 1, FUN=range, na.rm=na.rm) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) names(out) <- c('range_min', 'range_max') out } raster/R/projectRaster.R0000644000176200001440000001744614507510157014746 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 .useproj6 <- function() { FALSE } .rawTransform <- function(projfrom, projto, xy, wkt="") { v <- terra::vect() out <- terra::project(xy, projfrom, projto) matrix(out, ncol=2) # xy <- terra::vect(xy, crs=projfrom) # xy <- terra::project(xy, projto) # terra::crds(xy) } projectExtent <- function(object, crs) { use_proj6 <- .useproj6() object <- raster(object) dm <- oldm <- dim(object) # simple way to avoid a bug with a single column/row reported by # Jon Olav Skoien dm[1] <- max(10, dm[1]) dm[2] <- max(10, dm[2]) dim(object) <- dm pfrom <- .getCRS(object) pto <- .getCRS(crs) if (use_proj6) { projfrom <- wkt(pfrom) projto <- wkt(pto) if (is.null(projfrom) || is.null(projto)) { use_proj6 = FALSE projfrom <- pfrom projto <- pto } } else { projfrom <- proj4string(pfrom) projto <- proj4string(pto) } # rs <- res(object) # xmn <- object@extent@xmin - 0.5 * rs[1] # xmx <- object@extent@xmax + 0.5 * rs[1] # ymn <- object@extent@ymin - 0.5 * rs[2] # ymx <- object@extent@ymax + 0.5 * rs[2] # xha <- (xmn + xmx) / 2 # yha <- (ymn + ymx) / 2 # xy <- matrix(c(xmn, ymx, xha, ymx, xmx, ymx, xmn, yha, xha, yha, xmx, yha, xmn, ymn, xha, ymn, xmx, ymn), ncol=2, byrow=T) rows <- unique(c(seq(1,nrow(object), by=max(1, round(nrow(object)/50))), nrow(object))) cols <- unique(c(seq(1,ncol(object), by=max(1, round(ncol(object)/50))), ncol(object))) xy1 <- xyFromCell(object, cellFromRowCol(object, rows, 1)) xy1[,1] <- xy1[,1] - 0.5 * xres(object) xy1[1,2] <- xy1[1,2] + 0.5 * yres(object) xy1[nrow(xy1),2] <- xy1[nrow(xy1),2] + 0.5 * yres(object) xy2 <- xyFromCell(object, cellFromRowCol(object, rows, ncol(object))) xy2[,1] <- xy2[,1] + 0.5 * xres(object) xy2[1,2] <- xy2[1,2] + 0.5 * yres(object) xy2[nrow(xy2),2] <- xy2[nrow(xy2),2] + 0.5 * yres(object) xy3 <- xyFromCell(object, cellFromRowCol(object, 1, cols)) xy3[,2] <- xy3[,2] + 0.5 * yres(object) xy3[1,1] <- xy3[1,1] - 0.5 * xres(object) xy3[ncol(xy3),1] <- xy3[ncol(xy3),1] + 0.5 * xres(object) xy4 <- xyFromCell(object, cellFromRowCol(object, nrow(object), cols)) xy4[,2] <- xy4[,2] - 0.5 * yres(object) xy4[1,1] <- xy4[1,1] - 0.5 * xres(object) xy4[ncol(xy4),1] <- xy4[ncol(xy4),1] + 0.5 * xres(object) # added for circumpolar data: if (nrow(object) > 75 & ncol(object) > 75) { xy5 <- sampleRegular(object, 500, xy=TRUE) # rows <- c(seq(min(nrow(object), 25), nrow(object), by=50)) # cols <- c(seq(min(ncol(object), 25), ncol(object), by=50)) # xy5 <- xyFromCell(object, cellFromRowColCombine(object, rows, cols)) xy <- rbind(xy1, xy2, xy3, xy4, xy5) } else { xy <- rbind(xy1, xy2, xy3, xy4) } xy <- .rawTransform( projfrom, projto, xy) xy <- subset(xy, !(is.infinite(xy[,1]) | is.infinite(xy[,2]) | is.na(xy[,2]) )) x <- xy[,1] y <- xy[,2] if (length(y) == 0 | length(y) ==0) { stop("cannot do this transformation") } minx <- min(x) maxx <- max(x) if (maxx == minx) { maxx <- maxx + 0.5 minx <- minx - 0.5 } miny <- min(y) maxy <- max(y) if (maxy == miny) { maxy <- maxy + 0.5 miny <- miny - 0.5 } obj <- raster(extent(minx, maxx, miny, maxy), nrows=oldm[1], ncols=oldm[2], crs=crs) return(obj) } .computeRes <- function(obj, crs) { x <- xmin(obj) + 0.5 * (xmax(obj) - xmin(obj)) y <- ymin(obj) + 0.5 * (ymax(obj) - ymin(obj)) res <- res(obj) x1 <- x - 0.5 * res[1] x2 <- x + 0.5 * res[1] y1 <- y - 0.5 * res[2] y2 <- y + 0.5 * res[2] xy <- cbind(c(x1, x2, x, x), c(y, y, y1, y2)) #fromcrs <- .getCRS(obj) fromsrs <- .getSRS(obj) pXY <- .rawTransform(fromsrs, crs, xy) # out <- c((pXY[2,1] - pXY[1,1]), (pXY[4,2] - pXY[3,2])) outex <- extent(pXY) out <- c(xmax(outex) - xmin(outex), ymax(outex) - ymin(outex)) if (any(is.na(out))) { if (isLonLat(obj)) { out <- pointDistance(cbind(x1, y1), cbind(x2, y2), lonlat=TRUE) out <- c(out, out) } else { out <- res } } # abs should not be necessary, but who knows what a projection might do? abs( signif(out, digits=3) ) } .getAlignedRaster <- function(x,y) { x <- raster(x) y <- raster(y) p <- projectRaster(x, crs=.getCRS(y)) m <- merge(extent(y), extent(p)) rx <- extend(y, m) crop(rx, p) } projectRaster <- function(from, to, res, crs, method="bilinear", alignOnly=FALSE, over=FALSE, filename="", ...) { #projfrom <- .getCRS(from) projfrom <- .getSRS(from) if (is.na(projfrom)) { stop("input projection is NA") } lonlat <- isLonLat(projfrom) if (missing(to)) { if (missing(crs)) { stop("both 'to' and 'crs' arguments are missing.") } #projto <- .getCRS(crs) projto <- .getSRS(crs) #compareCRS(projfrom, projto) to <- projectExtent(from, projto) # to@crs <- projto to@srs <- projto if (missing(res)) { res <- .computeRes(from, projto) } res(to) <- res # add some cells to capture curvature e <- extent(to) add <- min(5, min(dim(to)[1:2])/10) * max(res) e@ymin <- e@ymin - add e@ymax <- e@ymax + add e@xmin <- e@xmin - add e@xmax <- e@xmax + add if (!is.character(projto)) projto <- projto@projargs if (substr(projto, 1, 13) == "+proj=longlat") { e@xmin <- max(-180, e@xmin) e@xmax <- min(180, e@xmax) e@ymin <- max(-90, e@ymin) e@ymax <- min(90, e@ymax) } to <- extend(to, e) } else { # projto <-.getCRS(to) projto <- .getSRS(to) if (is.na(projto) || (projto == "")) { stop("output projection is empty") } e <- extent( projectExtent(from, projto) ) add <- min(10, min(dim(to)[1:2])/10) * max(raster::res(to)) e@ymin <- e@ymin - add e@ymax <- e@ymax + add e@xmin <- e@xmin - add e@xmax <- e@xmax + add if (isLonLat(projto)) { e@xmin <- max(-180, e@xmin) e@xmax <- min(180, e@xmax) e@ymin <- max(-90, e@ymin) e@ymax <- min(90, e@ymax) } } methods::validObject(to) # methods::validObject(.getCRS((to))) #if (identical(projfrom, projto)) { # warning('projections of "from" and "to" are the same') #} # if ((!use_proj6) & lonlat & over) { # projto_int <- paste(projto, "+over") # } else { projto_int <- projto # } if (alignOnly) { to <- .getAlignedRaster(from, to) return (to) } # pbb <- projectExtent(to,.getCRS(from)) # bb <- intersect(extent(pbb), extent(from)) # methods::validObject(bb) if (!method %in% c('bilinear', 'ngb')) { stop('invalid method') } nl <- nlayers(from) if ( nl == 1) { to <- raster(to) if (method=="ngb") { colortable(to) <- colortable(from) } } else { to <- brick(to, values=FALSE, nl=nl) } if (method=='ngb') { method <- 'simple' # for extract (.xyValues) } names(to) <- names(from) if ( ! hasValues(from) ) { #warning("'from' has no cell values") return(to) } if (canProcessInMemory(to, n=nl*4)) { inMemory <- TRUE } else { inMemory <- FALSE } # this seems to need smaller chunks #cz <- max(5, 0.1 * .chunk() / nlayers(to)) if (inMemory) { xy <- coordinates(to) xy <- subset(xy, xy[,1] > e@xmin & xy[,1] < e@xmax) cells <- cellFromXY(to, xy) xy <- .rawTransform( projto_int, projfrom, xy) to[cells] <- .xyValues(from, xy, method=method) if (filename != '') { to <- writeRaster(to, filename, ...) } return(to) } else { tr <- blockSize(to, n=nlayers(to)*4) pb <- pbCreate(tr$n, label='projectRaster', ...) to <- writeStart(to, filename=filename, ...) for (i in 1:tr$n) { cells <- cellFromRowCol(to, tr$row[i], 1):cellFromRowCol(to, tr$row[i]+tr$nrows[i]-1, ncol(to)) xy <- xyFromCell(to, cells ) xy <- subset(xy, xy[,1] > e@xmin & xy[,1] < e@xmax) if (nrow(xy) > 0) { ci <- match(cellFromXY(to, xy), cells) xy <- .rawTransform( projto_int, projfrom, xy) v <- matrix(nrow=length(cells), ncol=nl) v[ci, ] <- .xyValues(from, xy, method=method) to <- writeValues(to, v, tr$row[i]) } pbStep(pb) } pbClose(pb) to <- writeStop(to) return(to) } } raster/R/which.R0000644000176200001440000000227414507510157013212 0ustar liggesusers# Author: Robert J. Hijmans # Date: November 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("Which")) { setGeneric("Which", function(x, ...) standardGeneric("Which")) } setMethod('Which', signature(x='RasterLayer'), function(x, cells=FALSE, na.rm=TRUE, ...) { if (canProcessInMemory(x, 2)){ if (cells) { return(which(as.logical(getValues(x)) == TRUE)) } else { x <- as.logical(x) if (na.rm) { x[is.na(x)] <- FALSE } return(x) } } else { out <- raster(x) if (cells) { vv <- vector() } else { filename <- rasterTmpFile() out <- writeStart(out, filename=filename, format=.filetype(), datatype='INT2S', overwrite=TRUE) } tr <- blockSize(out, n=2) pb <- pbCreate(tr$n, type=.progress() ) for (i in 1:tr$n) { v <- as.logical( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) if (cells) { offs <- (tr$row[i]-1) * out@ncols vv <- c(vv, which(v==TRUE) + offs) } else { v <- as.logical(v) if (na.rm) { v[is.na(v)] <- 0 } out <- writeValues(out, v, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (cells) { return(vv) } else { out <- writeStop(out) return(out) } } } ) raster/R/netCDFwriteCD.R0000644000176200001440000001467014533250215014473 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .startWriteCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, progress='', att, varname, varunit, varatt, longname, xname, yname, zname, zunit, zatt, NAflag, force_v4=FALSE, sources, ...) { stopifnot(requireNamespace("ncdf4")) filename <- trim(filename) if (filename == '') { stop('provide a filename') } extension(filename) <- .defaultExtension(format='CDF') if (file.exists(filename) & !overwrite) { stop('file exists, use overwrite=TRUE to overwrite it') } dataType(x) <- datatype ncdatatype <- .getNetCDFDType(datatype) nl <- nlayers(x) if (couldBeLonLat(x)) { if (missing(xname)) xname = 'longitude' if (missing(yname)) yname = 'latitude' xunit = 'degrees_east' yunit = 'degrees_north' } else { if (missing(xname)) xname = 'easting' if (missing(yname)) yname = 'northing' xunit = 'meter' # probably yunit = 'meter' # probably } if (missing(varname)) { if (nl == 1) { varname <- names(x) } else { #varname <- x@title varname <- attr(x@data, 'zvar') if (is.null(varname)) { varname <- names(x@z) if (is.null(varname)) { varname <- 'variable' } } } } if (missing(varunit)) varunit <- "" if (missing(longname)) longname <- "" if (inherits(x, 'RasterBrick')) { zv <- 1:nl z <- getZ(x) if (!is.null(z)) { if (!any(is.na(z))) { cls <- substr(class(z)[1], 1, 4) z <- as.numeric(z) if (!any(is.na(z))) { zv[] <- z if (cls[1] %in% c('Date', 'POSI')) { if (missing(zatt)) { if (missing(zname)) { zname <- 'time' } if (cls == 'Date') { zatt <- list('units=days since 1970-1-1') zunit <- 'days' } else { zatt <- list('units=seconds since 1970-1-1 00:00:00') zunit <- 'seconds' } } } } else { warning('z-values cannot be converted to numeric') } } else { warning('z-values contain NA') } } } if (missing(zname)) { zname <- 'z' } if (missing(zunit)) { zunit <- 'unknown' } if (missing(NAflag)) { NAflag <- NAvalue(x) } xdim <- ncdf4::ncdim_def( xname, xunit, xFromCol(x, 1:ncol(x)) ) ydim <- ncdf4::ncdim_def( yname, yunit, yFromRow(x, 1:nrow(x)) ) if (inherits(x, 'RasterBrick')) { zdim <- ncdf4::ncdim_def( zname, zunit, zv, unlim=TRUE ) vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim, ydim, zdim), NAflag, longname, prec = ncdatatype, ... ) } else { vardef <- ncdf4::ncvar_def( varname, varunit, list(xdim, ydim), NAflag, longname, prec = ncdatatype, ... ) } crsdef <- ncdf4::ncvar_def("crs", "", list(), NULL, prec="integer") defs <- list(crsdef, vardef) nc <- ncdf4::nc_create(filename, defs, force_v4=force_v4) prj <- crs(x) if (!is.na(prj)) { ncdf4::ncatt_put(nc, "crs", "proj4", proj4string(prj), prec='text') ncdf4::ncatt_put(nc, varname, "grid_mapping", "crs") ncdf4::ncatt_put(nc, varname, "proj4", as.character(prj), prec='text') } if (! missing(zatt)){ for (i in 1:length(zatt)) { a <- trim(unlist(strsplit(zatt[[i]], '='))) ncdf4::ncatt_put(nc, zname, a[1], a[2]) } } # ncdf4::ncatt_put(nc, varname, '_FillValue', x@file@nodatavalue, prec=ncdatatype, definemode=TRUE) # ncdf4::ncatt_put(nc, varname, 'missing_value', x@file@nodatavalue, prec=ncdatatype) # ncdf4::ncatt_put(nc, varname, 'long_name', longname, prec='text') if (! missing(varatt)){ for (i in 1:length(varatt)) { a <- trim(unlist(strsplit(varatt[i], '='))) ncdf4::ncatt_put(nc, varname, a[1], a[2]) } } ncdf4::ncatt_put(nc, 0, 'Conventions', 'CF-1.4', prec='text') if (! missing(att)){ for (i in 1:length(att)) { a <- trim(unlist(strsplit(att[i], '='))) ncdf4::ncatt_put(nc, 0, a[1], a[2]) } } pkgversion <- drop(read.dcf(file=system.file("DESCRIPTION", package='raster'), fields=c("Version"))) ncdf4::ncatt_put(nc, 0, 'created_by', paste('R, packages ncdf4 and raster (version ', pkgversion, ')', sep=''), prec='text') ncdf4::ncatt_put(nc, 0, 'date', format(Sys.time(), "%Y-%m-%d %H:%M:%S"), prec='text') ncdf4::nc_close(nc) x@data@min <- rep(Inf, nl) x@data@max <- rep(-Inf, nl) x@data@haveminmax <- FALSE x@file@driver <- 'netcdf' x@file@name <- filename x@file@nodatavalue <- NAflag x@title <- varname return(x) } .writeRangeCDF <- function(x) { nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) ncdf4::ncatt_put(nc, x@title, 'min', as.numeric(x@data@min)) ncdf4::ncatt_put(nc, x@title, 'max', as.numeric(x@data@max)) } .stopWriteCDF <- function(x) { .writeRangeCDF(x) if (inherits(x, 'RasterBrick')) { r <- brick(x@file@name) } else { r <- raster(x@file@name) } return(r) } .writeValuesCDF <- function(x, v, start=1) { rsd <- stats::na.omit(v) if (length(rsd) > 0) { x@data@min <- min(x@data@min, rsd) x@data@max <- max(x@data@max, rsd) } v[is.na(v)] <- x@file@nodatavalue nr <- length(v) / x@ncols v <- matrix(v, ncol=nr) nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start), count=c(x@ncols, nr)) ) return(x) } .writeValuesBrickCDF <- function(x, v, start=1, layer) { if (missing(layer)) { nl <- nlayers(x) lstart <- 1 lend <- nl w <- getOption('warn') options('warn'=-1) rsd <- apply(v, 2, range, na.rm=TRUE) x@data@min <- pmin(x@data@min, rsd[1,]) x@data@max <- pmax(x@data@max, rsd[2,]) options('warn'= w) } else { nl <- 1 lstart <- layer lend <- layer rsd <- stats::na.omit(v) if (length(rsd) > 0) { x@data@min[layer] <- min(x@data@min[layer], rsd) x@data@max[layer] <- max(x@data@max[layer], rsd) } } ncols <- x@ncols v[is.na(v)] = x@file@nodatavalue rows <- length(v) / (ncols * nl) v <- array(v, c(rows, ncols, nl)) nc <- ncdf4::nc_open(x@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) try ( ncdf4::ncvar_put(nc, x@title, v, start=c(1, start, lstart), count=c(ncols, rows, lend) ) ) return(x) } #.rasterSaveAsNetCDF <- function(x, filename, datatype='FLT4S', overwrite=FALSE, ...) { # x <- .startWriteCDF(x, filename=filename, datatype=datatype, overwrite=overwrite, ...) # if (nlayers(x) > 1) { # x <- .writeValuesBrickCDF(x, getValues(x) ) # } else { # x <- .writeValuesCDF(x, getValues(x)) # } # return( .stopWriteCDF(x) ) #} #library(raster) #r = raster(ncol=10, nrow=5) #r[] = c(1:49, NA) #names(r) = 'hello world' #a = .rasterSaveAsNetCDF(r, 'test.nc', overwrite=TRUE) #plot(a) #print(a) raster/R/rasterToPolygons.R0000644000176200001440000000567414507510157015455 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 rasterToPolygons <- function(x, fun=NULL, n=4, na.rm=TRUE, digits=12, dissolve=FALSE) { stopifnot(n %in% c(4,8,16)) if (nlayers(x) > 1) { if (!is.null(fun)) { stop('you cannot supply a "fun" argument when "x" has multiple layers') } } if (! fromDisk(x) & ! inMemory(x)) { xyv <- xyFromCell(x, 1:ncell(x)) xyv <- cbind(xyv, NA) } else if ( !(na.rm) | inMemory(x) | canProcessInMemory(x) ) { xyv <- cbind(xyFromCell(x, 1:ncell(x)), getValues(x)) x <- clearValues(x) if (na.rm) { nas <- apply(xyv[,3:ncol(xyv), drop=FALSE], 1, function(x) all(is.na(x))) xyv <- xyv[!nas, ,drop=FALSE] } if (!is.null(fun)) { if (nrow(xyv) > 0) { xyv <- subset(xyv, fun(xyv[,3])) } } } else { tr <- blockSize(x) xyv <- matrix(ncol=3, nrow=0) nl <- nlayers(x) for (i in 1:tr$n) { start <- cellFromRowCol(x, tr$row[i], 1) end <- start+tr$nrows[i]*ncol(x)-1 xyvr <- cbind(xyFromCell(x, start:end), getValues(x, row=tr$row[i], nrows=tr$nrows[i])) if (na.rm) { if (nl > 1) { nas <- apply(xyvr[,3:ncol(xyvr), drop=FALSE], 1, function(x) all(is.na(x))) } else { nas <- is.na(xyvr[,3]) } xyvr <- xyvr[!nas, ,drop=FALSE] } if (nrow(xyvr) > 0) { if (!is.null(fun)) { xyvr <- subset(xyvr, fun(xyvr[,3,drop=FALSE])) } rownames(xyvr) <- NULL xyv <- rbind(xyv, xyvr) } } } colnames(xyv) <- c('x', 'y', names(x)) if (nrow(xyv) == 0) { warning('no values in selection') return( NULL ) } cr <- .getPolygons(xyv[, 1:2, drop=FALSE], res(x), n) # xr <- xres(x)/2 # yr <- yres(x)/2 # if (n==4) { # cr <- matrix(ncol=10, nrow=nrow(xyv)) # cr[,c(1,4:5)] <- xyv[,1] - xr # cr[,2:3] <- xyv[,1] + xr # cr[,c(6:7,10)] <- xyv[,2] + yr # cr[,8:9] <- xyv[,2] - yr # } else if (n == 8) { # cr <- matrix(ncol=18, nrow=nrow(xyv)) # cr[,c(1,7:9)] <- xyv[,1] - xr # cr[,c(2,6)] <- xyv[,1] # cr[,3:5] <- xyv[,1] + xr # cr[,c(10:12,18)] <- xyv[,2] + yr # cr[,c(13,17)] <- xyv[,2] # cr[,14:16] <- xyv[,2] - yr # } else if (n == 16) { # cr <- matrix(ncol=34, nrow=nrow(xyv)) # cr[,c(1,13:17)] <- xyv[,1] - xr # cr[,c(2,12)] <- xyv[,1] - 0.5 * xr # cr[,c(3,11)] <- xyv[,1] # cr[,c(4,10)] <- xyv[,1] + 0.5 * xr # cr[,5:9] <- xyv[,1] + xr # cr[,c(18:22,34)] <- xyv[,2] + yr # cr[,c(23,33)] <- xyv[,2] + 0.5 * yr # cr[,c(24,32)] <- xyv[,2] # cr[,c(25,31)] <- xyv[,2] - 0.5 * yr # cr[,26:30] <- xyv[,2] - yr # } cr <- round(cr, digits=digits) sp <- lapply(1:nrow(cr), function(i) sp::Polygons(list(sp::Polygon( matrix( cr[i,], ncol=2 ) )), i)) sp <- sp::SpatialPolygons(sp, proj4string=.getCRS((x))) sp <- sp::SpatialPolygonsDataFrame(sp, data.frame(xyv[,3:ncol(xyv),drop=FALSE]), match.ID=FALSE) if (dissolve) { # if(! requireNamespace("rgeos") ) { # warning('package rgeos is not available. Cannot dissolve') # } else { sp <- aggregate(sp, names(sp)) # } } sp } raster/R/cellFromPolygon.R0000644000176200001440000000231214507510157015214 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2011 # Version 1.0 # Licence GPL v3 cellFromPolygon <- function(object, p, weights=FALSE) { spbb <- sp::bbox(p) rsbb <- bbox(object) addres <- max(res(object)) npol <- length(p@polygons) res <- list() res[[npol+1]] = NA if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { return(res[1:npol]) } rr <- raster(object) for (i in 1:npol) { pp <- p[i,] spbb <- sp::bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE, datatype="FLT4S") rc[rc==0] <- NA xy <- rasterToPoints(rc) weight <- xy[,3] / 100 xy <- xy[,-3] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch holes or very small polygons cell <- cellFromXY(object, xy) if (weights) { res[[i]] <- cbind(cell, weight) } else { res[[i]] <- cell } } } } return( res[1:npol] ) } raster/R/freq.R0000644000176200001440000000627514507510157013052 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 setMethod('freq', signature(x='RasterLayer'), function(x, digits=0, value=NULL, useNA="ifany", progress='', ...) { if (!is.null(value)) { return( .count(x, value, digits=digits, progress=progress, ...) ) } if (canProcessInMemory(x, 3)) { d <- round(getValues(x), digits=digits) res <- table( d, useNA=useNA ) res <- cbind(as.numeric(names(res)), as.vector(res)) } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress, label='freq') z <- vector(length=0) for (i in 1:tr$n) { d <- round(getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]), digits=digits) res <- table(d, useNA=useNA ) res <- cbind(as.numeric(unlist(as.vector(dimnames(res)), use.names = FALSE)), as.vector(res)) z <- rbind(z, res) pbStep(pb, i) } res <- tapply(z[,2], as.character(z[,1]), sum) res <- cbind(as.numeric(names(res)), as.vector(res)) z <- z[is.na(z[,1]), ,drop=FALSE] if (isTRUE(nrow(z) > 0)) { z <- sum(z[,2]) res <- rbind(res, c(NA, z)) } res <- res[order(res[,1]), ] pbClose(pb) } colnames(res) <- c('value', 'count') return(res) } ) setMethod('freq', signature(x='RasterStackBrick'), function(x, digits=0, value=NULL, useNA="ifany", merge=FALSE, progress='', ...) { if (!is.null(value)) { return(.count(x, value, digits=digits, progress=progress, ...)) } nl <- nlayers(x) res <- list() pb <- pbCreate(nl, progress=progress, label='freq') for (i in 1:nl) { res[[i]] <- freq( raster(x, i), digits=digits, useNA=useNA, progress='', ...) pbStep(pb, i) } pbClose(pb) names(res) <- ln <- names(x) if (merge) { r <- res[[1]] colnames(r)[2] <- ln[1] if (nl > 1) { for (i in 2:nl) { x <- res[[i]] colnames(x)[2] <- ln[i] r <- merge(r, x, by=1, all=TRUE) } } return(r) } return(res) } ) .count <- function(x, value, digits=0, progress='', ...) { value <- value[1] if (nlayers(x) > 1) { if (canProcessInMemory(x, 2)) { if (is.na(value)) { v <- colSums(is.na(getValues(x))) } else { v <- round(getValues(x), digits=digits) == value v <- colSums(v, na.rm=TRUE) } } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress) v <- 0 for (i in 1:tr$n) { vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (is.na(value)) { v <- v + colSums(is.na(vv)) } else { vv <- round(v, digits=digits) == value v <- v + colSums(vv, na.rm=TRUE) } pbStep(pb, i) } pbClose(pb) } return(v) } else { if (canProcessInMemory(x, 2)) { if (is.na(value)) { x <- sum(is.na(getValues(x))) } else { v <- stats::na.omit(round(getValues(x), digits=digits)) x <- sum(v == value) } return(x) } else { tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, progress=progress) r <- 0 for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (is.na(value)) { r <- r + sum(is.na(v)) } else { v <- stats::na.omit(round(v, digits=digits)) r <- r + sum(v == value) } pbStep(pb, i) } pbClose(pb) return(r) } } } raster/R/spplot.R0000644000176200001440000000415614507510157013432 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric("spplot")) { setGeneric("spplot", function(obj, ...) standardGeneric("spplot")) } setMethod("spplot", signature(obj='Raster'), function(obj, ..., maxpixels=50000, as.table=TRUE, zlim) { obj <- sampleRegular(obj, maxpixels, asRaster=TRUE, useGDAL=TRUE) if (!missing(zlim)) { if (length(zlim) != 2) { warning('zlim should be a vector of two elements') } if (length(zlim) >= 2) { zlim <- sort(zlim[1:2]) obj[obj < zlim[1]] <- zlim[1] obj[obj > zlim[2]] <- zlim[2] } } obj <- as(obj, 'SpatialGridDataFrame') #obj@data <- obj@data[, ncol(obj@data):1] spplot(obj, ..., as.table=as.table) } ) # spplot for SpatialPoints object that has no data.frame setMethod('spplot', signature(obj='SpatialPoints'), function(obj, ...) { obj <- sp::SpatialPointsDataFrame(obj, data.frame(ID=1:length(obj))) spplot(obj, ...) }) setMethod('spplot', signature(obj='SpatialPolygons'), function(obj, ...) { obj <- sp::SpatialPolygonsDataFrame(obj, data.frame(ID=1:length(obj))) spplot(obj, ...) }) setMethod('spplot', signature(obj='SpatialLines'), function(obj, ...) { obj <- sp::SpatialLinesDataFrame(obj, data.frame(ID=1:length(obj))) spplot(obj, ...) }) setMethod("lines", signature(x='SpatialPolygons'), function(x, ...) { x <- as(x, 'SpatialLines') lines(x, ...) } ) setMethod("spplot", signature(obj='SpatRaster'), function(obj, ..., maxpixels=50000, as.table=TRUE, zlim) { obj <- as(obj, "Raster") obj <- sampleRegular(obj, maxpixels, asRaster=TRUE) if (!missing(zlim)) { if (length(zlim) != 2) { warning('zlim should be a vector of two elements') } if (length(zlim) >= 2) { obj[obj < zlim[1] | obj > zlim[2]] <- NA } } obj <- as(obj, 'SpatialGridDataFrame') spplot(obj, ..., as.table=as.table) } ) setMethod("spplot", signature(obj="SpatVector"), function(obj, ...) { x <- as(obj, "Spatial") if (.hasSlot(x, "data")) { for (i in 1:ncol(x@data)) { if (is.character(x@data[,i])) { x@data[,i] <- as.factor(x@data[,i]) } } } spplot(x, ...) } ) raster/R/match.R0000644000176200001440000000106314507510157013177 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2011 # October 2011 # version 1 # Licence GPL v3 setMethod("%in%", signature(x='Raster', table='ANY'), function(x, table) { calc(x, function(x) x %in% table) } ) if (!isGeneric("match")) { setGeneric("match", function(x, table, nomatch=NA_integer_, incomparables=NULL) standardGeneric("match")) } setMethod("match", signature(x='Raster', table='ANY', nomatch='ANY', incomparables='ANY'), function(x, table, nomatch, incomparables) { calc(x, function(x) match(x, table, nomatch, incomparables)) } ) raster/R/approxNA.R0000644000176200001440000000641014507510157013634 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2012 # Version 1.0 # Licence GPL v3 setMethod('approxNA', signature(x='RasterStackBrick'), function(x, filename="", method="linear", yleft, yright, rule=1, f=0, ties=mean, z=NULL, NArule=1, ...) { filename <- trim(filename) out <- brick(x, values=FALSE) nl <- nlayers(out) if (nl < 2) { warning('cannot interpolate with a single layer') return(x) } if (is.null(z)) { xout <- getZ(x) if (is.null(xout)) { xout <- 1:nl } else if (length(xout)!= nl) { stop('length of values returned by getZ(x) does not match the number of layers of x') } } else { if (length(z)!= nl) { stop('length of z does not match the number of layers of x') } xout <- z } ifelse((missing(yleft) & missing(yright)), ylr <- 0L, ifelse(missing(yleft), ylr <- 1L, ifelse(missing(yright), ylr <- 2L, ylr <- 3L))) if (canProcessInMemory(x)) { x <- getValues(x) s <- rowSums(is.na(x)) if (isTRUE(NArule==1)) { j <- s == (nl-1) # one non-NA only if (length(j) > 0 ) { x[j, ] <- apply(x[j, ,drop=FALSE], 1, max, na.rm=TRUE) } } i <- s < (nl-1) # at least two if (length(i) > 0 ) { if (ylr==0) { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y )) } else if (ylr==1) { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y )) } else if (ylr==2) { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y )) } else { x[i,] <- t(apply(x[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y )) } } else { warning('no NA values to approximate') } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename=filename, ...) } return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n, label='approxNA', ...) out <- writeStart(out, filename=filename, ...) nc <- ncol(out) for (j in 1:tr$n) { v <- getValues(x, row=tr$row[j], nrows=tr$nrows[j]) s <- .rowSums(is.na(v), nrow(v), nl) if (isTRUE(NArule==1)) { k <- s == (nl-1) # one non-NA only if (length(k) > 0 ) { v[k, ] <- apply(v[k,,drop=FALSE ], 1, max, na.rm=TRUE) } } i <- (s < nl-1) # need at least two if (length(i) > 0 ) { if (ylr==0) { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, rule=rule, f=f, ties=ties)$y ) ) } else if (ylr==1) { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, rule=rule, f=f, ties=ties)$y ) ) } else if (ylr==2) { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yleft=yleft, rule=rule, f=f, ties=ties)$y ) ) } else { v[i,] <- t( apply(v[i,,drop=FALSE], 1, function(x) stats::approx(x=xout, y=x, xout=xout, method=method, yright=yright, yleft=yleft, rule=rule, f=f, ties=ties)$y ) ) } } out <- writeValues(out, v, start=tr$row[j]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) raster/R/rasterFromCells.R0000644000176200001440000000124014507510157015207 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 rasterFromCells <- function(x, cells, values=TRUE) { x <- raster(x) u <- stats::na.omit(unique(cells)) # now removing NAs 2018-02-22 u <- u[ u > 0 & u <= ncell(x) ] if (length(u) == 0) { stop('no valid cells') } cols <- colFromCell(x, u) rows <- rowFromCell(x, u) res <- res(x) x1 <- xFromCol(x, min(cols)) - 0.5 * res[1] x2 <- xFromCol(x, max(cols)) + 0.5 * res[1] y1 <- yFromRow(x, max(rows)) - 0.5 * res[2] y2 <- yFromRow(x, min(rows)) + 0.5 * res[2] e <- extent(x1, x2, y1, y2) r <- crop(x, e) if (values) { r <- setValues(r, cellsFromExtent(x, e)) } return(r) } raster/R/union.R0000644000176200001440000000102714507510157013233 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 setMethod('union', signature(x='Extent', y='Extent'), function(x, y) { .unionExtent(x, y) } ) .unionExtent <- function(x, ...) { objects <- c(x, list(...)) if (length(objects) == 1) { return(extent(x)) } e <- extent(objects[[1]]) for (i in 2:length(objects)) { e2 <- extent(objects[[i]]) e@xmin <- min(e@xmin, e2@xmin) e@xmax <- max(e@xmax, e2@xmax) e@ymin <- min(e@ymin, e2@ymin) e@ymax <- max(e@ymax, e2@ymax) } return(e) } raster/R/hdr.R0000644000176200001440000000355614507510157012671 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 hdr <- function(x, format, extension='.wld', filename='') { if (inherits(x, 'RasterStack')) { stop('Only applicable to RasterLayer and RasterBrick classes (and their derivates)') } if (x@file@name == '') { if (filename == '') { stop('Object has no filename; and none provided as argument') } else { x@file@name = filename } } # if (missing(filename)) { # if (x@file@name == '') { # stop('Object has no filename; please provide a "filename=" argument') # } # } else { # fn <- trim(as.character(filename[1])) # if (nchar(fn) < 1) { # stop('invalid filename') # } # x@file@name == fn # } type <- toupper(format) if (type=="RASTER") { .writeHdrRaster(x) } else if (type=="WORLDFILE") { .worldFile(x, extension) } else if (type=="VRT") { .writeHdrVRT(x) .writeStx(x) } else if (type=="BIL") { .writeHdrBIL(x) .writeStx(x) } else if (type=="BSQ") { .writeHdrBIL(x, "BSQ") .writeStx(x) } else if (type=="BIP") { .writeHdrBIL(x, "BIP") .writeStx(x) } else if (type=="ERDASRAW") { .writeHdrErdasRaw(x) .writeStx(x) } else if (type=="ENVI") { .writeHdrENVI(x) .writeStx(x) } else if (type=="SAGA") { .writeHdrSAGA(x) } else if (type=="IDRISI") { .writeHdrIDRISI(x) } else if (type=="IDRISIold") { .writeHdrIDRISI(x, old=TRUE) } else if (type=="PRJ") { .writeHdrPRJ(x, ESRI=TRUE) } else { stop("This file format is not supported") } return( invisible(TRUE) ) } .writeStx <- function(x, filename='') { if (x@data@haveminmax) { if (filename=='') { filename <- filename(x) } if (filename!='') { extension(filename) <- ".stx" thefile <- file(filename, "w") # open a txt file connectionis cat(1, " ", minValue(x), " ", maxValue(x), "\n", file = thefile) close(thefile) } } return( invisible(TRUE) ) } raster/R/cellFromLine.R0000644000176200001440000000150014507510157014452 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 cellFromLine <- function(object, lns) { spbb <- sp::bbox(lns) rsbb <- bbox(object) addres <- 2 * max(res(object)) nlns <- length( lns@lines ) res <- list() res[[nlns+1]] = NA if (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) { return(res[1:nlns]) } rr <- raster(object) for (i in 1:nlns) { pp <- lns[i,] spbb <- sp::bbox(pp) if (! (spbb[1,1] > rsbb[1,2] | spbb[1,2] < rsbb[1,1] | spbb[2,1] > rsbb[2,2] | spbb[2,2] < rsbb[2,1]) ) { rc <- crop(rr, extent(pp)+addres) rc <- .linesToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # always TRUE? res[[i]] <- cellFromXY(object, xy) } } } return( res[1:nlns] ) } raster/R/plotExent.R0000644000176200001440000000073514507510157014072 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 .extentMatrix <- function(x) { xy <- matrix(NA, nrow=5, ncol=2) xy[c(1,4),1] <- x@xmin xy[2:3,1] <- x@xmax xy[1:2,2] <- x@ymax xy[3:4,2] <- x@ymin xy[5,] <- xy[1,] return(xy) } setMethod("plot", signature(x='Extent', y='missing'), function(x, y, type='l', add=FALSE, ...) { xy <- .extentMatrix(x) if (add) { lines(xy, ...) } else { plot(xy, type=type, ...) } } ) raster/R/hdrEnvi.R0000644000176200001440000000436414507510157013511 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrENVI <- function(r) { hdrfile <- filename(r) extension(hdrfile) <- ".hdr" thefile <- file(hdrfile, "w") cat("ENVI\n", file = thefile) cat("samples = ", ncol(r), "\n", file = thefile) cat("lines = ", nrow(r), "\n", file = thefile) cat("bands = ", r@file@nbands, "\n", file = thefile) cat("header offset = 0\n", file = thefile) cat("file type = ENVI Standard\n", file = thefile) dsize <- dataSize(r@file@datanotation) if (.shortDataType(r@file@datanotation) == 'INT') { if (dsize == 1) { dtype <- 1 } else if (dsize == 2) { dtype <- 2 } else if (dsize == 4) { dtype <- 3 } else if (dsize == 8) { dtype <- 14 } else { stop('what?') } } else { if (dsize == 4) { dtype <- 4 } else if (dsize == 8) { dtype <- 5 } else { stop('what?') } } cat("data type = ", dtype, "\n", file = thefile) #1=8-bit byte; 2=16-bit signed integer; 3=32-bit signed long integer; 4=32-bit floating point; #5=64-bit double-precision floating point; 6=2x32-bit complex, real-imaginary pair of double precision; #9=2x64-bit double-precision complex, real-imaginary pair of double precision; 12=16-bit unsigned integer; #13=32-bit unsigned long integer; 14=64-bit signed long integer; and 15=64-bit unsigned long integer. cat("data ignore value=", .nodatavalue(r), "\n", file = thefile, sep='') cat("interleave = ", r@file@bandorder, "\n", file = thefile) cat("sensor type = \n", file = thefile) btorder <- as.integer(r@file@byteorder != 'little') # little -> 0, big -> 1 cat("byte order = ", btorder, "\n",file = thefile) if (couldBeLonLat(r)) { cat("map info = {Geographic Lat/Lon, 1, 1,", xmin(r),", ", ymax(r),", ", xres(r),", ", yres(r), "}\n", file = thefile) } else { cat("map info = {projection, 1, 1,", xmin(r),", ", ymax(r),", ", xres(r),", ", yres(r), "}\n", file = thefile) } # if (.requireRgdal(FALSE)) { # cat("coordinate system string = {", wkt(r), "}\n", file = thefile, sep="") # } else { cat("projection info =", proj4string(r), "\n", file = thefile) # } cat("z plot range = {", minValue(r),", ", maxValue(r), "}\n", file = thefile) cat("band names = {", paste(names(r),collapse=","), "}", "\n", file = thefile) close(thefile) } raster/R/rasterizeLines.R0000644000176200001440000002442014507510157015110 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .specialRowFromY <- function(object, y) { rownr <- 1 + (trunc((ymax(object) - y)/yres(object))) rownr[y == ymin(object)] <- nrow(object) rownr[y > ymax(object)] <- -1 rownr[y < ymin(object)] <- nrow(object) + 1 return(rownr) } .specialColFromX <- function(object, x) { colnr <- (trunc((x - xmin(object))/xres(object))) + 1 colnr[x == xmax(object)] <- ncol(object) colnr[x < xmin(object)] <- -1 colnr[x > xmax(object)] <- ncol(object) + 1 return(colnr) } .getCols <- function(rs, rownr, aline, line1, line2) { minx <- xmin(rs) maxx <- xmax(rs) resxy <- matrix(NA, ncol=2, nrow=0) miny <- min(line1[,2], line2[,2]) maxy <- max(line1[,2], line2[,2]) xyxy <- cbind(aline[1:(length(aline[,1])-1), ,drop=FALSE], aline[-1, ,drop=FALSE]) xyxy <- subset(xyxy, !( (xyxy[,2] > maxy & xyxy[,4] > maxy ) | (xyxy[,2] < miny & xyxy[,4] < miny)) ) if (length(xyxy) < 1) { return(resxy) } res <- vector(length=0) for (i in 1:length(xyxy[,1])) { rows <- .specialRowFromY(rs, c(xyxy[i,2], xyxy[i,4]) ) if ((rows[1] > rownr & rows[2] > rownr) | (rows[1] < rownr & rows[2] < rownr)) { next } cols <- .specialColFromX(rs, c(xyxy[i,1], xyxy[i,3])) if ((cols[1] < 1 & cols[2] < 1) | (cols[1] > ncol(rs) & cols[2] > ncol(rs))) { next } rowcol <- cbind(rows, cols)[order(cols),] if (rowcol[1,1] == rowcol[2,1]) { # entire line segment in row add <- rowcol[1,2]:rowcol[2,2] add <- subset(add, add>0 & add<=ncol(rs)) res <- c(res, add) } else { if (rowcol[1,1] == rownr ) { # line segment starts in this row if (rowcol[2,1] < rownr) { xy <- .intersectSegments(line1[1,1], line1[1,2], line1[2,1], line1[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } else { xy <- .intersectSegments(line2[1,1], line2[1,2], line2[2,1], line2[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } if (is.na(xy[1])) { xy <- xyxy[i,3:4] } xy <- t(as.matrix(xy)) outcol = min(.specialColFromX(rs, xy[,1]), ncol(rs)) if (outcol < 1) next cols <- c(max(1, rowcol[1,2]), outcol) col1 <- min(cols) col2 <- max(cols) res <- c(res, col1:col2) } else if (rowcol[2,1] == rownr) { # line segment ends in this row if (rowcol[1,1] < rownr) { xy <- .intersectSegments(line1[1,1], line1[1,2], line1[2,1], line1[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } else { xy <- .intersectSegments(line2[1,1], line2[1,2], line2[2,1], line2[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) } if (is.na(xy[1])) { next } xy <- t(as.matrix(xy)) incol <- max(1, .specialColFromX(rs, xy[,1])) if (incol > ncol(rs)) next cols <- c(incol, min(ncol(rs), rowcol[2,2])) col1 <- min(cols) col2 <- max(cols) res <- c(res, col1:col2) } else { # line segment crosses this row xy1 <- .intersectSegments(line1[1,1], line1[1,2], line1[2,1], line1[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) xy2 <- .intersectSegments(line2[1,1], line2[1,2], line2[2,1], line2[2,2], xyxy[i,1], xyxy[i,2], xyxy[i,3], xyxy[i,4] ) if (is.na(xy1[1])) { next } if (is.na(xy2[1])) { next } xy <- rbind(xy1, xy2) cols <- .specialColFromX(rs, xy[,1]) col1 <- min(cols) col2 <- max(cols) if (col1 > ncol(rs)) { next } if (col2 == -1) { next } if (col1 == -1) { col1 <- 1 } if (col2 > ncol(rs)) { col2 <- ncol(rs) } res <- c(res, col1:col2) } } } return(res) } .rasterizeLineLength <- function(x, r, background=NA, filename="", ...) { # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) r <- raster(r) if (canProcessInMemory(r, n=8)) { r[] <- 1:ncell(r) rp <- rasterToPolygons(r) rp <- intersect(x, rp) # lengths <- rgeos::gLength(rp, byid=TRUE) / 1000 lengths <- perim(vect(rp)) / 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 lengths <- perim(vect(rp)) / 1000 n <- tapply(lengths, data.frame(rp)[, names(y)], sum) v <- rep(background, ncell(y)) v[as.integer(names(n))] <- n out <- writeValues(out, v, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } } .linesToRaster <- function(lns, x, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue="all", filename="", ...) { dots <- list(...) if (!is.null(dots$overlap)) { stop('argument "overlap" is no longer available. Use "fun"') } if (!is.null(dots$updateRaster)) { stop('argument "updateRaster" is no longer available. Use "update"') } filename <- trim(filename) if (mask & update) { stop('use either "mask=TRUE" OR "update=TRUE" (or neither)') } if (update) { if (!is.numeric(updateValue)) { if (is.na(updateValue)) { updateValue <- 'NA' } else if (!(updateValue == 'NA' | updateValue == '!NA' | updateValue == 'all')) { stop('updateValue should be either "all", "NA", "!NA"') } } } if (is.character(fun)) { if (!(fun %in% c('first', 'last', 'sum', 'min', 'max', 'count', 'length'))) { stop('invalid character value for fun') } doFun <- FALSE if (fun == 'length') { if (mask) { fun <- 'first' } else if (update) { stop('cannot do update with length yet --- come back later...') } else { return(.rasterizeLineLength(lns, x, background=background, update=FALSE, updateValue="all", filename="", ...) ) } } } else { doFun <- TRUE } rstr <- raster(x) if (!is.na(projection(lns))) { projection(rstr) <-.getCRS(lns) } if (inherits(lns, 'SpatialPolygons')) { lns <- as(lns, "SpatialLines") } if (! inherits(lns, 'SpatialLines')) { stop('lns should be, or inherit from, a SpatialLines* object') } # check if bbox of raster and lns overlap spbb <- sp::bbox(lns) rsbb <- bbox(rstr) if (spbb[1,1] > rsbb[1,2] | spbb[2,1] > rsbb[2,2]) { stop('lines and raster have no overlapping areas') } nline <- length(lns@lines) info <- matrix(NA, nrow=nline, ncol=4) info[,4] <- 1:nrow(info) info[,1] <- sapply(lns@lines, function(i) length(i@Lines)) for (i in 1:nline) { r <- range(sapply( lns@lines[[i]]@Lines, function(j) range(j@coords[,2]))) info[i,2] <- r[1] info[i,3] <- r[2] } lxmin <- min(spbb[1,1], rsbb[1,1]) - 0.5 * xres(rstr) lxmax <- max(spbb[1,2], rsbb[1,2]) + 0.5 * xres(rstr) pvals <- .getPutVals(lns, field, nline, mask) putvals <- pvals[,1] if (ncol(pvals) > 1) { rstr@data@isfactor <- TRUE rstr@data@attributes <- list(pvals) } if (filename == "") { v <- matrix(NA, ncol=nrow(rstr), nrow=ncol(rstr)) } else { rstr <- writeStart(rstr, filename=filename, ...) } rv1 <- rep(NA, ncol(rstr)) lst1 <- vector(length=length(rv1), mode='list') yrs <- yres(rstr) pb <- pbCreate(nrow(rstr), label='rasterize', ...) for (r in 1:nrow(rstr)) { ly <- yFromRow(rstr, r) uly <- ly + 0.51 * yrs lly <- ly - 0.51 * yrs info1 <- subset(info, !(info[,2] > uly | info[,3] < lly ) ) # subpol <- subset(polinfo, !(polinfo[,2] > ly | polinfo[,3] < ly), drop=FALSE) if (doFun) { rv <- lst1 } else { rv <- rv1 } if (nrow(info1) > 0) { line1 <- rbind(c(lxmin, ly + 0.5*yrs), c(lxmax,ly + 0.5*yrs)) line2 <- rbind(c(lxmin, ly - 0.5*yrs), c(lxmax,ly - 0.5*yrs)) for (k in 1:nrow(info1)) { i <- info1[k,4] for (j in 1:info1[k,1]) { if ( max ( lns@lines[[i]]@Lines[[j]]@coords[,2] ) < lly | min( lns@lines[[i]]@Lines[[j]]@coords[,2] ) > uly ) { # line part entirely outside of row. do nothing } else { aline <- lns@lines[[i]]@Lines[[j]]@coords #cat(i, "\n"); utils::flush.console(); colnrs <- .getCols(rstr, r, aline, line1, line2) if ( length(colnrs) > 0 ) { rvtmp <- rv1 rvtmp[colnrs] <- putvals[i] if (doFun) { ind <- which(!is.na(rvtmp)) for (ii in ind) { rv[[ii]] <- c(rv[[ii]], rvtmp[ii]) } } else if (mask) { rv[!is.na(rvtmp)] <- rvtmp[!is.na(rvtmp)] } else if (fun=='last') { rv[!is.na(rvtmp)] <- rvtmp[!is.na(rvtmp)] } else if (fun=='first') { rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='sum') { rv[!is.na(rv) & !is.na(rvtmp)] <- rv[!is.na(rv) & !is.na(rvtmp)] + rvtmp[!is.na(rv) & !is.na(rvtmp)] rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='min') { rv[!is.na(rv) & !is.na(rvtmp)] <- pmin(rv[!is.na(rv) & !is.na(rvtmp)], rvtmp[!is.na(rv) & !is.na(rvtmp)]) rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='max') { rv[!is.na(rv) & !is.na(rvtmp)] <- pmax(rv[!is.na(rv) & !is.na(rvtmp)], rvtmp[!is.na(rv) & !is.na(rvtmp)]) rv[is.na(rv)] <- rvtmp[is.na(rv)] } else if (fun=='count') { rvtmp[!is.na(rvtmp)] <- 1 rv[!is.na(rv) & !is.na(rvtmp)] <- rv[!is.na(rv) & !is.na(rvtmp)] + rvtmp[!is.na(rv) & !is.na(rvtmp)] rv[is.na(rv)] <- rvtmp[is.na(rv)] } } } } } } if (doFun) { for (i in 1:length(rv)) { if (is.null(rv[[i]])) { rv[[i]] <- NA } } rv <- sapply(rv, fun) } if (mask) { oldvals <- getValues(x, r) ind <- which(is.na(rv)) oldvals[ind] <- NA rv <- oldvals } else if (update) { oldvals <- getValues(x, r) if (is.numeric(updateValue)) { ind <- which(oldvals == updateValue & !is.na(rv)) } else if (updateValue == "all") { ind <- which(!is.na(rv)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { ind <- which(!is.na(oldvals) & !is.na(rv)) } oldvals[ind] <- rv[ind] rv <- oldvals } else { rv[is.na(rv)] <- background } if (filename == "") { v[,r] <- rv } else { rstr <- writeValues(rstr, rv, r) } pbStep(pb, r) } pbClose(pb) if (filename == "") { rstr <- setValues(rstr, as.vector(v)) } else { rstr <- writeStop(rstr) } return(rstr) } raster/R/imageplot2.R0000644000176200001440000001574514507510157014162 0ustar liggesusers# The functions is based on a function in the fields package # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html # # Adjustments by Robert Hijmans # July 2011 .asRaster <- function(x, col, breaks=NULL, r=NULL, colNA=NA, alpha=NULL) { if (!is.null(breaks)) { if (is.logical(x)) { x <- x * 1 } x[] <- as.numeric(cut(as.vector(x), breaks, include.lowest=TRUE)) } else { #if (is.function(fun)) { # x[] <- fun(x) #} if (is.null(r)) { r <- range(x, na.rm=TRUE) } if (r[1] == r[2]) { r[1] <- r[1] - 0.001 r[2] <- r[2] + 0.001 } x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) } x[] <- col[x] if (!is.na(colNA)) { x[is.na(x)] <- grDevices::rgb(t(grDevices::col2rgb(colNA)), maxColorValue=255) } if (!is.null(alpha)) { x[] <- paste(substr(as.vector(x), 1, 7), t(alpha), sep='') } as.raster(x) } .rasterImagePlot <- function(x, col, add=FALSE, legend=TRUE, horizontal = FALSE, legend.shrink=0.5, legend.width=0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab=NULL, graphics.reset=FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, lab.breaks=NULL, axis.args=NULL, legend.args = NULL, interpolate=FALSE, box=TRUE, breaks=NULL, zlim=NULL, zlimcol=NULL, fun=NULL, asp, colNA = NA, alpha=NULL, npretty=0, ...) { if (!is.null(alpha)) { if (is.vector(alpha)) { alpha <- matrix(alpha, nrow=nrow(x), ncol=ncol(x), byrow=TRUE) } alpha <- as.matrix(alpha) alpha[alpha < 0] <- 0 alpha[alpha > 1] <- 1 alpha[is.na(alpha)] <- 1 alpha <- alpha * 255 + 1 a <- c(0:9, LETTERS[1:6]) a <- paste(rep(a, each=16), rep(a, times=16), sep='') a <- a[alpha] alpha <- matrix(a, nrow(alpha), ncol(alpha), byrow=TRUE) } ffun <- NULL if (is.character(fun)) { if (fun %in% c('sqrt', 'log')) { if (fun == 'sqrt') { ffun <- fun fun <- sqrt } else { ffun <- fun fun <- log } } else { fun <- NULL } } else { fun <- NULL } lonlat <- .couldBeLonLat(x, warnings=FALSE) if (missing(asp)) { if (lonlat) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } } e <- as.vector(t(bbox(extent(x)))) x <- as.matrix(x) if (!is.null(fun)) { x <- fun(x) } x[is.infinite(x)] <- NA if (!is.null(zlim)) { if (!is.null(zlimcol)) { x[x < zlim[1]] <- zlim[1] x[x > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { x[x < zlim[1] | x > zlim[2]] <- NA } } if (is.null(breaks)) { suppressWarnings(zrange <- range(x, zlim, na.rm=TRUE)) } else { suppressWarnings(zrange <- range(x, zlim, breaks, na.rm=TRUE)) } if (! is.finite(zrange[1])) { legend <- FALSE } else { x <- .asRaster(x, col, breaks, zrange, colNA, alpha=alpha) } old.par <- graphics::par(no.readonly = TRUE) if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (legend.only) { box <- FALSE } else { if (!add) { graphics::par(plt = bigplot) if (lonlat & (npretty > 0)) { lX <- pretty(e[1]:e[2], npretty) lX <- lX[lX >= -180 & lX <= 180] lY <- pretty(e[3]:e[4], npretty) lY <- lY[lY >= -90 & lY <= 90] labelsX <- parse(text=paste(lX, "^o", sep="")) labelsY <- parse(text=paste(lY, "^o", sep="")) plot(NA, NA, xlim=e[1:2], ylim=e[3:4], type = "n", , xaxs ='i', yaxs = 'i', asp=asp, axes = FALSE, ...) graphics::axis(1, lX, labels=labelsX) graphics::axis(2, lY, labels=labelsY) } else { plot(NA, NA, xlim=e[1:2], ylim=e[3:4], type = "n", , xaxs ='i', yaxs = 'i', asp=asp, ...) } } graphics::rasterImage(x, e[1], e[3], e[2], e[4], interpolate=interpolate) big.par <- graphics::par(no.readonly = TRUE) } if (legend) { if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { graphics::par(old.par) stop("plot region is too small. Cannot add a legend\n") } ix <- 1 minz <- zrange[1] maxz <- zrange[2] if (minz == maxz) { if (!is.null(breaks)) { breaks=minz } else { minz <- minz - 0.001 maxz <- maxz + 0.001 } } graphics::par(new=TRUE, pty = "m", plt=smallplot, err = -1) if (!is.null(breaks)) { binwidth <- (maxz - minz)/100 midpoints <- seq(minz, maxz, by = binwidth) axis.args <- c(list(side=ifelse(horizontal,1,4), mgp=c(3,1,0), las=ifelse(horizontal,0,2)), axis.args) if (is.null(axis.args$at)) { axis.args$at <- breaks } if (is.null(axis.args$labels) ) { axis.args$labels=lab.breaks } } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } if (!horizontal) { plot(NA, NA, xlim=c(0, 1), ylim=c(minz, maxz), type="n", xlab="", ylab="", xaxs ='i', yaxs = 'i', axes=FALSE) if (is.null(breaks)) { mult <- round(max(1, 100 / length(col) )) xx <- .asRaster( ((mult*length(col)):1)/mult, col, colNA=colNA) } else { xx <- rev(.asRaster(midpoints, col, breaks=breaks, colNA=colNA)) } graphics::rasterImage(xx, 0, minz, 1, maxz, interpolate=FALSE) if (!is.null(ffun)) { at <- graphics::axTicks(2) axis.args$at <- at if (ffun=='sqrt') { at <- at^2 if (max(at) > 5) { at <- round(at, 0) } else { at <- round(at, 1) } at <- unique(at) axis.args$at <- sqrt(at) } else { at <- exp(at) if (max(at) > 5) { at <- round(at, 0) } else { at <- round(at, 1) } at <- unique(at) axis.args$at <- log(at) } axis.args$labels <- at } do.call(graphics::axis, axis.args) graphics::box() } else { plot(NA, NA, ylim=c(0, 1), xlim=c(minz, maxz), type="n", xlab="", ylab="", xaxs ='i', yaxs = 'i', axes=FALSE) if (is.null(breaks)) { mult <- round(max(1, 100 / length(col) )) xx <- t(.asRaster((1:(mult*length(col)))/mult, col, colNA=colNA )) } else { xx <- t(.asRaster(midpoints, col, breaks=breaks, colNA=colNA)) } graphics::rasterImage(xx, minz, 0, maxz, 1, interpolate=FALSE) do.call("axis", axis.args) graphics::box() } if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) } if (!is.null(legend.args)) { do.call(graphics::mtext, legend.args) } } mfg.save <- graphics::par()$mfg if (graphics.reset | add) { graphics::par(old.par) graphics::par(mfg = mfg.save, new = FALSE) } else { graphics::par(big.par) graphics::par(plt = big.par$plt, xpd = FALSE) graphics::par(mfg = mfg.save, new = FALSE) } if (!add & box ) graphics::box() invisible() } raster/R/clearValues.R0000644000176200001440000000207514507510157014355 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .clearRaster <- function(object) { object@data@inmemory <- FALSE # object@data@indices = vector(mode='numeric') object@data@values <- vector() if ( ! fromDisk(object) ) { object@data@min <- Inf object@data@max <- -Inf object@data@haveminmax <- FALSE } return(object) } clearValues <- function(x) { if (inherits(x, "BasicRaster")) { return(x) } else if (inherits(x, "RasterLayer" )) { x <- .clearRaster(x) } else if (inherits(x, "RasterStack") ) { for (i in seq(along.with=nlayers(x))) { if (fromDisk(x@layers[[i]])) { x@layers[[i]] <- .clearRaster(x@layers[[i]]) } } } else if (inherits(x, 'RasterBrick')) { x@data@values <- matrix(NA,0,0) x@data@inmemory <- FALSE # x@data@indices = c(0,0) if ( ! fromDisk(x) ) { x@data@min <- rep(Inf, nlayers(x)) x@data@max <- rep(-Inf, nlayers(x)) x@data@haveminmax <- FALSE } } return(x) } .clearFile <- function(x) { x@file@name <- '' x@data@fromdisk <- FALSE x@file@driver <- "" return(x) } raster/R/coerce.R0000644000176200001440000003356714642777135013374 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 ### from terra setAs("SpatRaster", "Raster", function(from) { if (any(terra::window(from))) { stop("you must remove the 'window' from the SpatRaster before coercion to a Raster*") } b <- sources(from, bands=TRUE) nl <- nlyr(from) e <- as.vector(ext(from)) prj <- crs(from) #, proj=TRUE) if (nl == 1) { if (b$source == "") { r <- raster::raster(ncols=ncol(from), nrows=nrow(from), crs=prj, xmn=e[1], xmx=e[2], ymn=e[3], ymx=e[4]) if (hasValues(from)) { raster::values(r) <- values(from) } } else { r <- raster::raster(b$source, band=b$bands) } } else { usid <- unique(b$sid) if ((length(usid) == 1) & (b$source[1] != "")) { if ((nl == nrow(b)) && (b$bands[1] == 1) && (all(diff(b$bands) == 1))) { r <- raster::brick(b$source[1]) if (nlayers(r) != nl) { r <- r[[b$bands]] } } else { r <- raster::stack(b$source[1], bands=b$bands) } } else if (all(b$source=="")) { r <- raster::brick(ncol=ncol(from), nrow=nrow(from), crs=prj, xmn=e[1], xmx=e[2], ymn=e[3], ymx=e[4], nl=nlyr(from)) if (hasValues(from)) { raster::values(r) <- values(from) } } else { x <- raster::raster(ncol=ncol(from), nrow=nrow(from), crs=prj, xmn=e[1], xmx=e[2], ymn=e[3], ymx=e[4]) r <- list() b$layer <- 1:nrow(b) for (i in usid) { bi <- b[b$sid == usid[i], ,drop=FALSE] if (bi$source[1] == "") { r[[i]] <- raster::setValues(x, values(from[[ bi$layer ]])) } else { bands <- bi$bands if (length(bands) > 1) { r[[i]] <- raster::stack(b$source[i], bands=bands) } else { r[[i]] <- raster::raster(b$source[i], band=bands) } } } r <- raster::stack(r) } } if (hasValues(from)) { so <- scoff(from) gain(r) <- so[,1] offs(r) <- so[,2] } # things that may be different than the file source try(levels(r) <- cats(from), silent=TRUE) try(names(r) <- names(from)) #crs(r) <- crs(from) extent(r) <- as.vector(ext(from)) projection(r) <- crs(from, proj=TRUE) r } ) ## to terra .fromRasterLayerBrick <- function(from) { if (fromDisk(from)) { f <- filename(from) if (from@file@driver == "netcdf") { v <- attr(from@data, "zvar") r <- rast(f, v) } else { r <- try(rast(f), silent=TRUE) if (inherits(r, "try-error")) { r <- rast(from + 0) levs <- levels(from)[[1]] if (!is.null(levs)) { levels(r) <- levs } } if (nbands(from) != nlayers(from)) { r <- r[[bandnr(from)]] } } if (from@file@NAchanged) { NAflag(r) <- from@file@nodatavalue } scoff(r) <- cbind(gain(from), offs(from)) } else { r <- rast( nrows=nrow(from), ncols=ncol(from), nlyrs=nlayers(from), extent=extent(from)) if (hasValues(from)) { values(r) <- values(from) } levs <- levels(from)[[1]] if (!is.null(levs)) { if (ncol(levs) == 1) { levs <- cbind(value=1:nrow(levs), levs) } levels(r) <- levs } } if (.hasSlot(from, "srs")) { prj <- from@srs } else { prj <- .srs_from_sp(from@crs) } crs(r, warn=FALSE) <- prj #z <- from@z #if (length(z) == 1) { # z <- z[[1]] # try(time(r) <- z, silent=TRUE) #} r } .fromRasterStack <- function(from) { nl <- nlayers(from) ff <- sapply(1:nl, function(i) { filename(from[[i]]) }) uff <- unique(ff) if (length(uff) == 1) { if (uff == "") { return(.fromRasterLayerBrick(from)) } else { n <- nbands(from[[1]]) bnr <- sapply(1:nl, function(i) { bandnr(from[[i]]) }) if ((n == nl) && all(bnr == 1:n)) { return( rast(uff) ) } } } s <- lapply(1:nlayers(from), function(i) { x <- from[[i]] .fromRasterLayerBrick(x) }) out <- do.call(c, s) g <- gc() out } setAs("Raster", "SpatRaster", function(from) { if (inherits(from, "RasterLayer") || inherits(from, "RasterBrick")) { x <- .fromRasterLayerBrick(from) } else { x <- .fromRasterStack(from) } names(x) <- names(from) ext(x) <- as.vector(extent(from)) if (.hasSlot(from, "srs")) { prj <- from@srs } else { prj <- .srs_from_sp(from@crs) } crs(x, warn=FALSE) <- prj x } ) # To sp pixel/grid objects setAs("Raster", "GridTopology", function(from) { rs <- res(from) orig <- bbox(from)[,1] + 0.5 * rs sp::GridTopology(orig, rs, dim(from)[2:1] ) } ) setAs("GridTopology", "RasterLayer", function(from) { raster(extent(from), nrows=from@cells.dim[2], ncols=from@cells.dim[1]) } ) setAs("Raster", "SpatialPixels", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the 'rectify' function") } sp <- rasterToPoints(from, fun=NULL, spatial=FALSE) r <- raster(from) sp <- sp::SpatialPoints(sp[,1:2,drop=FALSE], proj4string= .getCRS(r)) grd <- as(r, "GridTopology") sp::SpatialPixels(points=sp, grid=grd) } ) setAs("Raster", "SpatialPixelsDataFrame", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* object\n or first use the 'rectify' function") } v <- rasterToPoints(from, fun=NULL, spatial=FALSE) r <- raster(from) sp <- sp::SpatialPoints(v[,1:2,drop=FALSE], proj4string= .getCRS(r)) grd <- as(r, "GridTopology") if (ncol(v) > 2) { v <- data.frame(v[, 3:ncol(v), drop = FALSE]) if (any(is.factor(from))) { f <- levels(from) for (i in 1:length(f)) { if (!is.null(f[[i]])) { v[,i] <- as.factor(f[[i]][v[,i]]) } } } sp::SpatialPixelsDataFrame(points=sp, data=v, grid=grd) } else { warning("object has no values, returning a 'SpatialPixels' object") sp::SpatialPixels(points=sp, grid=grd) } } ) setAs("Raster", "SpatialGrid", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the 'rectify' function") } r <- raster(from) grd <- as(r, "GridTopology") sp::SpatialGrid(grd, proj4string=.getCRS(r)) } ) setAs("Raster", "SpatialGridDataFrame", function(from) { if (rotated(from)) { stop("\n Cannot coerce because the object is rotated.\n Either coerce to SpatialPoints* from\n or first use the 'rectify' function") } r <- raster(from) grd <- as(r, "GridTopology") if (hasValues(from)) { sp <- sp::SpatialGridDataFrame(grd, proj4string=.getCRS(r), data=as.data.frame(from)) } else { warning("object has no values, returning a 'SpatialGrid' object") sp <- sp::SpatialGrid(grd, proj4string=.getCRS(r)) } sp } ) # To sp vector objects setAs("Raster", "SpatialPolygons", function(from){ r <- rasterToPolygons(from[[1]]) as(r, "SpatialPolygons") } ) setAs("Raster", "SpatialPolygonsDataFrame", function(from){ return( rasterToPolygons(from) ) } ) setAs("Raster", "SpatialPoints", function(from) { sp::SpatialPoints(rasterToPoints(from, spatial=FALSE)[,1:2], proj4string=.getCRS(from)) } ) setAs("Raster", "SpatialPointsDataFrame", function(from) { rasterToPoints(from, spatial=TRUE) } ) setAs("Extent", "SpatialPolygons", function(from){ p <- rbind(c(from@xmin, from@ymin), c(from@xmin, from@ymax), c(from@xmax, from@ymax), c(from@xmax, from@ymin), c(from@xmin, from@ymin) ) sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(p)), "1"))) } ) setAs("Extent", "SpatialLines", function(from){ p <- rbind(c(from@xmin, from@ymin), c(from@xmin, from@ymax), c(from@xmax, from@ymax), c(from@xmax, from@ymin), c(from@xmin, from@ymin) ) sp::SpatialLines(list(sp::Lines(list(sp::Line(p)), "1"))) } ) setAs("Extent", "SpatialPoints", function(from){ p <- cbind( x=c( from@xmin, from@xmin, from@xmax, from@xmax), y=c(from@ymin, from@ymax, from@ymin, from@ymax) ) sp::SpatialPoints(p) } ) # to RasterLayer setAs("SpatialGrid", "RasterLayer", function(from){ return(raster (from)) } ) setAs("SpatialPixels", "RasterLayer", function(from){ return(raster (from)) } ) setAs("SpatialGrid", "BasicRaster", function(from){ to <- methods::new("BasicRaster") to@extent <- extent(from) crs(to) <- from@proj4string dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1]) return(to) } ) setAs("SpatialPixels", "BasicRaster", function(from){ to <- methods::new("BasicRaster") to@extent <- extent(from) crs(to) <- from@proj4string dim(to) <- c(from@grid@cells.dim[2], from@grid@cells.dim[1]) return(to) } ) # to RasterStack setAs("SpatialGrid", "RasterStack", function(from){ stack(from) } ) setAs("SpatialPixels", "RasterStack", function(from){ stack(from) } ) # to RasterBrick setAs("SpatialGrid", "RasterBrick", function(from){ return(brick(from)) } ) setAs("SpatialPixels", "RasterBrick", function(from){ return(brick(from)) } ) setAs("STFDF", "RasterBrick", function(from) { time <- from@time nc <- ncol(from@data) r <- raster(from@sp) b <- brick(r, nl=length(time) * nc) b <- setZ(b, rep(time, nc)) # rep changes some time formats names(b) <- paste(rep(colnames(from@data), each=length(time)), as.character(time), sep="") # need to improve this for character, factor variables m <- as.numeric(as.matrix(from@data)) setValues(b, m) } ) setAs("STSDF", "RasterBrick", function(from) { from <- as(from, "STFDF") as(from, "RasterBrick") } ) # Between Raster objects setAs("RasterStack", "RasterLayer", function(from){ return( raster(from)) } ) setAs("RasterBrick", "RasterLayer", function(from){ return( raster(from)) } ) setAs("RasterStack", "RasterBrick", function(from){ return( brick(from)) } ) setAs("RasterBrick", "RasterStack", function(from){ return( stack(from)) } ) setAs("RasterLayer", "RasterStack", function(from){ return( stack(from)) } ) setAs("RasterLayer", "RasterBrick", function(from){ return( brick(from)) } ) setAs("matrix", "RasterLayer", function(from){ return(raster(from)) } ) setAs("RasterLayer", "matrix", function(from){ return( getValues(from, format="matrix")) } ) # "image" .rasterToImage <- function(r) { x <- xFromCol(r,1:ncol(r)) y <- yFromRow(r, nrow(r):1) z <- t(as.matrix(r)[nrow(r):1,]) list(x=x, y=y, z=z) } # spatstat setAs("im", "RasterLayer", function(from) { r <- raster(nrows=from$dim[1], ncols=from$dim[2], xmn=from$xrange[1], xmx=from$xrange[2], ymn=from$yrange[1], ymx=from$yrange[2], crs="") r <- setValues(r, from$v) flip(r, direction="y") } ) # adehabitat setAs("asc", "RasterLayer", function(from) { d <- t(from[]) d <- d[nrow(d):1, ] type <- attr(from, "type") if (type == "factor") { warning("factor type converted to numeric") } cz <- attr(from, "cellsize") xmn <- attr(from, "xll") - 0.5 * cz ymn <- attr(from, "yll") - 0.5 * cz xmx <- xmn + ncol(d) * cz ymx <- ymn + nrow(d) * cz e <- extent(xmn, xmx, ymn, ymx) d <- raster(d) extent(d) = e return(d) } ) setAs("RasterLayer", "asc", function(from) { asc <- getValues(from, format="matrix") asc <- asc[nrow(asc):1, ] attr(asc, "cellsize") <- xres(from) attr(asc, "xll") <- xmin(from) + 0.5 * xres(from) attr(asc, "yll") <- ymin(from) + 0.5 * yres(from) attr(asc, "type") <- "numeric" class(asc) <- "asc" return(asc) } ) setAs("kasc", "RasterBrick", function(from) { names <- colnames(from) cz <- attr(from, "cellsize") ncol <- attr(from, "ncol") nrow <- attr(from, "nrow") xmn <- attr(from, "xll") - 0.5 * cz ymn <- attr(from, "yll") - 0.5 * cz xmx <- xmn + ncol * cz ymx <- ymn + nrow * cz e <- extent(xmn, xmx, ymn, ymx) b <- brick(e, nrow=nrow, ncol=ncol) m = matrix(NA, ncol=ncol(from), nrow=nrow(from)) for (i in 1:ncol(m)) { m[,i] <- as.numeric(from[,i]) } dim(m) <- dim(from) b <- setValues(b, m) names(b) <- names return(b) } ) setAs("kasc", "RasterStack", function(from) { names <- colnames(from) cz <- attr(from, "cellsize") ncol <- attr(from, "ncol") nrow <- attr(from, "nrow") xmn <- attr(from, "xll") - 0.5 * cz ymn <- attr(from, "yll") - 0.5 * cz xmx <- xmn + ncol * cz ymx <- ymn + nrow * cz e <- extent(xmn, xmx, ymn, ymx) r <- raster(e, nrow=nrow, ncol=ncol) r <- setValues(r, as.numeric(from[,1])) names(r) <- names[1] s <- stack(r) if (ncol(from) > 1) { for (i in 2:ncol(from)) { r <- setValues(r, as.numeric(from[,i])) names(r) <- names[i] s <- addLayer(s, r) } } return(s) } ) # kernel density estimate (kde) from package ks setAs("kde", "RasterLayer", function(from) { x <- t(from$estimate) x <- x[nrow(x):1,] raster(x, xmn=min(from$eval.points[[1]]), xmx=max(from$eval.points[[1]]), ymn=min(from$eval.points[[2]]), ymx=max(from$eval.points[[2]]) ) } ) setAs("grf", "RasterBrick", function(from) { x <- from$data if (!is.matrix(x)) { x <- matrix(x) } ncell <- nrow(x) nl <- ncol(x) nc <- nr <- as.integer(sqrt(ncell)) dim(x) <- c(nr, nc, nl) x = aperm(x, perm=c(2,1,3)) b <- brick(x) b <- flip(b, "y") extent(b) <- extent(as.vector(apply(from$coords, 2, range))) b } ) setAs("grf", "RasterLayer", function(from) { x <- from$data if (is.matrix(x)) { x <- x[,1] } ncell <- length(x) nc <- nr <- as.integer(sqrt(ncell)) dim(x) <- c(nr, nc) x <- t(x)[nrow(x):1,] r <- raster(x) extent(r) <- extent(as.vector(apply(from$coords, 2, range))) r } ) # setAs("RasterStackBrick", "big.matrix", # function(from, filename="") { # b <- big.matrix(ncell(from), nlayers(from), backingfile=filename ) # names(b) <- colnames(from) # op <- options("bigmemory.allow.dimnames") # options(bigmemory.allow.dimnames=TRUE) # colnames(b) <- names(from) # options(bigmemory.allow.dimnames=op) # if (canProcessInMemory(from)) { # b[] <- as.matrix(from) # } else { # nc <- ncol(from) # tr <- blockSize(from) # for (i in 1:tr$n) { # start <- ((tr$row[i]-1) * nc) + 1 # end <- start + (tr$nrows[i] * nc) - 1 # b[start:end, ] <- getValues(from, row=tr$row[i], nrows=tr$nrows[i]) # } # } # b # } raster/R/raster.R0000644000176200001440000002540414643101465013407 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2008 # Version 1.0 # Licence GPL v3 setMethod('raster', signature(x='missing'), function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, crs, ext, resolution, vals=NULL) { if (missing(ext)) { ext <- extent(xmn, xmx, ymn, ymx) } if (missing(crs)) { if (ext@xmin > -360.01 & ext@xmax < 360.01 & ext@ymin > -90.01 & ext@ymax < 90.01) { crs <- .spCRS("+proj=longlat +datum=WGS84") } else { # if sp >= 1.2.1 crs <- .spCRS(as.character(NA), doCheckCRSArgs=FALSE) crs <- .spCRS(as.character(NA), doCheckCRSArgs=FALSE) } } 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) } else { r <- methods::new('RasterLayer', extent=ext) res(r) <- resolution } projection(r) <- crs 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 <- .spCRS("+proj=longlat +datum=WGS84") } else { crs <- .spCRS(as.character(NA)) } } else { crs <- .getCRS(crs) } x <- t(x$z) x <- x[nrow(x):1, ] r <- raster( x, xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs ) return(r) } ) setMethod('raster', signature(x='matrix'), function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", template=NULL) { crs <- .getCRS(crs) if (!is.null(template)) { if (inherits(template, 'Extent')) { r <- raster(template, crs=crs) } else { r <- raster(template) } } else { r <- raster(ncols=ncol(x), nrows=nrow(x), xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs) } r <- setValues(r, as.vector(t(x))) return(r) } ) # setMethod('raster', signature(x='big.matrix'), # function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs=NA, template=NULL) { # if (isTRUE(is.na(crs))) { # crs <- as.character(NA) # } # if (!is.null(template)) { # if (inherits(template, 'Extent')) { # r <- raster(template, crs=crs) # } else { # r <- raster(template) # } # } else { # r <- raster(ncols=ncol(x), nrows=nrow(x), xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs) # } # # r@file@driver <- 'big.matrix' # # if (is.filebacked(x)) { # # r@file@name <- bigmemory:::file.name(x) # # } # r@data@fromdisk <- TRUE # r@data@inmemory <- FALSE # attr(r@file, 'big.matrix') <- x # return(r) # } # ) setMethod('raster', signature(x='character'), function(x, band=1, ...) { x <- .fullFilename(x) r <- .rasterObjectFromFile(x, band=band, objecttype='RasterLayer', ...) return(r) } ) setMethod('raster', signature(x='BasicRaster'), function(x) { r <- raster(x@extent, nrows=x@nrows, ncols=x@ncols, crs=.getCRS(x)) if (rotated(x)) { r@rotated <- TRUE r@rotation <- x@rotation } return(r) } ) setMethod('raster', signature(x='RasterLayer'), function(x) { r <- raster(x@extent, nrows=x@nrows, ncols=x@ncols, crs=.getCRS(x)) r@rotated <- x@rotated r@rotation <- x@rotation r@file@blockrows <- x@file@blockrows r@file@blockcols <- x@file@blockcols return(r) } ) setMethod('raster', signature(x='RasterStack'), function(x, layer=0){ newindex = -1 if (nlayers(x) > 0) { if (!is.numeric(layer)) { newindex <- which(names(x) == layer)[1] if (is.na (newindex) ) { warning('variable', layer, 'does not exist') newindex = -1 } layer <- newindex } } if ( layer > 0 ) { dindex <- max(1, min(nlayers(x), layer)) if (dindex != layer) { warning(paste("layer was changed to", dindex))} r <- x@layers[[dindex]] names(r) <- names(x)[dindex] } else { r <- raster(extent(x)) dim(r) <- c(nrow(x), ncol(x)) projection(r) <- .getCRS(x) } extent(r) <- extent(x) # perhaps it was changed by user and different on disk if (rotated(x@layers[[1]])) { r@rotated <- TRUE r@rotation <- x@layers[[1]]@rotation } return(r) } ) setMethod('raster', signature(x='RasterBrick'), function(x, layer=0){ newindex <- -1 if (nlayers(x) > 0) { if (!is.numeric(layer)) { newindex <- which(names(x) == layer)[1] if (is.na (newindex) ) { warning('variable', layer, 'does not exist') newindex = -1 } layer <- newindex } layer <- round(layer) } if (layer > 0) { dindex <- as.integer(max(1, min(nlayers(x), layer))) if ( fromDisk(x) ) { if (dindex != layer) { warning(paste("layer was changed to", dindex))} # better raster(filename(x), band=dindex) ? # with zvar for ncdf files? r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=.getCRS(x)) r@file <- x@file r@file@blockrows <- x@file@blockrows[dindex] r@file@blockcols <- x@file@blockcols[dindex] r@file@nbands <- nlayers(x) r@data@offset <- x@data@offset[dindex] r@data@gain <- x@data@gain[dindex] r@data@inmemory <- FALSE r@data@fromdisk <- TRUE r@data@haveminmax <- x@data@haveminmax r@data@band <- dindex r@data@min <- x@data@min[dindex] r@data@max <- x@data@max[dindex] ln <- x@data@names[dindex] if (! is.na(ln) ) { r@data@names <- ln } #zv <- unlist(x@z[1])[dindex] zv <- NULL try( zv <- x@z[[1]][dindex], silent=TRUE ) if (! is.null(zv) ) { r@z <- list(zv) } # ncdf files zvar <- try(methods::slot(x@data, 'zvar'), silent=TRUE) if (!(inherits(zvar, "try-error"))) { attr(r@data, "zvar") <- zvar attr(r@data, "dim3") <- x@data@dim3 attr(r@data, "level") <- x@data@level } r@file@nodatavalue <- x@file@nodatavalue } else { r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=.getCRS(x)) if ( inMemory(x) ) { if ( dindex != layer ) { warning(paste("layer was changed to", dindex)) } r <- setValues(r, x@data@values[,dindex]) r@data@names <- names(x)[dindex] } } isf <- is.factor(x)[dindex] if (isTRUE(isf)) { r@data@isfactor <- TRUE r@data@attributes <- levels(x)[dindex] } } else { r <- raster(extent(x), nrows=nrow(x), ncols=ncol(x), crs=.getCRS(x)) } if (rotated(x)) { r@rotated <- TRUE r@rotation <- x@rotation } return(r) } ) setMethod('raster', signature(x='Extent'), function(x, nrows=10, ncols=10, crs="", ...) { crs <- .getCRS(crs) raster(ncols=ncols, nrows=nrows, ext=x, crs=crs, ...) } ) setMethod('raster', signature(x='sf'), function(x, origin, ...){ sp <- .sf2sp(x) raster(sp, origin, ...) } ) setMethod('raster', signature(x='Spatial'), function(x, origin, ...){ r <- raster(extent(x), ...) crs(r) <- .getCRS(x) if (!missing(origin)) { origin(r) <- origin r <- extend(r, 1) r <- crop(r, x, snap='out') } r } ) setMethod('raster', signature(x='SpatialGrid'), function(x, layer=1, values=TRUE){ r <- raster(extent(x)) projection(r) <-.getCRS(x) dim(r) <- c(x@grid@cells.dim[2], x@grid@cells.dim[1]) if (layer < 1) { values <- FALSE } if (inherits(x, 'SpatialGridDataFrame') & values) { if (dim(x@data)[2] > 0) { layer = layer[1] if (is.numeric(layer)) { dindex <- max(1, min(dim(x@data)[2], layer)) if (dindex != layer) { warning(paste("layer was changed to: ", dindex)) } layer <- dindex names(r) <- colnames(x@data)[layer] } else if (!(layer %in% names(x))) { stop(layer, ' is not a valid name') } else { names(r) <- layer } if (is.character( x@data[[layer]]) ) { x@data[[layer]] <- as.factor(x@data[[layer]]) } if (is.factor( x@data[[layer]]) ) { r@data@isfactor <- TRUE levs <- levels(x@data[[layer]]) r@data@attributes <- list(data.frame(ID=1:length(levs), levels=levs)) r <- setValues(r, as.integer(x@data[[layer]])) } else { r <- setValues(r, x@data[[layer]]) } } } return(r) } ) setMethod('raster', signature(x='SpatialPixels'), function(x, layer=1, values=TRUE){ if (inherits(x, 'SpatialPixelsDataFrame')) { if (layer < 1) { x <- as(x, 'SpatialGrid') } else { x <- as(x[layer], 'SpatialGridDataFrame') return(raster(x, values=values)) } } else { x <- as(x, 'SpatialGrid') return(raster(x)) } return(x) } ) setMethod('raster', signature(x='im'), function(x, crs) { r <- as(x, 'RasterLayer') if (!missing(crs)) { projection(r) <- .spCRS() } r } ) setMethod('raster', signature(x='kasc'), function(x, crs) { x <- as(x, 'RasterLayer') if (missing(crs)) { e <- x@extent if (e@xmin > -360.1 & e@xmax < 360.1 & e@ymin > -90.1 & e@ymax < 90.1) { crs <- .spCRS("+proj=longlat +datum=WGS84") } else { crs <- as.character(NA) } } projection(x) <- crs return(x) } ) setMethod('raster', signature(x='asc'), function(x, crs) { x <- as(x, 'RasterLayer') if (missing(crs)) { e <- x@extent if (e@xmin > -360.1 & e@xmax < 360.1 & e@ymin > -90.1 & e@ymax < 90.1) { crs <- .spCRS("+proj=longlat +datum=WGS84") } else { crs <- .spCRS(as.character(NA)) } } projection(x) <- crs return(x) } ) setMethod('raster', signature(x='kde'), function(x, crs) { x <- as(x, 'RasterLayer') if (missing(crs)) { e <- x@extent if (e@xmin > -360.1 & e@xmax < 360.1 & e@ymin > -90.1 & e@ymax < 90.1) { crs <- .spCRS("+proj=longlat +datum=WGS84") } else { crs <- .spCRS(as.character(NA)) } } projection(x) <- crs return(x) } ) setMethod('raster', signature(x='grf'), function(x, i=1) { i <- max(1, i[1]) if (i != 1) { nc <- NCOL(x$data) if (i <= nc) { x$data <- x$data[,i] } else { stop('i is higher than the number of simulations in x') } } as(x, 'RasterLayer') } ) setMethod('raster', signature(x='GridTopology'), # contributed by Michael Sumner function(x) { raster(extent(x), nrows=x@cells.dim[2], ncols=x@cells.dim[1]) } ) setMethod('raster', signature(x='SpatRaster'), function(x) { r <- as(x[[1]], "Raster") g <- gc() r } ) raster/R/aggregate_sp.R0000644000176200001440000001572014507510157014540 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 .getVars <- function(v, cn, nc) { vl <- length(v) v <- unique(v) if (is.numeric(v)) { v <- round(v) v <- v[v>0 & v <= nc] if (length(v) < 1) { stop('invalid column numbers') } } else if (is.character(v)) { v <- v[v %in% cn] if (length(v) < 1) { stop('invalid column names') } } v } .doSums <- function(sums, cn, dc, x) { out <- list() for (i in 1:length(sums)) { if (length(sums[[i]]) != 2) { stop('argument "s" most of be list in which each element is a list of two (fun + varnames)') } fun = sums[[i]][[1]] if (!is.function(fun)) { if (is.character(fun)) { if (tolower(fun[1]) == 'first') { fun <- function(x) x[1] } else if (tolower(fun[1]) == 'last') { fun <- function(x) x[length(x)] } } } v <- .getVars(sums[[i]][[2]], cn, ncol(x@data)) ag <- aggregate(x@data[,v,drop=FALSE], by=list(dc$v), FUN=fun) out[[i]] <- ag[,-1,drop=FALSE] } do.call(cbind, out) } setMethod('aggregate', signature(x='SpatialPolygons'), function(x, by=NULL, sums=NULL, dissolve=TRUE, vars=NULL, ...) { if (!is.null(vars)) { if (is.null(by)) { by <- vars } else { stop('do not provide "by" and "vars" arguments') } warning('Use argument "by" instead of deprecated argument "vars"') } if (!is.null(by)) { if (!is.character(by)) { # sp::aggregate is not exported # solution by Matt Strimas-Mackey spAgg <- get('aggregate', envir=as.environment("package:sp")) return( spAgg(x, by, ..., dissolve=dissolve) ) } } prj <- x@proj4string projection(x) <- NA # if (dissolve) { # if (!requireNamespace("rgeos")) { # warning('Cannot dissolve because the rgeos package is not available') # dissolve <- FALSE # } # } # warning("this method will be removed. You can use 'terra::aggregate' instead") if (!.hasSlot(x, 'data') ) { hd <- FALSE if (!is.null(by)) { if (length(by) == length(x@polygons)) { x <- sp::SpatialPolygonsDataFrame(x, data=data.frame(ID=by)) by <- 1 } else if (is.character(by)) { stop('character argument for by not understood. It is not length(x) and x has no attributes') } } } else { hd <- TRUE } if (isTRUE(is.null(by))) { # if (dissolve) { # gval <- rgeos::get_RGEOS_CheckValidity() # if (gval != 2) { # on.exit(rgeos::set_RGEOS_CheckValidity(gval)) # rgeos::set_RGEOS_CheckValidity(2L) # } # if (rgeos::version_GEOS() < "3.3.0") { # x <- rgeos::gUnionCascaded(x) # } else { # x <- rgeos::gUnaryUnion(x) # } # } else { # p <- list() # for (i in 1:length(x)) { # nsubobs <- length(x@polygons[[i]]@Polygons) # p <- c(p, lapply(1:nsubobs, function(j) x@polygons[[i]]@Polygons[[j]])) # } # x <- sp::SpatialPolygons(list(sp::Polygons(p, '1')), proj4string=x@proj4string) # } #if (hd) { # x <- sp::SpatialPolygonsDataFrame(x, data=data.frame(ID=1)) #} x <- vect(x) x <- aggregate(x, dissolve=dissolve) x <- as(x, "Spatial") x <- as(x, "SpatialPolygons") x@proj4string <- prj return(x) } else { dat <- x@data cn <- colnames(dat) v <- .getVars(by, cn) dat <- dat[,v, drop=FALSE] 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] xv <- vect(x) values(xv) <- dc[,2,drop=FALSE] if (nrow(id) == nrow(dat)) { # nothing to aggregate if (hd) { x@data <- dat } else { x <- as(x, 'SpatialPolygons') } return(x) } id <- id[order(id$v), ] dat <- dat[id[,1], ,drop=FALSE] if (!is.null(sums)) { out <- .doSums(sums, cn, dc, x) dat <- cbind(dat, out) } #if (hd) { # x <- as(x, 'SpatialPolygons') #} xv <- aggregate(xv, "v", dissolve=dissolve) xv$agg_n <- NULL x <- as(xv, "Spatial") x <- as(x, "SpatialPolygons") # if (dissolve) { # # if (rgeos::version_GEOS0() < "3.3.0") { # x <- lapply(1:nrow(id), function(y) sp::spChFIDs(rgeos::gUnionCascaded(x[dc[dc$v==y,1],]), as.character(y))) # } else { # x <- lapply(1:nrow(id), # function(y) { # z <- x[dc[dc$v==y, 1], ] # z <- try( rgeos::gUnaryUnion(z) ) # if (! inherits(z, "try-error")) { # sp::spChFIDs(z, as.character(y)) # } # } # ) # } # } else { #x <- lapply(1:nrow(id), function(y) { #spChFIDs(aggregate(x[dc[dc$v==y,1],], dissolve=FALSE), as.character(y))) # x <- lapply(1:nrow(id), function(y) { # d <- data.frame(geom(x[dc[dc$v==y,1],])) # pmx = tapply(d[,"part"], d[,"object"], max) # z <- as.vector(cumsum(pmx) - 1) # d$part <- z[d$object] + d$part # d$object <- y # d <- as(d, "SpatialPolygons") # sp::spChFIDs(d, as.character(y)) # }) # } # x <- do.call(rbind, x) # x@proj4string <- crs rownames(dat) <- NULL x <- sp::SpatialPolygonsDataFrame(x, dat, FALSE) x@proj4string <- prj x } } ) 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, ...) ) } } # warning("this method will be removed. You can use 'terra::aggregate' instead") if (!.hasSlot(x, 'data') ) { hd <- FALSE if (!is.null(by)) { if (length(by) == length(x@lines)) { x <- sp::SpatialLinesDataFrame(x, data=data.frame(ID=by)) by <- 1 } else if (is.character(by)) { stop('character argument for by not understood. It is not length(x) and x has no attributes') } } } else { hd <- TRUE } if (isTRUE(is.null(by))) { x <- vect(x) values(x) <- id x <- aggregate(x) x <- as(x, "Spatial") # p <- list() # for (i in 1:length(x)) { # nsubobs <- length(x@lines[[i]]@Lines) # p <- c(p, lapply(1:nsubobs, function(j) x@lines[[i]]@Lines[[j]])) # } # x <- sp::SpatialLines(list(sp::Lines(p, '1')), proj4string=crs(x)) # return(x) } else { dat <- x@data cn <- colnames(dat) v <- .getVars(by, cn) dat <- dat[,v, drop=FALSE] crs <- x@proj4string dc <- apply(dat, 1, function(y) paste(as.character(y), collapse='_')) dc <- data.frame(oid=1:length(dc), v=as.integer(as.factor(dc))) id <- dc[!duplicated(dc$v), , drop=FALSE] if (nrow(id) == nrow(dat)) { # nothing to aggregate if (hd) { x@data <- dat } else { x <- as(x, 'SpatialLines') } return(x) } id <- id[order(id$v), ] dat <- dat[id[,1], ,drop=FALSE] if (!is.null(sums)) { out <- .doSums(sums, cn, dc, x) dat <- cbind(dat, out) } if (hd) { x <- as(x, 'SpatialLines') } x <- vect(x) values(x) <- id x <- aggregate(x) x <- as(x, "Spatial") x <- as(x, "SpatialLines") # x <- lapply(1:nrow(id), function(y) sp::spChFIDs(aggregate(x[dc[dc$v==y,1],]), as.character(y))) # x <- do.call(rbind, x) crs(x) <- crs rownames(dat) <- NULL sp::SpatialLinesDataFrame(x, dat, FALSE) } } ) raster/R/makeRasterList.R0000644000176200001440000000306714507510157015043 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2008 # Version 0.9 # Licence GPL v3 .addToList <- function(x, r, compare, giveError, unstack) { if (inherits(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 (inherits(arg[[i]], 'list')) { for (j in seq(along.with=arg[[i]])) { x <- .addToList(x, arg[[i]][[j]], compare=compare, giveError=giveError, unstack=unstack) } } else { x <- .addToList(x, arg[[i]], compare=compare, giveError=giveError, unstack=unstack) } } fdim <- sapply(x, fromDisk) & sapply(x, inMemory) if (sum(fdim) > 0) { x[fdim] <- sapply(x[fdim], clearValues) } hv <- sapply(x, hasValues) if (sum(hv) < length(x)) { if (sum(hv) == 0) { x <- x[1] } else { x <- x[hv] warning('layer(s) with no data ignored') } } return(x) } setMethod('as.list', signature(x='Raster'), function(x, ...) { .makeRasterList(x, ...) } ) raster/R/values.R0000644000176200001440000000115314507510157013402 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('values', signature(x='Raster'), function(x, ...) { getValues(x, ...) }) setMethod('values<-', signature(x='RasterLayer'), function(x, value) { setValues(x, value) } ) setMethod('values<-', signature(x='RasterBrick'), function(x, value) { setValues(x, values=value, layer=-1) } ) setMethod('values<-', signature(x='RasterStack'), function(x, value) { setValues(x, values=value, layer=-1) } ) setMethod('values<-', signature(x='RasterLayerSparse'), function(x, value) { setValues(x, value, index=NULL) } ) raster/R/as.data.frame.R0000644000176200001440000000512214507510157014507 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2011 # Version 1.0 # Licence GPL v3 .insertColsInDF <- function(x, y, col, combinenames=TRUE) { cnames <- NULL if (combinenames) { if (ncol(y) > 1) { cnames <- paste(colnames(x)[col], '_', colnames(y), sep='') } } if (ncol(y) == 1) { x[, col] <- y return(x) } else if (col==1) { z <- cbind(y, x[, -1, drop=FALSE]) } else if (col==ncol(x)) { z <- cbind(x[, -ncol(x), drop=FALSE], y) } else { z <- cbind(x[,1:(col-1), drop=FALSE], y, x[,(col+1):ncol(x), drop=FALSE]) } if (!is.null(cnames)) { colnames(z)[col:(col+ncol(y)-1)] <- cnames } z } setMethod('as.data.frame', signature(x='Raster'), function(x, row.names = NULL, optional = FALSE, xy=FALSE, na.rm=FALSE, long=FALSE, ...) { if (!canProcessInMemory(x, 4) & na.rm) { r <- raster(x) ncx <- ncol(r) tr <- blockSize(x) pb <- pbCreate(tr$n, label='as.data.frame', ...) x <- readStart(x) v <- NULL for (i in 1:tr$n) { start <- (tr$row[i]-1) * ncx + 1 end <- start + tr$nrows[i] * ncx - 1 vv <- cbind(start:end, getValues(x, row=tr$row[i], nrows=tr$nrows[i])) if (xy) { vv <- cbind(vv, data.frame(xyFromCell(r, start:end))) } vv <- stats::na.omit(vv) v <- rbind(v, vv) pbStep(pb, i) } x <- readStop(x) } else { v <- getValues(x) if (xy) { XY <- data.frame(xyFromCell(x, 1:ncell(x))) v <- cbind(XY, v) } if (na.rm) { v <- stats::na.omit(cbind(1:ncell(x), v)) } } v <- as.data.frame(v, row.names=row.names, optional=optional, ...) if (na.rm) { rownames(v) <- as.character(v[,1]) v <- v[,-1,drop=FALSE] } if (nlayers(x) == 1) { colnames(v)[ncol(v)] <- names(x) # for nlayers = 1 } i <- is.factor(x) if (any(is.factor(x))) { if (ncol(v) == 1) { v <- data.frame( factorValues(x, v[,1], 1)) # j <- which(sapply(v, is.character)) # if (length(j) > 0) { # for (jj in j) { # v[, jj] <- as.factor(v[,jj]) # } # } } else { nl <- nlayers(x) if (ncol(v) > nl) { rnge1 <- 1:(ncol(v)-nl) rnge2 <- (ncol(v)-nl+1):ncol(v) v <- cbind(v[, rnge1], .insertFacts(x, v[, rnge2, drop=FALSE], 1:nl)) } else { v <- .insertFacts(x, v, 1:nl) } } } if (long) { nc <- (ncol(v) - nlayers(x) + 1):ncol(v) times <- getZ(x) timevar <- 'Z' if (is.null(times)) { times <- names(x) timevar <- 'layer' } v <- stats::reshape(v, direction='long', varying=nc, v.names='value', timevar=timevar, times=times) v[ncol(v)] = NULL # id column rownames(v) <- NULL #v$layer <- names(x)[v$layer] } v } ) raster/R/colortable.R0000644000176200001440000000036514507510157014235 0ustar liggesusers colortable <- function(x) { if (.hasSlot(x, 'legend')) { x@legend@colortable } else { logical(0) } } 'colortable<-' <- function(x, value) { # for now assuming values are between 0 and 255!! x@legend@colortable <- value return(x) } raster/R/cellValues.R0000644000176200001440000000424114507510157014203 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 .cellValues <- function(x, cells, layer, nl, df=FALSE, factors=FALSE) { cells[cells < 1 | cells > ncell(x)] <- NA if (inherits(x, 'RasterLayer')) { if (inMemory(x)) { if (length(stats::na.omit(cells)) == 0) { if (length(cells) == 0) { return(NULL) } return(cells) } # as.numeric to avoid logical values for backwards compatibility result <- as.numeric(x@data@values[cells] ) } else { result <- .readCells(x, cells, 1) } } else { nlyrs <- nlayers(x) if (missing(layer)) { layer <- 1 } layer <- min( max( round(layer), 1), nlyrs) if (missing(nl)) { nl <- nlyrs } nl <- min( max( round(nl), 1), nlyrs-layer+1 ) lyrs <- layer:(layer+nl-1) if (inherits(x, 'RasterStack')) { result <- matrix(ncol=nl, nrow=length(cells)) colnames(result) <- names(x)[lyrs] if (length(stats::na.omit(cells)) == 0) { return(result) } if (inMemory(x)) { for (i in 1:length(lyrs)) { result[,i] <- as.numeric(x@layers[[lyrs[i]]]@data@values[cells] ) } } else { for (i in 1:length(lyrs)) { result[,i] <- .readCells( x@layers[[lyrs[i]]], cells, 1) } } } else if (inherits(x, 'RasterBrick')) { if (inMemory(x)) { result <- x@data@values[cells, lyrs, drop=FALSE] } else if (x@file@driver == 'netcdf') { result <- .readBrickCellsNetCDF(x, cells, layer, nl) } else { result <- .readCells(x, cells, lyrs) } if (is.null(dim(result))) { result <- matrix(result, ncol=length(lyrs)) } colnames(result) <- names(x)[lyrs] } } if (df) { if (!is.matrix(result)) { result <- matrix(result) colnames(result) <- names(x) } result <- data.frame(ID=1:NROW(result), result) facts <- is.factor(x)[lyrs] if (any(facts) & factors) { if (ncol(result) == 2) { # possibly multiple columns added result <- cbind(result[,1,drop=FALSE], factorValues(x, result[,2], layer)) } else { # single columns only i <- which(facts) for (j in i) { result <- .insertColsInDF(result, factorValues(x, result[, j+1], j), j+1) } } } } result } raster/R/writeAllGDAL.R0000644000176200001440000000177214507510157014325 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .writeGDALall <- function(x, filename, options=NULL, setStatistics=TRUE, ...) { stat <- cbind(NA, NA) # if (nlayers(x) > 1) { # y <- brick(x, values=FALSE) # levels(y) <- levels(x) # x <- getValues(x) ## if (setStatistics) { ## stat <- t(apply(x, 2, function(z, ...) cbind(mean(z, na.rm=TRUE), stats::sd(z, na.rm=TRUE)))) ## } # } else { # y <- raster(x) # levels(y) <- levels(x) # y@legend@colortable <- colortable(x) # x <- getValues(x) ## if (setStatistics) { ## stat <- cbind(mean(x, na.rm=TRUE), stats::sd(x, na.rm=TRUE)) ## } # } ## filetype <- .filetype(format=format, filename=filename) ## y <- .startGDALwriting(y, filename, gdal=options, overwrite=overwrite, format=filetype, ...) # y <- .startGDALwriting(y, filename, gdal=options, ...) # x <- writeValues(y, x, start=1) y <- .startGDALwriting(x, filename, gdal=options, ...) x <- writeValues(y, getValues(x), start=1) .stopGDALwriting(x, stat) } raster/R/modalRaster.R0000644000176200001440000000212114507510157014354 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 setMethod("modal", signature(x='Raster'), function(x, ..., ties='random', na.rm=FALSE, freq=FALSE){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- .addArgs(...) } else { add <- NULL } nl <- nlayers(x) if (nl < 2) { warning('there is not much point in computing a modal value for a single layer') return(x[[1]]) } else if (nl == 2) { warning('running modal with only two layers!') } out <- raster(x) if (canProcessInMemory(x)) { x <- cbind(getValues(x), add) x <- setValues(out, apply(x, 1, modal, ties=ties, na.rm=na.rm, freq=freq)) return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n, label='modal') out <- writeStart(out, filename="") for (i in 1:tr$n) { v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add) v <- apply(v, 1, modal, ties=ties, na.rm=na.rm, freq=freq) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) writeStop(out) } ) raster/R/symdif.R0000644000176200001440000000145414507510157013402 0ustar liggesusers# Author: Robert J. Hijmans # Date: December 2011 # Version 1.0 # Licence GPL v3 setMethod('symdif', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ...) { # warning("this method will be removed. You can use 'terra::symdif' instead") z <- symdif(vect(x), vect(y)) return(as(z, "Spatial")) # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # haswarned <- FALSE # yy <- list(y, ...) # for (y in yy) { # if (! identical( .proj4string(x), .proj4string(y)) ) { # if (!haswarned) { # warning('non identical crs') # haswarned <- TRUE # } # y@proj4string <- x@proj4string # } # if (rgeos::gIntersects(x, y)) { # part1 <- erase(x, y) # part2 <- erase(y, x) # x <- bind(part1, part2) # } # } # x } ) raster/R/pairs.R0000644000176200001440000000205414507510157013222 0ustar liggesusers setMethod('pairs', signature(x='RasterStackBrick'), function(x, hist=TRUE, cor=TRUE, use="pairwise.complete.obs", maxpixels=100000, ...) { panelhist <- function(x,...) { usr <- graphics::par("usr"); on.exit(graphics::par(usr)) graphics::par(usr = c(usr[1:2], 0, 1.5) ) h <- hist(x, plot = FALSE) breaks <- h$breaks nB <- length(breaks) y <- h$counts y <- y/max(y) graphics::rect(breaks[-nB], 0, breaks[-1], y, col="green") } panelcor <- function(x, y,...) { usr <- graphics::par("usr") on.exit(graphics::par(usr)) graphics::par(usr = c(0, 1, 0, 1)) r <- abs(stats::cor(x, y, use=use)) txt <- format(c(r, 0.123456789), digits=2)[1] text(0.5, 0.5, txt, cex = max(0.5, r * 2)) } if (hist) {dp <- panelhist} else {dp <- NULL} if (cor) {up <- panelcor} else {up <- NULL} d <- sampleRegular(x, maxpixels) dots <- list(...) cex <- dots$cex main <- dots$main if (is.null(cex)) cex <- 0.5 if (is.null(main)) main <- '' pairs(d, main=main, cex=cex, upper.panel=up, diag.panel=dp) } ) raster/R/mean.R0000644000176200001440000001304514507510157013026 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 .deepCopyRasterLayer <- function(x, filename="", ...) { out <- raster(x) if (canProcessInMemory(x)) { return( setValues(out, getValues(x)) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='copy') out <- writeStart(out, filename=filename) x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } setMethod("mean", signature(x='Raster'), function(x, ..., trim=NA, na.rm=FALSE){ if (!is.na(trim)) { warning("argument 'trim' is ignored") } dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- unlist(.addArgs(...)) } else { add <- NULL } out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (nlayers(x) == 1) { return(.deepCopyRasterLayer(x)) } if (canProcessInMemory(x)) { x <- getValues(x) x <- setValues(out, .rowMeans(x, nc, d[3], na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='mean') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMeans(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { d3 <- d[3] + length(add) if (canProcessInMemory(x)) { if (length(add) == 1) { x <- cbind(getValues(x), add) } else { x <- getValues(x) x <- t(apply(x, 1, function(i) c(i, add))) } x <- setValues(out, .rowMeans(x, nc, d3, na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='mean') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- t(apply(v, 1, function(i) c(i, add))) v <- .rowMeans(v, tr$nrows[i]*d[2], d3, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } ) .sum <- function(x, add=NULL, na.rm=FALSE){ out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowSums(getValues(x), nc, d[3], na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='sum') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowSums(v, tr$nrows[i]*d[2], d[3], na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return ( writeStop(out) ) } else { add <- sum(add, na.rm=na.rm) d3 <- d[3] + 1 if (canProcessInMemory(x)) { return( setValues(out, .rowSums(cbind(getValues(x), add), nc, d3, na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='sum') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowSums(cbind(v, add), tr$nrows[i]*d[2], d3, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) writeStop(out) } } .min <- function(x, add=NULL, na.rm=FALSE) { out <- raster(x) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowMin(getValues(x), na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='min') out <- writeStart(out, filename="") #x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMin(v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) #x <- readStop(x) return ( writeStop(out) ) } else { add <- min(add, na.rm=na.rm) if (canProcessInMemory(x)) { x <- setValues(out, .rowMin(cbind(getValues(x), add), na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='min') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMin(cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return ( writeStop(out) ) } } .max <- function(x, add=NULL, na.rm=FALSE){ out <- raster(x) if (is.null(add)) { if (canProcessInMemory(x)) { return( setValues(out, .rowMax(getValues(x), na.rm=na.rm)) ) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='max') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMax( v, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { add <- max(add, na.rm=na.rm) if (canProcessInMemory(x)) { x <- setValues(out, .rowMax(cbind(getValues(x), add), na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='max') out <- writeStart(out, filename="") x <- readStart(x) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- .rowMax( cbind(v, add), na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } raster/R/cellsFromExtent.R0000644000176200001440000000247614507510157015232 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 cellsFromExtent <- function(object, extent, expand=FALSE) { object <- raster(object) extent <- alignExtent(extent(extent), object) innerBox <- intersect(extent(object), extent) if (is.null(innerBox)) { return(NULL) } srow <- rowFromY(object, innerBox@ymax - 0.5 * yres(object)) erow <- rowFromY(object, innerBox@ymin + 0.5 * yres(object)) scol <- colFromX(object, innerBox@xmin + 0.5 * xres(object)) ecol <- colFromX(object, innerBox@xmax - 0.5 * xres(object)) if (expand) { srow <- srow - round((extent@ymax - innerBox@ymax) / yres(object)) erow <- erow + round((innerBox@ymin - extent@ymin) / yres(object)) scol <- scol - round((innerBox@xmin - extent@xmin) / xres(object)) ecol <- ecol + round((extent@xmax - innerBox@xmax) / xres(object)) } return(cellFromRowColCombine(object, srow:erow, scol:ecol)) } # By Mike Sumner extentFromCells <- function (object, cells) { cells <- stats::na.omit(unique(round(cells))) cells <- cells[cells > 0 & cells <= ncell(object)] if (length(cells) < 1) { stop('no valid cells') } r <- res(object) dx <- r[1] * c(-0.5, 0.5) dy <- r[2] * c(-0.5, 0.5) extent(range(xFromCell(object, cells)) + dx, range(yFromCell(object, cells)) + dy) } raster/R/dropLayer.R0000644000176200001440000000200114507510157014035 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("dropLayer")) { setGeneric("dropLayer", function(x, i, ...) standardGeneric("dropLayer")) } ...nameToIndex <- function(name, allnames) { # this is the same as match, I think k = NULL for (i in 1:length(name)) { k = c(k, which(allnames == name[i])[1]) } return(k) } setMethod('dropLayer', signature(x='RasterStack'), function(x, i, ...) { if (is.character(i)) { i = match(i, names(x)) } i <- sort(unique(round(i))) i <- i[i > 0 & i <= nlayers(x)] if (length(i) > 0) { x@layers <- x@layers[-i] } return(x) } ) setMethod('dropLayer', signature(x='RasterBrick'), function(x, i, ...) { if (is.character(i)) { i <- match(i, names(x)) } i <- sort(unique(round(i))) nl <- nlayers(x) i <- i[i > 0 & i <= nl] if (length(i) < 1) { return(x) } else { sel <- which(! 1:nl %in% i ) if (length(sel) == 0) { return(brick(x, values=FALSE)) } else { return(subset(x, sel, ...)) } } } ) raster/R/netCDFread.R0000644000176200001440000001116514507510157014046 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .readRowsNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1)) { if ( x@file@toptobottom ) { row <- x@nrows - row - nrows + 2 } is.open <- x@file@open if (is.open) { nc <- x@file@con } else { nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) } zvar <- x@data@zvar if (nc$var[[zvar]]$ndims == 1) { # for GMT ncx <- ncol(x) start <- (row-1) * ncx + 1 count <- nrows * ncx d <- ncdf4::ncvar_get( nc, varid=zvar, start=start, count=count ) if (col > 1 | ncols < ncx) { d <- matrix(d, ncol=ncx, byrow=TRUE) d <- d[, col:(col+ncols-1)] d <- as.vector(t(d)) } } else if (nc$var[[zvar]]$ndims == 2) { start <- c(col, row) count <- c(ncols, nrows) d <- ncdf4::ncvar_get( nc, varid=zvar, start=start, count=count ) } else if (nc$var[[zvar]]$ndims == 3) { start <- c(col, row, x@data@band) count <- c(ncols, nrows, 1) d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { if (x@data@dim3 == 4) { start <- c(col, row, x@data@level, x@data@band) count <- c(ncols, nrows, 1, 1) d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } else { start <- c(col, row, x@data@band, x@data@level) count <- c(ncols, nrows, 1, 1) d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA } #d <- x@data@add_offset + d * x@data@scale_factor if (length(dim(d)) > 1) { if ( x@file@toptobottom ) { d <- d[, ncol(d):1] } } d <- as.vector(d) d[d == x@file@nodatavalue] <- NA return(d) } .readRowsBrickNetCDF <- function(x, row, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs) { # RH removed because of bug with RasterLayer specific slots # if (nlayers(x) == 1) { # return(.readRowsNetCDF(x=x, row=row, nrows=nrows, col=col, ncols=ncols) ) # } is.open <- x@file@open if ( x@file@toptobottom ) { row <- x@nrows - row - nrows + 2 } navalue <- x@file@nodatavalue #n the true number of layers #nn the span of layers between the first and the last #alyrs, the layers requested, scaled to start at one. n <- nn <- nlayers(x) if (missing(lyrs)) { layer <- 1 lyrs <- 1:n } else { lyrs <- lyrs[lyrs %in% 1:n] if (length(lyrs) == 0) { stop("no valid layers") } layer <- lyrs[1] n <- length(lyrs) nn <- lyrs[length(lyrs)] - lyrs[1] + 1 } alyrs <- lyrs - lyrs[1] + 1 lns <- names(x)[lyrs] nrows <- min(round(nrows), x@nrows-row+1) ncols <- min((x@ncols-col+1), ncols) stopifnot(nrows > 0) stopifnot(ncols > 0) if (is.open) { nc <- x@file@con } else { nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) } zvar <- x@data@zvar if (nc$var[[zvar]]$ndims == 4) { if (x@data@dim3 == 4) { start <- c(col, row, x@data@level, layer) count <- c(ncols, nrows, 1, nn) } else { start <- c(col, row, layer, x@data@level) count <- c(ncols, nrows, nn, 1) } } else if (nc$var[[zvar]]$ndims == 2) { start <- c(col, row) count <- c(ncols, nrows) } else { start <- c(col, row, layer) count <- c(ncols, nrows, nn) } d <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) #if (!is.na(x@file@nodatavalue)) { d[d==x@file@nodatavalue] <- NA } #d <- x@data@add_offset + d * x@data@scale_factor if (nlayers(x) > 1) { dims = dim(d) if (length(dims) == 3) { if ( x@file@toptobottom ) { v <- matrix(nrow=nrows*ncols, ncol=n) for (i in 1:length(alyrs)) { x <- d[,,alyrs[i]] v[,i] <- as.vector( x[, ncol(x):1] ) } } else { dim(d) = c(dims[1] * dims[2], dims[3]) d <- d[, alyrs, drop=FALSE] d[d == x@file@nodatavalue] <- NA return(d) } } else if (length(dims) == 2) { if (nrows==1) { d <- d[ , alyrs,drop=FALSE] d[d == navalue] <- NA return(d) } else if (n==1) { v <- matrix(nrow=nrows*ncols, ncol=n) if ( x@file@toptobottom ) { v[] <- as.vector(d[,ncol(d):1]) } else { v[] <- as.vector(d) } } else if (ncols==1) { if ( x@file@toptobottom ) { d <- d[nrow(d):1, ] } d <- d[ , alyrs, drop=FALSE] d[d == navalue] <- NA return(d) } } else { # length(dims) == 1 v <- matrix(nrow=nrows*ncols, ncol=n) if ( x@file@toptobottom & nrows > 1) { d <- rev(d) } v[] <- d # d[, alyrs, drop=FALSE] } } else { if ( x@file@toptobottom ) { if (is.matrix(d)) { d <- d[, ncol(d):1] } } v <- matrix(as.vector(d), ncol=1) #v <- v[,lyrs,drop=FALSE] } v[v == navalue] <- NA colnames(v) <- lns return(v) } raster/R/drawExtent.R0000644000176200001440000000143014507510157014226 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : January 2009, December 2011 # Version 1.0 # Licence GPL v3 drawExtent <- function(show=TRUE, col="red") { if (show) { loc1 <- graphics::locator(n=1, type="p", pch='+', col=col) } else { loc1 <- graphics::locator(n=1) } loc2 <- graphics::locator(n=1) loc <- rbind(unlist(loc1), unlist(loc2)) e <- extent(min(loc[,'x']), max(loc[,'x']), min(loc[,'y']), max(loc[,'y'])) if (e@xmin == e@xmax) { e@xmin <- e@xmin - 0.0000001 e@xmax <- e@xmax + 0.0000001 } if (e@ymin == e@ymax) { e@ymin <- e@ymin - 0.0000001 e@ymax <- e@ymax + 0.0000001 } if (show) { p <- rbind(c(e@xmin, e@ymin), c(e@xmin, e@ymax), c(e@xmax, e@ymax), c(e@xmax, e@ymin), c(e@xmin, e@ymin) ) lines(p, col=col) } return(e) } raster/R/as.logical.R0000644000176200001440000000414114507510157014117 0ustar liggesusers# Author: Robert J. Hijmans # Date: November 2009, Jan 2016 # Version 1.0 # Licence GPL v3 setMethod('as.integer', signature(x='Raster'), function(x, filename='', ...) { if (nlayers(x) > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } datatype <- list(...)$datatype if (canProcessInMemory(x, 2)){ x <- getValues(x) x[] <- as.integer(x) out <- setValues(out, x) if (filename != '') { if (is.null(datatype)) { out <- writeRaster(out, filename, datatype='INT4S', ...) } else { out <- writeRaster(out, filename, ...) } } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (is.null(datatype)) { out <- writeStart(out, filename=filename, datatype='INT4S', ...) } else { out <- writeStart(out, filename=filename, ...) } tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { v <- as.integer( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('as.logical', signature(x='Raster'), function(x, filename='', ...) { if (nlayers(x) > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } datatype <- list(...)$datatype if (canProcessInMemory(x, 2)){ x <- getValues(x) x[] <- as.logical(x) out <- setValues(out, x) if (filename != '') { if (is.null(datatype)) { out <- writeRaster(out, filename, datatype='INT2S', ...) } else { out <- writeRaster(out, filename, ...) } } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (is.null(datatype)) { out <- writeStart(out, filename=filename, datatype='INT2S', ...) } else { out <- writeStart(out, filename=filename, ...) } tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { v <- as.logical ( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i] ) ) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) return(out) } } ) raster/R/cor.R0000644000176200001440000000133214507510157012665 0ustar liggesusers .cor <- function(x, n=Inf, ...) { nl <- nlayers(x) if (nl < 2) return(1) if (n < ncell(x)) { x <- sampleRegular(x, size=n, asRaster=TRUE) } if (canProcessInMemory(x, nlayers(x)*4)) { s <- stats::na.omit(getValues(x)) s <- stats::cor(s) } else { msk <- sum(x, na.rm=FALSE) x <- mask(x, msk) mx <- cellStats(x, 'mean') sx <- cellStats(x, 'sd') nc <- ncell(x) s <- matrix(NA, nrow=n, ncol=n) for (i in 1:(nl-1)) { for (j in (i+1):nl) { s[j,i] <- s[i,j] <- cellStats(((x[[i]] - mx[i]) * (x[[j]] - mx[j])) / (sx[i] * sx[j]), sum)/ (nc-1) } } diag(s) <- 1 } if (nrow(s) == 2) { s[2,1] } else { colnames(s) <- rownames(s) <- names(x) s } } raster/R/layerStats.R0000644000176200001440000000513314507510157014240 0ustar liggesusers# Jonathan Greenberg and Robert Hijmans # Date : April 2012 # Version 1.0 # Licence GPL v3 # Computation of the weighted covariance and (optionally) weighted means of bands in an Raster. # based on code by Mort Canty layerStats <- function(x, stat, w, asSample=TRUE, na.rm=FALSE, ...) { stat <- tolower(stat) stopifnot(stat %in% c('cov', 'weighted.cov', 'pearson')) stopifnot(is.logical(asSample) & !is.na(asSample)) nl <- nlayers(x) n <- ncell(x) mat <- matrix(NA, nrow=nl, ncol=nl) colnames(mat) <- rownames(mat) <- names(x) pb <- pbCreate(nl^2, label='layerStats', ...) if (stat == 'weighted.cov') { if (missing(w)) { stop('to compute weighted covariance a weights layer should be provided') } stopifnot( nlayers(w) == 1 ) if (na.rm) { # a cell is set to NA if it is NA in any layer. That is not ideal, but easier and quicker nas <- calc(x, function(i) sum(i)) * w x <- mask(x, nas) w <- mask(w, nas) } sumw <- cellStats(w, stat='sum', na.rm=na.rm) means <- cellStats(x * w, stat='sum', na.rm=na.rm) / sumw sumw <- sumw - asSample x <- (x - means) * sqrt(w) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x,layer=j) v <- cellStats(r, stat='sum', na.rm=na.rm) / sumw mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) cov.w <- list(mat, means) names(cov.w) <- c("weigthed covariance", "weighted mean") return(cov.w) } else if (stat == 'cov') { means <- cellStats(x, stat='mean', na.rm=na.rm) x <- (x - means) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x, layer=j) if (na.rm) { v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - cellStats(r, stat='countNA') - asSample) } else { v <- cellStats(r, stat='sum', na.rm=na.rm) / (n - asSample) } mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) covar <- list(mat, means) names(covar) <- c("covariance", "mean") return(covar) } else if (stat == 'pearson') { means <- cellStats(x, stat='mean', na.rm=na.rm) sds <- cellStats(x, stat='sd', na.rm=na.rm) x <- (x - means) for(i in 1:nl) { for(j in i:nl) { r <- raster(x, layer=i) * raster(x, layer=j) if (na.rm) { v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - cellStats(r, stat='countNA') - asSample) * sds[i] * sds[j]) } else { v <- cellStats(r, stat='sum', na.rm=na.rm) / ((n - asSample) * sds[i] * sds[j]) } mat[j,i] <- mat[i,j] <- v pbStep(pb) } } pbClose(pb) covar <- list(mat, means) names(covar) <- c("pearson correlation coefficient", "mean") return(covar) } } raster/R/fasterize.R0000644000176200001440000000474114507510157014105 0ustar liggesusers .makeSpPolygons <- function(polys, attr=NULL, crs="", ...) { x <- data.frame(geom(polys)) x$cump <- NULL ppp <- SpPolygons$new() x <- split(x, x$object) for (i in 1:length(x)) { y <- x[[i]] pp <- SpPoly$new() if ( any(y$hole > 0) ) { ym <- y[y$hole < 1, ] z <- split(ym, ym$part) for (j in 1:length(z)) { p <- SpPolyPart$new() p$set(z[[j]]$x, z[[j]]$y) z[[j]] <- p } yh <- y[y$hole > 0, ] zz <- split(yh, yh$part) for (j in 1:length(zz)) { id <- zz[[j]]$hole[1] z[[id]]$setHole(zz[[j]]$x, zz[[j]]$y) } for (j in 1:length(z)) { pp$addPart(z[[j]]) } } else { z <- split(y, y$part) for (j in 1:length(z)) { p <- SpPolyPart$new() p$set(z[[j]]$x, z[[j]]$y) pp$addPart(p) } } ppp$addPoly(pp) } if (!is.na(crs)) { ppp$crs <- crs } ppp } .fasterize <- function(p, r, values, background = NA, filename="", ...) { if (!inherits(p, "Rcpp_SpPolygons")) p <- .makeSpPolygons(p) if (missing(values)) values <- 1:p$size() out <- raster(r) if (canProcessInMemory(out, 4)) { out <- setValues(out, p$rasterize(nrow(r), ncol(r), as.vector(extent(r)), values, background)) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } return(out) } else { temp <- out tr <- blockSize(out) pb <- pbCreate(tr$n, label='rasterize', ...) out <- writeStart(out, filename=filename, ... ) for (i in 1:tr$n) { x <- crop(temp, extent(temp, r1=tr$row[i], r2=tr$row[i]+tr$nrows[i]-1, c1=1, c2=ncol(out))) #x <- setValues(x, p$rasterize(nrow(x), ncol(x), as.vector(extent(x)), values, background)) #out <- writeValues(out, values(x), tr$row[i]) x <- p$rasterize(nrow(x), ncol(x), as.vector(extent(x)), values, background) out <- writeValues(out, x, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) pbClose(pb) g <- gc() return(out) } } .extractPolygons <- function(x, p) { addres <- max(res(x)) * 2 rr <- raster(x) er <- as.vector(extent(x)) sp <- .makeSpPolygons(p) npol <- sp$size() res <- list(rep(NA, sp$size())) for (i in 1:npol) { pp <- sp$subset(i-1) ep <- pp$extent$vector if (!(ep[1] >= er[2] || ep[2] <= er[1] || ep[3] >= er[4] || ep[4] <= er[3])) { rc <- crop(rr, extent(ep)+addres) rc <- .fasterize(pp, rc, values=1, background = NA) xy <- rasterToPoints(rc)[,-3,drop=FALSE] if (length(xy) > 0) { # catch holes or very small polygons res[[i]] <- .xyValues(x, xy) } } } res } raster/R/update.R0000644000176200001440000003770114507510157013375 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2010 # Version 0.9 # Licence GPL v3 setMethod('update', signature(object='RasterLayer'), function(object, v, cell, ...) { if (!fromDisk(object)) { stop('object is not associated with a file on disk.') } band <- bandnr(object) cell <- stats::na.omit(round(cell)) driver <- object@file@driver if (.isNativeDriver(driver)) { stopifnot(object@file@toptobottom) if (nbands(object) > 1) { b <- brick(filename(object), native=TRUE) b <- update(b, v, cell, band=bandnr(object)) r <- raster(filename(object), band=bandnr(object)) return(r) } } datatype <- object@file@datanotation dtype <- substr(datatype, 1, 3) v <- .checkData(object, v, cell, dtype) setminmax <- FALSE if (object@data@haveminmax) { lst <- .updateMinMax(object, v, cell, 1) # band=1 because there is only one set of min/max values object <- lst[[1]] setminmax <- lst[[2]] } if (driver == 'gdal') { return( .updateGDAL(object, v, cell, band, setminmax) ) } else if (driver == 'netcdf') { return( .updateNCDF(object, v, cell, band ) ) } else if (.isNativeDriver(driver)) { return( .updateNativeSingle(object, v, cell, band, driver, datatype ) ) } stop('not implemented for: ', driver, ' files') } ) setMethod('update', signature(object='RasterBrick'), function(object, v, cell, band, ...) { if (!fromDisk(object)) { stop('object is not associated with a file on disk.') } stopifnot(band > 0 & band <= nbands(object)) cell <- stats::na.omit(round(cell)) datatype <- object@file@datanotation dtype <- substr(datatype, 1, 3) v <- .checkData(object, v, cell, dtype) setminmax <- FALSE if (object@data@haveminmax) { setminmax <- FALSE if (object@data@haveminmax) { object <- .updateMinMax(object, v, cell, band) setminmax <- object[[2]] object <- object[[1]] } } driver <- object@file@driver if (driver == 'gdal') { return( .updateGDAL(object, v, cell, band, setminmax) ) } else if (driver == 'netcdf') { return( .updateNCDF(object, v, cell, band ) ) } else if (.isNativeDriver(driver)) { stopifnot(object@file@toptobottom) return ( .updateNativeMultiple(object, v, cell, band, driver, datatype ) ) } stop('not implemented for: ', driver, ' files') } ) .updateNativeSingle <- function(object, v, cell, band, driver, datatype) { minv <- object@data@min maxv <- object@data@max object <- writeStart(object, filename(object), update=TRUE, format=driver, datatype=datatype, overwrite=TRUE) dtype <- substr(datatype, 1, 3) if (dtype == "INT" | dtype == "LOG") { v[is.na(v)] <- as.integer(object@file@nodatavalue) } else { v[] <- as.numeric(v) } if (is.matrix(v)) { for (r in 1:nrow(v)) { pos <- (cell-1) * object@file@dsize seek(object@file@con, pos, rw='w') writeBin(v[r,], object@file@con, size=object@file@dsize ) cell <- cell + object@ncols } } else { if (length(cell) == 1) { pos <- (cell-1) * object@file@dsize seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } else { for (i in 1:length(cell)) { pos <- (cell[i]-1) * object@file@dsize seek(object@file@con, pos, rw='w') writeBin(v[i], object@file@con, size=object@file@dsize ) } } } object@data@min <- minv object@data@max <- maxv object@data@haveminmax <- TRUE object <- writeStop(object) if (object@data@min == Inf) { object@data@haveminmax <- FALSE if (ncell(object) <= 1000000) { object <- setMinMax(object) hdr(object, driver) } } return( object ) } .updateNativeMultiple <- function(object, v, cell, band, driver, datatype ) { # need to support this too: stopifnot(object@file@toptobottom) bandorder <- object@file@bandorder getoff <- function(object, cell) { if (bandorder == 'BIL') { rc <- rowColFromCell(object, cell) - 1 off <- ((nbands(object) * (rc[1]) + (band-1)) * object@ncols + rc[2] ) * object@file@dsize } else if (bandorder == 'BIP') { off <- (nbands(object) * (cell-1) + band-1) * object@file@dsize } else if (bandorder == 'BSQ') { off <- (ncell(object) * (band-1) + (cell-1)) * object@file@dsize } else { stop("unknown band order") } return(off) } minv <- object@data@min maxv <- object@data@max object <- writeStart(object, filename(object), update=TRUE, format=driver, datatype=datatype, overwrite=TRUE, bandorder=bandorder) dtype <- substr(datatype, 1, 3) if (dtype == "INT" | dtype == "LOG") { v[is.na(v)] <- as.integer(object@file@nodatavalue) } else { v[] <- as.numeric(v) } if (is.matrix(v)) { if (bandorder == 'BIP') { for (r in 1:nrow(v)) { for (c in 1:ncol(v)) { pos <- getoff(object, cell+c-1) seek(object@file@con, pos, rw='w') writeBin(v[r,c], object@file@con, size=object@file@dsize ) } cell <- cell + object@ncols } } else { for (r in 1:nrow(v)) { pos <- getoff(object, cell) seek(object@file@con, pos, rw='w') writeBin(v[r,], object@file@con, size=object@file@dsize ) cell <- cell + object@ncols } } } else { if (length(cell) == 1) { if (bandorder == 'BSQ') { pos <- getoff(object, cell) seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } else if (bandorder == 'BIP') { for (i in 1:length(v)) { pos <- getoff(object, cell+i-1) seek(object@file@con, pos, rw='w') writeBin(v[i], object@file@con, size=object@file@dsize ) } } else { cell2 <- cell+length(v)-1 rows <- rowFromCell(object, cell) : rowFromCell(object, cell2) cols <- colFromCell(object, cell) : colFromCell(object, cell2) rows <- unique(rows) cols <- unique(cols) nr <- length(rows) if (nr == 1) { pos <- getoff(object, cell) seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } else { pos <- getoff(object, cellFromRowCol(object, rows[1], cols[1])) seek(object@file@con, pos, rw='w') nc <- object@ncols - cols[1] writeBin(v[1:nc], object@file@con, size=object@file@dsize ) v <- v[-(1:nc)] if (nr > 2) { nc <- object@ncols for (i in 3:(nr-1)) { pos <- getoff(object, cellFromRowCol(object, rows[i], 1)) seek(object@file@con, pos, rw='w') writeBin(v[1:nc], object@file@con, size=object@file@dsize ) v <- v[-(1:nc)] } if (length(v) > 0) { pos <- getoff(object, cellFromRowCol(object, rows[nr], 1)) seek(object@file@con, pos, rw='w') writeBin(v, object@file@con, size=object@file@dsize ) } } } } } else { for (i in 1:length(cell)) { pos <- getoff(object, cell[i]) seek(object@file@con, pos, rw='w') writeBin(v[i], object@file@con, size=object@file@dsize ) } } } object@data@min <- minv object@data@max <- maxv object@data@haveminmax <- TRUE object <- writeStop(object) if (object@data@min[band] == Inf) { object@data@haveminmax <- FALSE if (ncell(object) * nbands(object) <= 1000000) { object <- setMinMax(object) hdr(object, driver) } } return( object ) } .updateNCDF <- function(object, v, cell, band) { nc <- ncdf4::nc_open(object@file@name, write=TRUE) on.exit( ncdf4::nc_close(nc) ) zvar <- object@data@zvar dims <- nc$var[[zvar]]$ndims if (dims > 3) { # there is code for one level higher, but I am not sure if it is OK, as it does not check the order or the vars. stop('not yet implemented for high dimensional (>4) ncdf files') } if (is.matrix(v)) { startrow <- rowFromCell(object, cell) startcol <- colFromCell(object, cell) if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(startcol, startrow), count=c(ncol(v), nrow(v))) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(startcol, startrow, band), count=c(ncol(v), nrow(v), 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(startcol, startrow, object@data@level, band), count=c(ncol(v), nrow(v), 1, 1)) ) } } else { if (length(cell) == 1) { cell <- cell:(cell+length(v)-1) rows <- rowFromCell(object, cell) cols <- colFromCell(object, cell) rows <- unique(rows) cols <- unique(cols) nr <- length(rows) if (nr == 1) { #v <- as.matrix(v) if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(cols[1], rows), count=c(length(cols), 1)) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(cols[1], rows, band), count=c(length(cols), 1, 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, v, start=c(cols[1], rows, object@data@level, band), count=c(length(cols), 1, 1, 1)) ) } } else { offset <- c(cols[1], rows[1]) ncols <- object@ncols - cols[1] vv <- v[1:ncols] if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(cols[1], rows), count=c(length(cols), 1)) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(cols[1], rows, band), count=c(length(cols), 1, 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(cols[1], rows, object@data@level, band), count=c(length(cols), 1, 1, 1)) ) } v <- v[-(1:nc)] if (nr > 2) { vv <- v[1:n] nrows <- nr-2 n <- nrows * object@ncols if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows), count=c(ncols, 1)) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, band), count=c(ncols, 1, 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, object@data@level, band), count=c(ncols, 1, 1, 1)) ) } v <- v[-(1:n)] } if (nc$var[[zvar]]$ndims == 2) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows), count=c(1, rows[nr])) ) } else if (nc$var[[zvar]]$ndims == 3) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, band), count=c(1, rows[nr], 1)) ) } else if (nc$var[[zvar]]$ndims == 4) { try ( ncdf4::ncvar_put(nc, zvar, vv, start=c(1, rows, object@data@level, band), count=c(1, rows[nr], 1, 1)) ) } } } else { rows <- rowFromCell(object, cell) cols <- colFromCell(object, cell) if (nc$var[[zvar]]$ndims == 2) { for (i in 1:length(cell)) { try ( ncdf4::ncvar_put(nc, zvar, v[i], start=c(cols[i], rows[i]), count=c(1, 1)) ) } } else if (nc$var[[zvar]]$ndims == 3) { for (i in 1:length(cell)) { try ( ncdf4::ncvar_put(nc, zvar, v[i], start=c(cols[i], rows[i], band), count=c(1, 1, 1)) ) } } else if (nc$var[[zvar]]$ndims == 4) { for (i in 1:length(cell)) { try ( ncdf4::ncvar_put(nc, zvar, v[i], start=c(cols[i], rows[i], object@data@level, band), count=c(1, 1, 1, 1)) ) } } } } return( object ) } .updateGDAL <- function(object, v, cell, band, setminmax) { stop("no longer supported") } # .updateGDAL <- function(object, v, cell, band, setminmax) { # gdal <- methods::new("GDALDataset", filename(object)) # on.exit( rgdal::GDAL.close(gdal) ) # dr <- rgdal::getDriverName(rgdal::getDriver(gdal)) # if (! dr %in% .gdalWriteFormats()[,1]) { # stop('cannot update this file format (GDAL driver)') # } # if (is.matrix(v)) { # startrow <- rowFromCell(object, cell) - 1 # startcol <- colFromCell(object, cell) - 1 # rgdal::putRasterData(gdal, t(v), band=band, offset= c(startrow, startcol) ) # } else { # if (length(cell) == 1) { # cell <- cell:(cell+length(v)-1) # rows <- rowFromCell(object, cell) - 1 # cols <- colFromCell(object, cell) - 1 # rows <- unique(rows) # cols <- unique(cols) # nr <- length(rows) # if (nr == 1) { # rgdal::putRasterData(gdal, v, band=band, offset=c(rows, cols[1])) # } else { # offset <- c(rows[1], cols[1]) # nc <- object@ncols - cols[1] # rgdal::putRasterData(gdal, v[1:nc], band=band, offset=offset) # v <- v[-(1:nc)] # if (nr > 2) { # nrows <- nr-2 # n <- nrows * object@ncols # rgdal::putRasterData(gdal, t(matrix(v[1:n], ncol=object@ncols, byrow=TRUE)), band=band, offset=c(rows[2], 0)) # v <- v[-(1:n)] # } # if (length(v) > 0) { # rgdal::putRasterData(gdal, v, band=band, offset=c(rows[nr], 0)) # } # } # } else { # rows <- rowFromCell(object, cell) - 1 # cols <- colFromCell(object, cell) - 1 # for (i in 1:length(cell)) { # rgdal::putRasterData(gdal, v[i], band=band, offset=c(rows[i], cols[i])) # } # } # } # if (setminmax) { # b <- methods::new("GDALRasterBand", gdal, band) # statistics <- c(object@data@min, object@data@max, NA, NA) # rgdal::GDALcall(b, "SetStatistics", statistics) # } # return(object) # } .checkData <- function(object, v, cell, dtype) { stopifnot(length(cell) > 0) if (is.matrix(v)) { if (length(cell) > 1) { warning('only first cell used') cell <- cell[1] } stopifnot(cell > 0) rc <- rowColFromCell(object, cell) if ((nrow(v) + rc[1] - 1) > nrow(object)) { stop('attempting to update beyond end of file') } if ((ncol(v) + rc[2] - 1) > ncol(object)) { stop('attempting to update beyond end of file') } dm <- dim(v) mat <- TRUE } else { stopifnot( is.vector(v) ) if (length(cell) > 1) { stopifnot(max(cell) <= ncell(object)) stopifnot(min(cell) > 0) if (length(cell) != length(v)) { # recycling vv <- cell vv[] <- v v <- vv } } else { stopifnot(cell > 0) if ((length(v) + cell - 1) > ncell(object)) { stop('attempting to update beyond end of file') } } mat <- FALSE } if (dtype == "INT" ) { v <- as.integer(round(v)) } else if ( dtype =='LOG' ) { v[v != 1] <- 0 v <- as.integer(v) } v[is.infinite(v)] <- NA if (mat) { dim(v) <- dm } return(v) } .updateMinMax <- function(object, v, cell, band) { setminmax <- FALSE v <- stats::na.omit(v) newmin <- FALSE newmax <- FALSE if (length(v) > 0) { minv <- min(v) maxv <- max(v) if (minv < object@data@min[band]) { newmin <- TRUE } if (maxv > object@data@max[band]) { newmax <- TRUE } } if (newmin & newmax) { object@data@min[band] <- minv object@data@max[band] <- maxv setminmax <- TRUE } else { if (is.matrix(v)) { rc <- rowColFromCell(object, cell) oldv <- getValuesBlock(object, rc[1], nrow(v), rc[2], ncol(v)) } else { if (length(cell) == 1) { oldv <- stats::na.omit(.cellValues(object, cell:(cell+length(v)-1))) } else { oldv <- stats::na.omit(.cellValues(object, cell)) } } if (length(oldv) > 0) { oldmin <- min(oldv) oldmax <- max(oldv) if (oldmin > object@data@min[band]) { lostmin <- FALSE } else { lostmin <- TRUE } if (oldmax < object@data@max[band]) { lostmax <- FALSE } else { lostmax <- TRUE } } else { lostmin <- FALSE lostmax <- FALSE } if (! (lostmin | lostmax) ) { if (newmin | newmax) { object@data@min <- min(object@data@min[band], minv) object@data@max <- max(object@data@max[band], maxv) setminmax <- TRUE } } else if ((lostmin & newmin) & (! lostmax)) { object@data@min <- min(object@data@min[band], minv) setminmax <- TRUE } else if ((lostmax & newmax) & (! lostmin)) { object@data@max <- max(object@data@max[band], maxv) setminmax <- TRUE } else { object@data@min[band] <- Inf object@data@max[band] <- -Inf object@data@haveminmax <- FALSE setminmax <- TRUE } } return(list(object, setminmax)) } # .updateGDALminmax <- function(object, minv, maxv) { # gdal <- methods::new("GDALDataset", filename(object)) # on.exit( rgdal::GDAL.close(gdal) ) # for (band in 1:nlayers(object)) { # b <- methods::new("GDALRasterBand", gdal, band) # statistics <- c(minv[band], maxv[band], NA, NA) # rgdal::GDALcall(b, "SetStatistics", statistics) # } # return(object) # } raster/R/density.R0000644000176200001440000000311214507510157013557 0ustar liggesusers# Author: Robert J. Hijmans # Date: December 2009 # Version 0.1 # Licence GPL v3 setMethod('density', signature(x='Raster'), function(x, layer, maxpixels=100000, plot=TRUE, main, ...) { if (nlayers(x)==1) { d <- sampleRegular(x, maxpixels) #, useGDAL=TRUE) x <- density(stats::na.omit(d)) if (plot) { if (missing(main)) { main='' } plot(x, main=main, ...) return(invisible(x)) } else { return(x) } } if (missing(layer)) { y <- 1:nlayers(x) } else if (is.character(layer)) { y <- match(layer, names(x)) } else { y <- layer } y <- unique(as.integer(round(y))) y <- stats::na.omit(y) y <- y[ y >= 1 & y <= nlayers(x) ] nl <- length(y) if (nl == 0) {stop('no existing layers selected')} if (nl > 1) { res <- list() if (nl > 16) { warning('only the first 16 layers are plotted') nl <- 16 y <- y[1:16] } if (missing(main)) { main=names(x) } nc <- ceiling(sqrt(nl)) nr <- ceiling(nl / nc) mfrow <- graphics::par("mfrow") spots <- mfrow[1] * mfrow[2] if (spots < nl) { old.par <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(old.par)) graphics::par(mfrow=c(nr, nc)) } for (i in 1:length(y)) { r <- raster(x, y[i]) m <- main[y[i]] res[[i]] <- density(r, maxpixels=maxpixels, main=m, plot=plot, ...) } } else if (nl==1) { if (missing(main)) { main <- names(x)[y] } r <- raster(x, y) res <- density(r, maxpixels=maxpixels, main=main, plot=plot, ...) } if (plot) return(invisible(res)) else return(res) } ) raster/R/setZ.R0000644000176200001440000000057314507510157013035 0ustar liggesusers# Robert J. Hijmans # June 2011 # Version 1.0 # Licence GPL v3 setZ <- function(x, z, name='time') { if (is.null(z)) { x@z <- list() return(x) } if (is.list(z)) { z <- unlist(z) } stopifnot(length(z) == nlayers(x)) z <- list(z) names(z) <- name[1] x@z <- z x } getZ <- function(x) { if (length(x@z) == 0) { return(NULL) } else { return(x@z[[1]]) } } raster/R/dataType.R0000644000176200001440000000574214507510157013666 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 'dataType<-' <- function(x, value) { if (inherits(x, 'RasterStack')) { stop('Cannot set datatype of a RasterStack') } # for backward compatibility issues and non fatal mistakes. datatype <- substr( toupper( trim(value) ), 1, 5) if (datatype == 'LOGIC') {datatype <- 'LOG1S' } else if (datatype == 'BYTE') {datatype <- 'INT1U' } else if (datatype == 'SMALL') {datatype <- 'INT2S' } else if (datatype == 'INTEG') {datatype <- 'INT2S' } else if (datatype == 'NUMER') {datatype <- 'FLT4S' } else if (datatype == 'FLOAT') {datatype <- 'FLT4S' } else if (datatype == 'DOUBL') {datatype <- 'FLT8S' } else if (datatype == 'SINGL') {datatype <- 'FLT4S' } else if (datatype == 'REAL') {datatype <- 'FLT4S'} if (nchar(datatype) < 3) { stop(paste('invalid datatype:', datatype)) } else if (nchar(datatype) == 3) { if (datatype == 'LOG') { datatype <- paste(datatype, '1S', sep='') } else { datatype <- paste(datatype, '4S', sep='') } } else if (nchar(datatype) == 4) { if (datatype == 'INT1') { datatype <- paste(datatype, 'U', sep='') } else { datatype <- paste(datatype, 'S', sep='') } } # now for real if (!(substr(datatype, 1, 4) %in% c('LOG1', 'INT1', 'INT2', 'INT4', 'FLT4', 'FLT8'))) { stop('not a valid data type') } type <- substr(datatype,1,3) size <- substr(datatype,4,4) signed <- substr(datatype,5,5) != 'U' if (type == "FLT") { # if (dataContent(x) != 'nodata') { # x@data@values[] <- as.numeric(x@data@values) # } if (size == '4') { x@file@datanotation <- 'FLT4S' x@file@nodatavalue <- -3.4E38 } else if (size == '8') { x@file@datanotation <- 'FLT8S' x@file@nodatavalue <- -1.7E308 } else { stop("invalid datasize for a FLT (should be 4 or 8)") } } else if (type == "INT") { # x@data@min <- round(x@data@min) # x@data@max <- round(x@data@max) # if (dataContent(x) != 'nodata') { # x@data@values[] <- as.integer(round(x@data@values)) # } # } if (size == '4') { if (signed) { x@file@datanotation <- 'INT4S' x@file@nodatavalue <- -2147483647 } else { x@file@datanotation <- 'INT4U' x@file@nodatavalue <- 4294967295 } } else if (size == '2') { if (signed) { x@file@datanotation <- 'INT2S' x@file@nodatavalue <- -32768 } else { x@file@datanotation <- 'INT2U' x@file@nodatavalue <- 65535 } } else if (size == '1') { if (signed) { x@file@datanotation <- 'INT1S' x@file@nodatavalue <- as.double(NA) # no default NA value } else { x@file@datanotation <- 'INT1U' x@file@nodatavalue <- as.double(NA) # no default NA value } # } else if (size == '8') { # x@file@nodatavalue <- -9223372036854775808 # x@file@datanotation <- 'INT8S' } else { stop("invalid datasize for this datatype") } } else if ( type == 'LOG' ) { x@file@nodatavalue <- -128 x@file@datanotation <- 'LOG1S' } else { stop("unknown datatype") } return(x) } raster/R/rasterizePointsNGB.R0000644000176200001440000000114414507510157015637 0ustar liggesusers .p2r <- function(p, r=1, x, field, fun, ...) { points <- .pointsToMatrix(p) field <- .getPutVals(p, field, nrow(points), mask=FALSE) x <- raster(x) bf <- .xyvBuf(x, points, r, fun=NULL, na.rm=TRUE, cellnumbers=TRUE, small=TRUE, onlycells=TRUE) bf <- do.call(rbind, bf) bf <- bf[order(bf[,2]), ] field <- data.frame(field, value=1:NROW(field)) bf <- merge(bf, field, by='value') cellvs <- tapply(bf$field, bf[, 'cell', drop=F], fun) cellvs <- cbind(as.numeric(names(cellvs)), do.call(rbind, cellvs)) if (ncol(cellvs) > 2) { x <- brick(x, nl=ncol(cellvs)-1) } x[cellvs[,1]] <- cellvs[,-1] x } raster/R/adjacency.R0000644000176200001440000003433414507510157014033 0ustar liggesusers# Author: Jacob van Etten jacobvanetten@yahoo.com # Date : January 2009 # Version 0.9 # Licence GPL v3 .cs <- function(a,b) { aRep <- rep(a,times=length(b)) cbind(aRep,as.integer(aRep+rep(b,each=length(a))),deparse.level=0) } .adjacency <- function(x, ...) { warning('function "adjaceny" is obsolete and will be removed from the "raster" package.\nUse function "adjacent" in stead') dots <- list(...) fromCells <- dots$fromCells toCells <- dots$toCells directions <- dots$directions if (is.character(directions)) { directions <- tolower(directions) } stopifnot(directions %in% c(4,8,16) | directions=='bishop') x <- raster(x) outerMeridianConnect <- .isGlobalLonLat(x) if (directions=="bishop") { return(.adjBishop(x, fromCells, toCells, outerMeridianConnect)) } nCols <- ncol(x) nCells <- ncell(x) left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) right <- seq(2*nCols,nCells-nCols,by=nCols) upper <- 2:(nCols-1) lower <- seq((nCells-nCols+2),(nCells-1),by=1) upperleft <- 1 upperright <- nCols lowerleft <- nCells-nCols+1 lowerright <- nCells fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright)))) fromCellsUpper <- as.integer(intersect(fromCells,upper)) fromCellsLower <- as.integer(intersect(fromCells,lower)) fromCellsLeft <- as.integer(intersect(fromCells,left)) fromCellsRight <- as.integer(intersect(fromCells,right)) fromCellUpperleft <- as.integer(intersect(fromCells,upperleft)) fromCellUpperright <- as.integer(intersect(fromCells,upperright)) fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft)) fromCellLowerright <- as.integer(intersect(fromCells,lowerright)) rook <- c(1,-1,nCols,-nCols) coreFromToRook <- .cs(fromCellsCore,rook) upperFromToRook <- .cs(fromCellsUpper,rook[1:3]) lowerFromToRook <- .cs(fromCellsLower,rook[c(1,2,4)]) leftFromToRook <- .cs(fromCellsLeft,rook[c(1,3,4)]) rightFromToRook <- .cs(fromCellsRight,rook[2:4]) upperleftFromToRook <- .cs(fromCellUpperleft,rook[c(1,3)]) upperrightFromToRook <- .cs(fromCellUpperright,rook[2:3]) lowerleftFromToRook <- .cs(fromCellLowerleft,rook[c(1,4)]) lowerrightFromToRook <- .cs(fromCellLowerright,rook[c(2,4)]) fromto1 <- rbind(coreFromToRook,upperFromToRook,lowerFromToRook,leftFromToRook,rightFromToRook,upperleftFromToRook,upperrightFromToRook,lowerleftFromToRook,lowerrightFromToRook) if (outerMeridianConnect) { meridianFromLeft <- rbind( cbind(fromCellsLeft,as.integer(fromCellsLeft+nCols-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft+nCols-1)) ) meridianFromRight <- rbind( cbind(fromCellsRight,as.integer(fromCellsRight-nCols+1)), cbind(fromCellUpperright,as.integer(fromCellUpperright-nCols+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-nCols+1)) ) fromto1 <- rbind(fromto1,meridianFromLeft,meridianFromRight) } fromto <- subset(fromto1,fromto1[,2] %in% toCells) if (directions > 4) { bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1)) coreFromToBishop <- .cs(fromCellsCore,bishop) upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4]) lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2]) leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)]) rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)]) upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4]) upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3]) lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2]) lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1]) fromto2 <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop) if (outerMeridianConnect) { meridianFromLeft <- rbind( .cs(fromCellsLeft,c(2*nCols-1,-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1)) ) meridianFromRight <- rbind( cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))), cbind(fromCellUpperright,as.integer(fromCellUpperright+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1)) ) fromto2 <- rbind(fromto2,meridianFromLeft,meridianFromRight) } fromto2 <- subset(fromto2,fromto2[,2] %in% toCells) fromto <- rbind(fromto,fromto2) } if (directions > 8) { leftOuter <- seq(2*nCols+1,nCells-3*nCols+1,by=nCols) rightOuter <- seq(3*nCols,nCells-2*nCols,by=nCols) upperOuter <- seq(3,nCols-2,by=1) lowerOuter <- seq(nCells-nCols+3,nCells-2,by=1) upperleftUnder <- nCols+1 upperrightLeft <- nCols-1 lowerleftUp <- nCells-2*nCols+1 lowerrightUp <- nCells-nCols upperleftRight <- 2 upperrightUnder <- 2*nCols lowerleftRight <- nCells-nCols+2 lowerrightLeft <- nCells-1 leftInner <- seq(2*nCols+2,(nCells-3*nCols+2),by=nCols) rightInner <- seq(3*nCols-1,nCells-2*nCols-1,by=nCols) upperInner <- seq(nCols+3,2*nCols-2,by=1) lowerInner <- seq(nCells-2*nCols+3,nCells-nCols-2,by=1) upperleftInner <- nCols+2 upperrightInner <- 2*nCols-1 lowerleftInner <- nCells-2*nCols+2 lowerrightInner <- nCells-nCols-1 fromCellsCoreInner <- setdiff(fromCells,(c(leftOuter,rightOuter,upperOuter,lowerOuter,upperleft,upperright,lowerleft,lowerright, upperleftUnder, upperrightLeft, lowerleftUp, lowerrightUp, upperleftRight, upperrightUnder, lowerleftRight, lowerrightLeft, leftInner, rightInner, upperInner, lowerInner, upperleftInner, upperrightInner, lowerleftInner, lowerrightInner))) fromCellsUpperInner <- as.integer(intersect(fromCells,upperInner)) fromCellsLowerInner <- as.integer(intersect(fromCells,lowerInner)) fromCellsLeftInner <- as.integer(intersect(fromCells,leftInner)) fromCellsRightInner <- as.integer(intersect(fromCells,rightInner)) fromCellUpperleftInner <- as.integer(intersect(fromCells,upperleftInner)) fromCellUpperrightInner <- as.integer(intersect(fromCells,upperrightInner)) fromCellLowerleftInner <- as.integer(intersect(fromCells,lowerleftInner)) fromCellLowerrightInner <- as.integer(intersect(fromCells,lowerrightInner)) fromCellsLeftOuter <- as.integer(intersect(fromCells,leftOuter)) fromCellsRightOuter <- as.integer(intersect(fromCells,rightOuter)) fromCellsUpperOuter <- as.integer(intersect(fromCells,upperOuter)) fromCellsLowerOuter <- as.integer(intersect(fromCells,lowerOuter)) fromCellUpperleftUnder <- as.integer(intersect(fromCells,upperleftUnder)) fromCellUpperrightLeft <- as.integer(intersect(fromCells,upperrightLeft)) fromCellLowerleftUp <- as.integer(intersect(fromCells,lowerleftUp)) fromCellLowerrightUp <- as.integer(intersect(fromCells,lowerrightUp)) fromCellUpperleftRight <- as.integer(intersect(fromCells,upperleftRight)) fromCellUpperrightUnder <- as.integer(intersect(fromCells,upperrightUnder)) fromCellLowerleftRight <- as.integer(intersect(fromCells,lowerleftRight)) fromCellLowerrightLeft <- as.integer(intersect(fromCells,lowerrightLeft)) knight <- c(-2*nCols-1, -2*nCols+1, -nCols-2, -nCols+2, nCols-2, nCols+2, 2*nCols-1, 2*nCols+1) coreInnerFromToKnight <- .cs(fromCellsCoreInner, knight) upperInnerFromToKnight <- .cs(fromCellsUpperInner, knight[3:8]) lowerInnerFromToKnight <- .cs(fromCellsLowerInner, knight[1:6]) leftInnerFromToKnight <- .cs(fromCellsLeftInner, knight[c(1,2,4,6:8)]) rightInnerFromToKnight <- .cs(fromCellsRightInner, knight[c(1:3,5,7,8)]) upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knight[c(4,6:8)]) upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knight[c(3,5,7,8)]) lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knight[c(1,2,4,6)]) lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knight[c(1:3,5)]) leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knight[c(2,4,6,8)]) rightOuterFromToKnight <- .cs(fromCellsRightOuter, knight[c(1,3,5,7)]) upperOuterFromToKnight <- .cs(fromCellsUpperOuter, knight[5:8]) lowerOuterFromToKnight <- .cs(fromCellsLowerOuter, knight[1:4]) upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knight[c(4,6,8)]) upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knight[c(5,7,8)]) lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knight[c(2,4,6)]) lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knight[c(1,3,5)]) upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knight[6:8]) upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knight[c(3,5,7)]) lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knight[c(1,2,4)]) lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knight[1:3]) upperleftFromToKnight <- .cs(fromCellUpperleft, knight[c(6,8)]) upperrightFromToKnight <- .cs(fromCellUpperright, knight[c(5,7)]) lowerleftFromToKnight <- .cs(fromCellLowerleft, knight[c(2,4)]) lowerrightFromToKnight <- .cs(fromCellLowerright, knight[c(1,3)]) fromto3 <- rbind(coreInnerFromToKnight, upperInnerFromToKnight, lowerInnerFromToKnight, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperOuterFromToKnight, lowerOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight) fromto3 <- subset(fromto3,fromto3[,2] %in% toCells) if (outerMeridianConnect) { knightLeft <- c(-nCols-1, -2, +2*nCols-2, 3*nCols-1) knightRight <- c(-3*nCols+1, -2*nCols+2, +2, nCols+1) leftInnerFromToKnight <- .cs(fromCellsLeftInner, knightLeft[c(2,3)]) rightInnerFromToKnight <- .cs(fromCellsRightInner, knightRight[c(2,3)]) upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knightLeft[c(2,3)]) upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knightRight[c(2,3)]) lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knightLeft[c(2,3)]) lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knightRight[c(2,3)]) leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knightLeft) rightOuterFromToKnight <- .cs(fromCellsRightOuter, knightRight) upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knightLeft[2:4]) upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knightRight[3]) lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knightLeft[1:3]) lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knightRight[1:3]) upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knightLeft[c(3)]) upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knightRight[2:4]) lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knightLeft[2]) lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knightRight[2]) upperleftFromToKnight <- .cs(fromCellUpperleft, knightLeft[c(3,4)]) upperrightFromToKnight <- .cs(fromCellUpperright, knightRight[c(3,4)]) lowerleftFromToKnight <- .cs(fromCellLowerleft, knightLeft[c(1,2)]) lowerrightFromToKnight <- .cs(fromCellLowerright, knightRight[c(1,2)]) fromto3 <- rbind(fromto3, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight) } fromto3 <- subset(fromto3,fromto3[,2] %in% toCells) fromto <- rbind(fromto,fromto3) } colnames(fromto) <- c("from","to") return(fromto) } .adjBishop <- function(raster, fromCells, toCells, outerMeridianConnect) { nCols <- ncol(raster) nCells <- ncell(raster) left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols) right <- seq(2*nCols,nCells-nCols,by=nCols) upper <- 2:(nCols-1) lower <- seq((nCells-nCols+2),(nCells-1),by=1) upperleft <- 1 upperright <- nCols lowerleft <- nCells-nCols+1 lowerright <- nCells fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright)))) fromCellsUpper <- as.integer(intersect(fromCells,upper)) fromCellsLower <- as.integer(intersect(fromCells,lower)) fromCellsLeft <- as.integer(intersect(fromCells,left)) fromCellsRight <- as.integer(intersect(fromCells,right)) fromCellUpperleft <- as.integer(intersect(fromCells,upperleft)) fromCellUpperright <- as.integer(intersect(fromCells,upperright)) fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft)) fromCellLowerright <- as.integer(intersect(fromCells,lowerright)) bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1)) coreFromToBishop <- .cs(fromCellsCore,bishop) upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4]) lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2]) leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)]) rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)]) upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4]) upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3]) lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2]) lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1]) fromto <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop) if (outerMeridianConnect) { meridianFromLeft <- rbind( .cs(fromCellsLeft,c(2*nCols-1,-1)), cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)), cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1)) ) meridianFromRight <- rbind( cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))), cbind(fromCellUpperright,as.integer(fromCellUpperright+1)), cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1)) ) fromto <- rbind(fromto,meridianFromLeft,meridianFromRight) } fromto <- subset(fromto,fromto[,2] %in% toCells) return(fromto) } raster/R/isLonLat.R0000644000176200001440000000505214507510157013632 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .isGlobalLonLat <- function(x) { res <- FALSE tolerance <- 0.1 scale <- xres(x) if (isTRUE(all.equal(xmin(x), -180, tolerance=tolerance, scale=scale)) & isTRUE(all.equal(xmax(x), 180, tolerance=tolerance, scale=scale))) { if (couldBeLonLat(x, warnings=FALSE)) { res <- TRUE } } res } .couldBeLonLat <- function(x, warnings=TRUE) { crsLL <- isLonLat(x) crsNA <- is.na(projection(x)) e <- extent(x) extLL <- (e@xmin > -365 & e@xmax < 365 & e@ymin > -90.1 & e@ymax < 90.1) if (extLL & isTRUE(crsLL)) { return(TRUE) } else if (extLL & crsNA) { if (warnings) { warning('CRS is NA. Assuming it is longitude/latitude') } return(TRUE) } else if (isTRUE(crsLL)) { if (warnings) { warning('raster has a longitude/latitude crs, but coordinates do not match that') } return(TRUE) } else { return(FALSE) } } setMethod("couldBeLonLat", signature("ANY"), function(x, warnings=TRUE, ...) { .couldBeLonLat(x, warnings=warnings) } ) setMethod("couldBeLonLat", signature("BasicRaster"), function(x, warnings=TRUE, ...) { .couldBeLonLat(x, warnings=warnings) } ) setMethod("couldBeLonLat", signature("Spatial"), function(x, warnings=TRUE, ...) { .couldBeLonLat(x, warnings=warnings) } ) setMethod('isLonLat', signature(x='Spatial'), function(x, ...){ isLonLat(projection(x)) } ) setMethod('isLonLat', signature(x='BasicRaster'), # copied from the SP package (slightly adapted) #author: # ... function(x, ...){ p4str <- proj4string(x) if (is.na(p4str) || nchar(p4str) == 0) { return(FALSE) } res <- grep("longlat", p4str, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='character'), # copied from the SP package (slightly adapted) #author: # ... function(x, ...){ res <- grep("longlat", x, fixed = TRUE) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='CRS'), # copied from the SP package (slightly adapted) #author: # ... function(x, ...){ if (is.na(x@projargs)) { return(FALSE) } else { s <- trim(x@projargs) } if (is.na(s) || nchar(s) == 0) { return(FALSE) } s <- gsub(" ", "", s) res1 <- grep("longlat", s) res2 <- grep("+init=epsg:4326", s) res <- c(res1, res2) if (length(res) == 0) { return(FALSE) } else { return(TRUE) } } ) setMethod('isLonLat', signature(x='ANY'), function(x, ...){ isLonLat(as.character(x)) } ) raster/R/extractExtent.R0000644000176200001440000000317314507510157014751 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='Extent'), function(x, y, cellnumbers=FALSE, fun=NULL, na.rm=FALSE, layer=1, nl, df=FALSE, ...) { e <- intersect(extent(x), y) e <- alignExtent(e, x) if (!is.null(fun)) { cellnumbers <- FALSE } else if (cellnumbers) { cell <- cellsFromExtent(x, e) value <- extract(x, cell, layer=layer, nl=nl, df=df) if (df) { value <- data.frame(cell=cell, value) } else { value <- cbind(cell=cell, value) } return(value) } r <- res(x) e@xmin <- e@xmin + 0.25 * r[1] e@xmax <- e@xmax - 0.25 * r[1] e@ymin <- e@ymin + 0.25 * r[2] e@ymax <- e@ymax - 0.25 * r[2] row <- rowFromY(x, e@ymax) lastrow <- rowFromY(x, e@ymin) nrows <- lastrow-row+1 col <- colFromX(x, e@xmin) lastcol <- colFromX(x, e@xmax) ncols <- lastcol-col+1 v <- getValuesBlock(x, row, nrows, col, ncols) if (nlayers(x) > 1) { if (missing(layer)) { layer <- 1 } else { layer <- max(min(nlayers(x), layer), 1) } if (missing(nl)) { nl <- nlayers(x) - layer + 1 } else { nl <- max(min(nlayers(x)-layer+1, nl), 1) } lyrs <- layer:(layer+nl-1) v <- v[ , lyrs, drop=FALSE] } else { lyrs <- 1 } if (! is.null(fun)) { if (is.matrix(v)) { ln <- colnames(v) v <- apply(v, 2, FUN=fun, na.rm=na.rm) names(v) <- ln } else { v <- fun(v, na.rm=na.rm) } } if (df) { v <- data.frame(v) if (ncol(v) == 1) { v <- data.frame(factorValues(x, v, lyrs)) } else { v <- .insertFacts(x, v, lyrs) } } return(v) } ) raster/R/GDALtransient.R0000644000176200001440000000711314507510157014544 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 # .getGDALtransient <- function(r, filename, options, NAflag, ...) { # require(rgdal) # .GDALnodatavalue <- function(x){ # if (x == 'Float32') return(-3.4E38) # if (x == 'Float64') return(-1.7E308) # if (x == 'Int32') return(-2147483647) # if (x == 'Int16') return(-32768) # if (x == 'Int8') return(-128) # if (x == 'Byte') return(255) # if (x == 'UInt16') return(65535) # if (x == 'UInt32') return(2147483647) #(4294967295) <- not supported as integer in R # stop('cannot find matching nodata value') # } # nbands <- nlayers(r) # ct <- colortable(r) # if (length(ct) > 0 ) { # hasCT <- TRUE # if (is.null(list(...)$datatype)) { # datatype <- 'INT1U' # } else { # datatype <- .datatype(...) # } # } else { # hasCT <- FALSE # datatype <- .datatype(...) # } # isFact <- is.factor(r) # if (any(isFact)) { # v <- levels(r) # } # r <- raster(r) # overwrite <- .overwrite(...) # gdalfiletype <- .filetype(filename=filename, ...) # .isSupportedFormat(gdalfiletype) # if (filename == "") { # stop('provide a filename') # } # if (file.exists( filename)) { # if (!overwrite) { # stop("filename exists; use overwrite=TRUE") # } else if (!file.remove( filename)) { # stop("cannot delete existing file; permission denied.") # } # } # dataformat <- .getGdalDType(datatype, gdalfiletype) # if (dataformat != 'Byte') hasCT <- FALSE # if (missing(NAflag)) { # NAflag <- .GDALnodatavalue(dataformat) # } # if (gdalfiletype=='GTiff') { # bytes <- ncell(r) * dataSize(datatype) * nbands # if (bytes > (4 * 1024 * 1024 * 1000) ) { # ~ 4GB # options <- c(options, 'BIGTIFF=YES') # } # options <- c(options, "COMPRESS=LZW") # } # driver <- methods::new("GDALDriver", gdalfiletype) # transient <- try( methods::new("GDALTransientDataset", driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL), silent=TRUE) # if ( inherits(transient, "try-error")) { # if (dataformat == "Float64") { # dataformat <- "Float32" # } # transient <- methods::new("GDALTransientDataset", driver=driver, rows=r@nrows, cols=r@ncols, bands=nbands, type=dataformat, fname=filename, options=options, handle=NULL) # } # for (i in 1:nbands) { # b <- methods::new("GDALRasterBand", transient, i) # rgdal::GDALcall(b, "SetNoDataValue", NAflag) # if (hasCT) { # rgdal::GDALcall(b, "SetRasterColorTable", ct) # } # if (isFact[i]) { # vv <- v[[i]] # if (NCOL(vv) > 1) { # rn <- data.frame(IDID=0:max(vv[,1])) # rnvv <- merge(rn, vv, by=1, all.x=TRUE) # rnvv <- rnvv[order(rnvv[,1]), ] # cnms <- as.character(rnvv[,2]) # cnms[is.na(cnms)] <- '' # rgdal::GDALcall(b, "SetCategoryNames", cnms) # } # } # } # if (rotated(r)) { # gt <- r@rotation@geotrans # } else { # #if (flip) { # # gt <- c(xmin(r), xres(r), 0, 0, ymax(r), yres(r)) # # cat('flipping (this creates an invalid RasterLayer)\n') # #} else { # gt <- c(xmin(r), xres(r), 0, ymax(r), 0, -yres(r)) # #} # } # rgdal::GDALcall(transient, "SetGeoTransform", gt) # if (.useproj6() & !is.na(r@crs)) { # if (!is.na(r@crs)) { # cmt <- attr(r@crs, "comment") # if (is.null(cmt)) { # r@crs <- sp::CRS(r@crs@projargs) # } # } # rgdal::GDALcall(transient, "SetProjectWkt", r@crs) # } else { # prj <- proj4string(r) # rgdal::GDALcall(transient, "SetProject", prj) # } # if (is.null(options)) { # options <- '' # } # return(list(transient, NAflag, options, dataformat)) # } raster/R/image.R0000644000176200001440000000207314507510157013167 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod("image", signature(x='RasterLayer'), function(x, maxpixels=500000, useRaster=TRUE, ...) { # coltab <- x@legend@colortable # if (is.null(coltab) | length(coltab) == 0 | is.null(list(...)$col)) { # colortab <- FALSE # } # if (missing(main)) { main <- names(x) } x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) y <- yFromRow(x, nrow(x):1) # drop=F fix by Daniel Schlaepfer for single row image value <- t(as.matrix(x)[nrow(x):1, ,drop=FALSE]) x <- xFromCol(x,1:ncol(x)) # if (colortab) { # image(x=x, y=y, z=value, col=coltab[value], useRaster=useRaster, ...) # } else { image(x=x, y=y, z=value, useRaster=useRaster, ...) # } } ) setMethod("image", signature(x='RasterStackBrick'), function(x, y=1, maxpixels=100000, useRaster=TRUE, main, ...) { y <- round(y) stopifnot(y > 0 & y <= nlayers(x)) x <- raster(x, y) if (missing(main)) { main <- names(x) } image(x, maxpixels=maxpixels, useRaster=useRaster, main=main, ...) } ) raster/R/writeAllRaster.R0000644000176200001440000000432014507510157015046 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 ..writeRasterAll <- function(x, filename, NAflag, filetype, ... ) { x@file@driver <- filetype filename <- trim(filename) fnamevals <- .setFileExtensionValues(filename, filetype) fnamehdr <- .setFileExtensionHeader(filename, filetype) if (filetype == 'raster') { filename <- fnamehdr } else { filename <- fnamevals } x@file@name <- filename overwrite <- .overwrite(...) if (!overwrite & (file.exists(fnamehdr) | file.exists(fnamevals))) { stop(paste(filename,"exists. Use 'overwrite=TRUE' if you want to overwrite it")) } na <- is.nan(x@data@values) | is.infinite(x@data@values) if (any(na)) { x@data@values[na] <- NA } x <- setMinMax(x) datatype <- .datatype(...) if (filetype == 'SAGA') { if (datatype == 'FLT8S') { datatype = 'FLT4S' } } dtype <- .shortDataType(datatype) dataType(x) <- datatype if (missing(NAflag) ) { NAflag <- x@file@nodatavalue } mn <- minValue(x) mx <- maxValue(x) if (dtype == 'INT' ) { #datatype <- .checkIntDataType(mn, mx, datatype) dataType(x) <- datatype NAflag <- as.integer(round(NAflag)) if (substr(datatype, 5 , 5) == 'U') { x@data@values[x@data@values < 0] <- NA if (datatype == 'INT4U') { x@data@values[is.na(x@data@values)] <- NAflag #i <- x@data@values > 2147483647 & !is.na( x@data@values ) #x@data@values[i] <- 2147483647 - x@data@values[i] } else { x@data@values[is.na(x@data@values)] <- NAflag } } else { x@data@values[is.na(x@data@values)] <- NAflag } x@data@values <- as.integer(round( x@data@values )) x@data@min <- round(x@data@min) x@data@max <- round(x@data@max) } else if ( dtype =='FLT') { x@data@values <- as.numeric(x@data@values) if (filetype != 'raster') { x@data@values[is.na(x@data@values)] <- NAflag } } else if ( dtype =='LOG') { x@data@values <- as.integer(x@data@values) x@data@values[is.na(x@data@values)] <- as.integer(x@file@nodatavalue) } dsize <- dataSize(x@file@datanotation) filecon <- file(fnamevals, "wb") writeBin(x@data@values , filecon, size = dsize ) close(filecon) x@file@nodatavalue <- NAflag hdr(x, filetype) return(raster(filename, native=TRUE)) } raster/R/cv.R0000644000176200001440000000320414507510157012512 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008-2011 # Version 1.0 # Licence GPL v3 setGeneric("cv", function(x, ..., aszero=FALSE, na.rm=FALSE) standardGeneric("cv")) setMethod('cv', signature(x='ANY'), function(x, ..., aszero=FALSE, na.rm=FALSE) { # R function to compute the coefficient of variation (expressed as a percentage) # if there is only a single value, stats::sd = NA. However, one could argue that cv =0. # and NA may break the code that receives it. #The function returns NA if(aszero=FALSE) else a value of 0 is returned. x <- c(x, ...) z <- x[!is.na(x)] if (length(z) == 0) { return(NA) } else if (na.rm == FALSE & (length(z) < length(x))) { return(NA) } else if (length(z) == 1 & aszero) { return(0) } else { # abs to avoid very small (or zero) mean with e.g. -5:5 x <- mean(abs(z)) if (x == 0) {# all values are 0 return(0) } else { return(100 * stats::sd(z) / x) } } } ) setMethod("cv", signature(x='Raster'), function(x, ..., aszero=FALSE, na.rm=FALSE){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- .addArgs(...) } else { add <- NULL } out <- raster(x) if (canProcessInMemory(x)) { x <- cbind(getValues(x), add) x <- setValues(out, apply(x, 1, cv, aszero=aszero, na.rm=na.rm)) return(x) } tr <- blockSize(out) pb <- pbCreate(tr$n) out <- writeStart(out, filename="") for (i in 1:tr$n) { v <- cbind( getValues( x, row=tr$row[i], nrows=tr$nrows[i] ), add) v <- apply(v, 1, cv, aszero=aszero, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) writeStop(out) } ) raster/R/subs.R0000644000176200001440000000723214507510157013063 0ustar liggesusers# Authors: Robert J. Hijmans # Date : February 2010 # Version 0.9 # Licence GPL v3 if (!isGeneric("subs")) { setGeneric("subs", function(x, y, ...) standardGeneric("subs")) } .localmerge <- function(x, y, subNA, byc=1) { if (byc==1) { nc <- NCOL(x) nr <- NROW(x) x <- cbind(1:length(x), as.vector(x)) if (! subNA ) { y <- merge(x, y, by.x=2, by.y=1) x[y[,2], 2] <- y[,3] x <- x[,2] if (nc > 1) { x <- matrix(as.vector(x), nrow=nr) } } else { x <- as.matrix(merge(x, y, by.x=2, by.y=1, all.x=TRUE)) x <- x[order(x[,2]), -c(1:2)] } if (nc > 1) { x <- matrix(as.vector(x), nrow = nr) } } else { x <- cbind(1:nrow(x), x) x <- as.matrix(merge(x, y, by.x=(1:byc)+1, by.y=1:byc, all.x=TRUE)) x <- x[, -(1:byc)] x <- x[order(x[,1]), -1] } return(x) } setMethod('subs', signature(x='Raster', y='data.frame'), function(x, y, by=1, which=2, subsWithNA=TRUE, filename='', ...) { if (!subsWithNA) { if (length(which) > 1) { stop('you cannot use subsWithNA=FALSE if length(which) > 1') } if (length(by) > 1) { stop('you cannot use subsWithNA=FALSE if length(by) > 1') } } stopifnot(length(by) == 1 | length(by) == nlayers(x)) if (is.character(by)) { by <- match(by, colnames(y)) if (any(is.na(by))) { stop("'by' is not a valid column name") } } if (is.character(which)) { which <- which(which == colnames(y))[1] if (is.na(which)) { stop("'which' is not valid column name") } } byc <- length(by) tt <- table(y[,by]) tt <- tt[ which(tt > 1) ] if (length(tt) > 0) { stop('duplicate "by" values not allowed') } out <- raster(x) nlx <- nlayers(x) cls <- sapply(y, class) hasfactor <- rep(FALSE, length(cls)-1) levs <- list() for (i in 2:length(cls)) { if (cls[i] == 'character') { suppressWarnings(tmp <- as.numeric(y[,i])) if (all(is.na(tmp) == is.na(y[,i]))) { y[,i] <- tmp cls[i] <- 'numeric' } else { y[,i] <- factor(y[,i]) cls[i] <- 'factor' } } if (cls[i] == 'factor') { uny <- unique(y[,i]) lv <- data.frame(ID=1:length(uny), uny) colnames(lv)[2] <- colnames(y)[i] levs[[i-1]] <- lv hasfactor[i-1] <- TRUE m <- match(y[,i], uny) y[,i] <- m #as.numeric(uny[m]) } } if (nlx == 1) { ln <- colnames(y)[which] if (length(which) > 1) { out <- brick(out, nl=length(which)) } } else { if (byc == 1) { out <- brick(out, nl=nlx * length(which)) ln <- rep(names(x), length(which)) if (length(which) > 1) { ln2 <- rep(colnames(y)[which], each=nlx) ln <- paste(ln, paste('_', ln2, sep=''), sep='') } } else { if (length(which) > 1) { out <- brick(out, nl=length(which)) } ln <- colnames(y)[which] } } names(out) <- ln y <- y[ , c(by, which)] filename <- trim(filename) if (canProcessInMemory(x, 3)) { if (any(hasfactor)) { out@data@isfactor <- hasfactor out@data@attributes <- levs } v <- .localmerge( getValues(x), y, subsWithNA, byc ) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } tr <- blockSize(out) pb <- pbCreate(tr$n, label='subs', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) out <- writeValues(out, .localmerge(v, y, subsWithNA, byc), tr$row[i]) pbStep(pb) } pbClose(pb) if (any(hasfactor)) { out@data@isfactor <- TRUE out@data@attributes <- levs } out <- writeStop(out) return(out) } } ) raster/R/flip.R0000644000176200001440000000732314507510157013042 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('flip', signature(x='RasterLayer'), function(x, direction='y', filename='', ...) { filename <- trim(filename) outRaster <- .copyWithProperties(x) if (direction[1] == 1) { direction <- 'x' } else if (direction[1] == 2) { direction <- 'y' } if (!(direction %in% c('y', 'x'))) { stop('direction should be "y" or "x"') } if (!canProcessInMemory(outRaster, 2) && filename == '') { filename <- rasterTmpFile() inmemory = FALSE } else { inmemory = TRUE } if ( inmemory ) { x <- getValues(x, format='matrix') if (direction == 'y') { x <- x[nrow(x):1,] } else { x <- x[,ncol(x):1] } outRaster <- setValues(outRaster, as.vector(t(x))) if (filename != '') { outRaster = writeRaster(outRaster, filename=filename, ...) } } else { tr <- blockSize(outRaster) pb <- pbCreate(tr$n, label='flip', ...) outRaster <- writeStart(outRaster, filename=filename, datatype=dataType(x), ... ) if (direction == 'y') { nr <- nrow(outRaster) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- matrix(v, ncol=ncol(x), byrow=TRUE) v <- as.vector(t(v[nrow(v):1, ])) rownr <- nr - tr$row[i] - tr$nrows[i] + 2 outRaster <- writeValues(outRaster, v, rownr) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- matrix(v, ncol=ncol(x), byrow=TRUE) v <- as.vector(t(v[, ncol(v):1])) outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } } outRaster <- writeStop(outRaster) pbClose(pb) } return(outRaster) } ) setMethod('flip', signature(x='RasterStackBrick'), function(x, direction='y', filename='', ...) { filename <- trim(filename) outRaster <- brick(x, values=FALSE) if (direction[1] == 1) { direction <- 'x' } else if (direction[1] == 2) { direction <- 'y' } if (!(direction %in% c('y', 'x'))) { stop('directions should be y or x') } if (!canProcessInMemory(outRaster, 2) && filename == '') { filename <- rasterTmpFile() inmemory = FALSE } else { inmemory = TRUE } nc <- outRaster@ncols if ( inmemory ) { x <- getValues(x) for (i in 1:NCOL(x)) { v <- matrix(x[,i], ncol=nc, byrow=TRUE) if (direction == 'y') { v <- v[nrow(v):1,] } else { v <- v[,ncol(v):1] } x[,i] <- as.vector(t(v)) } outRaster <- setValues(outRaster, x) if (filename != '') { outRaster = writeRaster(outRaster, filename=filename, ...) } } else { tr <- blockSize(outRaster) pb <- pbCreate(tr$n, label='flip', ...) if (inherits(x, 'RasterStack')) { dtype <- 'FLT4S' } else { dtype <- dataType(x) } outRaster <- writeStart(outRaster, filename=filename, datatype=dtype, ... ) if (direction == 'y') { trinv <- tr trinv$row <- rev(trinv$row) trinv$nrows <- rev(trinv$nrows) trinv$newrows <- cumsum(c(1,trinv$nrows))[1:length(trinv$nrows)] for (i in 1:tr$n) { vv <- getValues(x, row=trinv$row[i], nrows=trinv$nrows[i]) for (j in 1:NCOL(vv)) { v <- matrix(vv[,j], nrow=nc) vv[,j] <- as.vector(v[, ncol(v):1]) } outRaster <- writeValues(outRaster, vv, trinv$newrows[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { vv = getValues(x, row=tr$row[i], nrows=tr$nrows[i]) for (j in 1:NCOL(vv)) { v <- matrix(vv[,j], nrow=nc) vv[,j] <- as.vector(v[nrow(v):1, ]) } outRaster <- writeValues(outRaster, vv, tr$row[i]) pbStep(pb, i) } } outRaster <- writeStop(outRaster) pbClose(pb) } return(outRaster) } ) raster/R/rasterFromBIL.R0000644000176200001440000001233514507510157014562 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromGenericFile <- function(filename, band=1, SIGNEDINT=NULL, type='RasterLayer', crs="", ...) { hdrfname <- .setFileExtensionHeader(filename, "BIL") ini <- readIniFile(hdrfname, token=' ') if (ini[1,1] == "ENVI") { stop("This file has an ENVI header; I cannot read that natively, only via GDAL") } ini[,2] = toupper(ini[,2]) byteorder <- '' nbands <- as.integer(1) band <- as.integer(band) bandorder <- "BIL" minval <- Inf maxval <- -Inf nodataval <- -Inf pixtype <- '' gaps <- 0 xx <- xn <- xd <- yx <- yn <- yd <- NULL for (i in 1:length(ini[,1])) { if (ini[i,2] == "LLXMAP") {xn <- as.numeric(ini[i,3])} else if (ini[i,2] == "ULXMAP") {xn <- as.numeric(ini[i,3])} else if (ini[i,2] == "LRXMAP") {xx <- as.numeric(ini[i,3])} else if (ini[i,2] == "URXMAP") {xx <- as.numeric(ini[i,3])} else if (ini[i,2] == "LLYMAP") {yn <- as.numeric(ini[i,3])} else if (ini[i,2] == "ULYMAP") {yx <- as.numeric(ini[i,3])} else if (ini[i,2] == "LRYMAP") {yn <- as.numeric(ini[i,3])} else if (ini[i,2] == "URYMAP") {yx <- as.numeric(ini[i,3])} else if (ini[i,2] == "XDIM") {xd <- as.numeric(ini[i,3])} else if (ini[i,2] == "YDIM") {yd <- as.numeric(ini[i,3])} else if (ini[i,2] == "YMAX") {yx <- as.numeric(ini[i,3])} else if (ini[i,2] == "ROWS") {nr <- as.integer(ini[i,3])} else if (ini[i,2] == "COLUMNS") {nc <- as.integer(ini[i,3])} else if (ini[i,2] == "NROWS") {nr <- as.integer(ini[i,3])} else if (ini[i,2] == "NCOLS") {nc <- as.integer(ini[i,3])} else if (ini[i,2] == "NODATA") {nodataval <- as.numeric(ini[i,3])} else if (ini[i,2] == "NBITS") {nbits <- ini[i,3]} else if (ini[i,2] == "PIXELTYPE") {pixtype <- ini[i,3]} else if (ini[i,2] == "BANDGAPBYTES") {gaps <- ini[i,3]} else if (ini[i,2] == "BYTEORDER") {byteorder <- ini[i,3]} else if (ini[i,2] == "NBANDS") {nbands <- ini[i,3]} else if (ini[i,2] == "LAYOUT") {bandorder <- ini[i,3]} else if (ini[i,2] == "MINVALUE=") {try (minval <- as.numeric(unlist(strsplit(trim(ini[i,3]), ' ')))) } else if (ini[i,2] == "MAXVALUE=") {try (maxval <- as.numeric(unlist(strsplit(trim(ini[i,3]), ' ')))) } } wrldf <- extension(filename, '.blw') if (file.exists(wrldf)) { a <- readLines(wrldf) if (is.null(xn)) xn <- as.numeric(a[5]) if (is.null(xd)) xd <- as.numeric(a[1]) if (is.null(yx)) yx <- as.numeric(a[6]) if (is.null(yd)) yd <- -1 * as.numeric(a[4]) } if (is.null(xd)) { xd <- (xx - xn) / (nc - 1) } if (is.null(yd)) { yd <- (yx - yn) / (nr - 1) } if (!is.null(xn)) { xn <- xn - 0.5 * xd if (is.null(xx)) { xx <- xn + nc * xd } } else { xx <- xx + 0.5 * xd xn <- xx - nc * xd } if (!is.null(yn)) { yn <- yn - 0.5 * yd if (is.null(yx)) { yx <- yn + nr * yd } } else { yx <- yx + 0.5 * yd yn <- yx - nr * yd } if (gaps > 0) { stop('generic raster with gaps not supported') } if (band < 1) { band <- 1 warning('band set to 1') } else if (band > nbands) { band <- nbands warning('band set to ', nbands) } minval <- minval[1:nbands] maxval <- maxval[1:nbands] minval[is.na(minval)] <- Inf maxval[is.na(maxval)] <- -Inf if (type == 'RasterBrick') { x <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) x@data@nlayers <- as.integer(nbands) x@data@min <- minval x@data@max <- maxval } else { x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) x@data@band <- as.integer(band) x@data@min <- minval[band] x@data@max <- maxval[band] } if (x@data@min[1] != Inf) {x@data@haveminmax <- TRUE } else { x@data@haveminmax <- FALSE } x@file@nbands <- as.integer(nbands) if (bandorder %in% c("BSQ", "BIP", "BIL")) { x@file@bandorder <- bandorder } if (type == 'RasterBrick') { names(x) <- rep(gsub(" ", "_", extension(basename(filename), "")), nbands) } else { lnames <- gsub(" ", "_", extension(basename(filename), "")) if (nbands > 1) { lnames <- paste(lnames, '_', band, sep='') } names(x) <- lnames } x@file@name <- filename if (!is.null(SIGNEDINT)) { if(SIGNEDINT) { pixtype <- 'SIGNEDINT' } else { pixtype <- 'UNSIGNEDINT' } } if (nbits == 8) { if (pixtype == 'SIGNEDINT') { dataType(x) <- 'INT1S' } else { if (pixtype != 'UNSIGNEDINT') { warning('assuming data is unsigned. If this is not correct, use dataType(x) <- "INT1S"') } dataType(x) <- 'INT1U' } } else if (nbits == 16) { if (pixtype == 'SIGNEDINT') { dataType(x) <- 'INT2S' } else { if (pixtype != 'UNSIGNEDINT') { warning('assumed data is unsigned. If this is not correct, use dataType(x) <- "INT2S"') } dataType(x) <- 'INT2U' } } else if (nbits == 32) { if (pixtype == 'FLOAT') { dataType(x) <- 'FLT4S' } else { dataType(x) <- 'INT4S' } } else if (nbits == 64 & pixtype == 'FLOAT') { dataType(x) <- 'FLT8S' # } else { # dataType(x) <- 'INT8S' # } } else { stop(paste('unexpected nbits in BIL:', nbits)) } if (byteorder == "I") { x@file@byteorder <- 'little' } else if (byteorder == "M") { x@file@byteorder <- 'big' } else { x@file@byteorder <- .Platform$endian } x@data@fromdisk <- TRUE x@file@driver <- bandorder x@file@nodatavalue <- nodataval return(x) } raster/R/head.R0000644000176200001440000000303114507510157013001 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2010 # Version 0.9 # Licence GPL v3 setMethod('head', signature(x='RasterLayer'), function(x, cols=20, rows=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) v <- getValuesBlock(x, 1, nrows=nr, ncols=nc, format='matrix') return(v) } ) setMethod('tail', signature(x='RasterLayer'), function(x, cols=20, rows=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) sr <- x@nrows - nr + 1 sc <- x@ncols - nc + 1 v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc, format='matrix') return(v) } ) setMethod('head', signature(x='RasterStackBrick'), function(x, cols=10, rows=2, layers=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) nl <- min(nlayers(x), max(1, layers)) v <- getValuesBlock(x, 1, nrows=nr, ncols=nc) return(v) } ) setMethod('tail', signature(x='RasterStackBrick'), function(x, cols=10, rows=2, layers=10, ...) { nr <- min(x@nrows, max(1, rows)) nc <- min(x@ncols, max(1, cols)) nl <- min(nlayers(x), max(1, layers)) sr <- x@nrows - nr + 1 sc <- x@ncols - nc + 1 v <- getValuesBlock(x, row=sr, nrows=nr, col=sc, ncols=nc) return(v) } ) setMethod('head', signature(x='Spatial'), function(x, n=6L,...) { if (.hasSlot(x, 'data')) { head(x@data, n=n, ...) } else { x[1,] } } ) setMethod('tail', signature(x='Spatial'), function(x, n=6L, ...) { if (.hasSlot(x, 'data')) { tail(x@data, n=n, ...) } else { x[length(x),] } } ) raster/R/arith_sp.R0000644000176200001440000000140014507510157013707 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod("+", signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ union(e1, e2) } ) setMethod("*", signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ intersect(e1, e2) } ) setMethod("-", signature(e1='SpatialPolygons', e2='SpatialPolygons'), function(e1, e2){ erase(e1, e2) } ) #setMethod("^", signature(e1='SpatialPolygons', e2='SpatialPolygons'), # function(e1, e2){ # crop(e1, e2) # } #) setMethod("+", signature(e1='SpatialPoints', e2='SpatialPoints'), function(e1, e2){ bind(e1, e2) } ) setMethod("+", signature(e1='SpatialLines', e2='SpatialLines'), function(e1, e2){ bind(e1, e2) } ) raster/R/readCells.R0000644000176200001440000001176614507510157014014 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 #read data on the raster for cell numbers .readCells <- function(x, cells, layers) { if (length(cells) < 1) { # cat(cells,"\n") # utils::flush.console() return(NULL) } cells <- round(cells) cells <- cbind(1:length(cells), cells) cells <- cells[order(cells[,2]), ,drop=FALSE] uniquecells <- sort(stats::na.omit(unique(cells[,2]))) uniquecells <- uniquecells[(uniquecells > 0) & (uniquecells <= ncell(x))] if (length(uniquecells) == 0) { return( matrix(NA, nrow=nrow(cells), ncol=length(layers)) ) } # creates problems with large integers # perhaps not needed (or causes problems with merge?) # uniquecells <- as.integer(uniquecells) # now using round (above) adjust <- TRUE if (length(uniquecells) > 0) { if ( inMemory(x) ) { vals <- getValues(x)[uniquecells] adjust <- FALSE } else if ( fromDisk(x) ) { driver <- x@file@driver if (length(uniquecells) > 250 & canProcessInMemory(x, 4)) { vals <- getValues(x) if (length(layers) > 1) { vals <- vals[uniquecells, layers, drop=FALSE] } else { vals <- vals[uniquecells] } adjust <- FALSE } else if (driver == 'gdal') { vals <- .readCellsGDAL(x, uniquecells, layers) } else if ( .isNativeDriver( driver) ) { # raster, BIL, .. vals <- .readCellsRaster(x, uniquecells, layers) # } else if ( driver == 'big.matrix') { # vals <- .readBigMatrixCells(x, uniquecells) } else if ( driver == 'netcdf') { vals <- .readRasterCellsNetCDF(x, uniquecells) } else if ( driver == 'ascii') { # can only have one layer vals <- .readCellsAscii(x, uniquecells) } else { stop('I did not expect the code to get here. Please report') } } else { stop('no data on disk or in memory') } } else { return(rep(NA, times=length(cells[,1]))) } if (is.null(dim(vals))) { vals <- matrix(vals, ncol=length(layers)) colnames(vals) <- names(x)[layers] } vals <- cbind(uniquecells, vals) vals <- merge(x=cells[,2], y=vals, by=1, all=TRUE) vals <- as.matrix(cbind(cells[,1], vals[,2:ncol(vals)])) # vals <- vals[order(cells[,1]), 2, drop=FALSE] vals <- vals[order(vals[,1]), 2:ncol(vals)] # terra already adjusted #if (adjust) { # if (x@data@gain != 1 | x@data@offset != 0) { # vals <- vals * x@data@gain + x@data@offset # } #} # if NAvalue() has been used..... if (.naChanged(x)) { if (x@file@nodatavalue < 0) { vals[vals <= x@file@nodatavalue] <- NA } else { vals[vals == x@file@nodatavalue] <- NA } } return(vals) } .readBigMatrixCells <- function(x, cells, layers) { b <- attr(x@file, 'big.matrix') if (inherits(x, 'RasterLayer')) { colrow <- matrix(ncol=3, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow[,3] <- NA rows <- sort(unique(colrow[,2])) nc <- x@ncols for (i in 1:length(rows)) { v <- b[rows[i], ] thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } colrow[, 3] } else { b[cells, layers] } } .readCellsRaster <- function(x, cells, layers=1) { nl <- length(layers) res <- vector(length=length(cells)*nl) res[] <- NA if (! x@file@toptobottom) { rows <- rowFromCell(x, cells) cols <- colFromCell(x, cells) rows <- nrow(x) - rows + 1 cells <- cellFromRowCol(x, rows, cols) } cells <- cells + x@file@offset if (nbands(x) > 1) { if (inherits(x, 'RasterLayer')) { if (.bandOrder(x) == 'BIL') { cells <- cells + (rowFromCell(x, cells)-1) * x@ncols * (nbands(x)-1) + (bandnr(x)-1) * x@ncols } else if (.bandOrder(x) == 'BIP') { cells <- (cells - 1) * nbands(x) + bandnr(x) } else if (.bandOrder(x) == 'BSQ') { cells <- cells + (bandnr(x)-1) * ncell(x) } } else { if (.bandOrder(x) == 'BIL') { cells <- rep(cells + (rowFromCell(x, cells)-1) * x@ncols * (nbands(x)-1) , each=nl) + (layers-1) * x@ncols } else if (.bandOrder(x) == 'BIP') { cells <- rep((cells - 1) * nbands(x), each=nl) + layers } else if (.bandOrder(x) == 'BSQ') { cells <- rep(cells, each=nl) + (layers-1) * ncell(x) } } } byteord <- x@file@byteorder dsize <- dataSize(x@file@datanotation) if (.shortDataType(x@file@datanotation) == "FLT") { dtype <- "numeric" } else { dtype <- "integer" } cells <- (cells-1) * dsize signed <- dataSigned(x@file@datanotation) if (dsize > 2) { signed <- TRUE } is.open <- x@file@open if (!is.open) { x <- readStart(x) } for (i in seq(along.with=cells)) { seek(x@file@con, cells[i]) res[i] <- readBin(x@file@con, what=dtype, n=1, size=dsize, endian=byteord, signed=signed) } if (!is.open) { x <- readStop(x) } if (x@file@datanotation == 'INT4U') { i <- !is.na(res) & res < 0 res[i] <- 2147483647 - res[i] } if (dtype == "numeric") { res[is.nan(res)] <- NA res[res <= x@file@nodatavalue] <- NA } else { res[res == x@file@nodatavalue] <- NA } if (nl > 1) { res <- t(matrix(res, nrow=nl)) colnames(res) <- names(x)[layers] } return(res) } raster/R/dotdens.R0000644000176200001440000000252714507510157013551 0ustar liggesusers# Robert Hijmans # Based on maptools:dotsInPolys by Roger Bivand .dotdensity <- function(p, field, x=1, type="regular", seed=0, sp=FALSE, ...) { set.seed(seed) stopifnot(inherits(p, 'SpatialPolygons')) n <- length(p) if (n < 1) return(invisible(NULL)) f <- tolower(type) stopifnot(type %in% c('regular', 'random')) if (inherits(p, 'SpatialPolygonsDataFrame')) { if (is.numeric(field)) { if (length(field)==1) { field <- round(field) stopifnot(field > 0 & field <= ncol(p)) field <- p@data[, field] } else { stopifnot(length(field)==length(p)) } } else if (is.character(field)) { stopifnot(field %in% names(p)) field <- p@data[, field] } } else { stopifnot(is.numeric(field)) stopifnot(length(field)==length(p)) } x <- x[1] stopifnot(x > 0) d <- round(field / x) d[d < 1] <- 0 d[is.na(d)] <- 0 res <- vector(mode = "list", length = n) for (i in 1:n) { if (d[i] > 0) { ires <- try (sp::spsample(p[i, ], d[i], type=f), silent=TRUE ) if (inherits(ires, "try-error")) { print(paste('error, ', d[i])) ires <- NULL } if (!is.null(ires)) { res[[i]] <- cbind(sp::coordinates(ires), id=i) } } } res <- do.call("rbind", res) colnames(res)[1:2] <- c('x', 'y') if (sp) { res <- data.frame(res) sp::coordinates(res) <- ~ x+y crs(res) <- crs(p) } res } raster/R/as.raster.R0000644000176200001440000000130714507510157014006 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2011 # Version 0.9 # Licence GPL v3 # Note: these functions create a _r_aster object (small r) (grDevices) for use with the rasterImage function # _NOT_ a Raster* object as defined in this package setMethod('as.raster', signature(x='RasterLayer'), function(x, maxpixels=50000, col=rev(terrain.colors(255)), ...) { x <- as.matrix(sampleRegular(x, maxpixels, asRaster=TRUE)) r <- range(x, na.rm=TRUE) x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) x[] <- col[x] as.raster(x) } ) #e <- as.vector(t(bbox(extent(r)))) #a <- as.raster(r) #plot(e[1:2], e[3:4], type = "n", xlab="", ylab="") #graphics::rasterImage(a, e[1], e[3], e[2], e[4]) raster/R/getValues.R0000644000176200001440000000254614507510157014051 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 if (!isGeneric("getValues")) { setGeneric("getValues", function(x, row, nrows, ...) standardGeneric("getValues")) } setMethod("getValues", signature(x='RasterLayer', row='missing', nrows='missing'), function(x, format='') { cr <- c(x@ncols, x@nrows) # f <- is.factor(x) # if (f) { # labs <- labels(x) # } if ( inMemory(x) ) { x <- x@data@values } else if ( fromDisk(x) ) { x <- .readRasterLayerValues(x, 1, x@nrows) } else { x <- rep(NA, ncell(x)) } if (format=='matrix') { return ( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) ) #} else if (format =='array') { # return( array( matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE), dim=c(cr, 1)) ) # } else if (f) { # x <- factor(x) # set labels? } return( x ) } ) setMethod("getValues", signature(x='RasterBrick', row='missing', nrows='missing'), function(x) { if (! inMemory(x) ) { if ( fromDisk(x) ) { x <- readAll(x) } else { return( matrix(rep(NA, ncell(x) * nlayers(x)), ncol=nlayers(x)) ) } } colnames(x@data@values) <- names(x) x@data@values } ) setMethod("getValues", signature(x='RasterStack', row='missing', nrows='missing'), function(x) { m <- matrix(nrow=ncell(x), ncol=nlayers(x)) colnames(m) <- names(x) for (i in 1:nlayers(x)) { m[,i] <- getValues(x@layers[[i]]) } m } ) raster/R/setValues.R0000644000176200001440000001412114507510157014055 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('setValues', signature(x='RasterLayer'), function(x, values, ...) { if (is.factor(values)) { levs <- levels(values) d <- dim(values) values <- as.integer(values) if (!is.null(d)) { dim(values) <- d } x@data@isfactor <- TRUE x@data@attributes <- list(data.frame(ID=1:length(levs), VALUE=levs)) } if (is.matrix(values)) { if (ncol(values) == x@ncols & nrow(values) == x@nrows) { values <- as.vector(t(values)) } else if (ncol(values)==1 | nrow(values)==1) { values <- as.vector(values) } else { stop('cannot use a matrix with these dimensions') } } else if (!is.vector(values)) { stop('values must be a vector or matrix') } if (!(is.numeric(values) | is.factor(values) | is.logical(values))) { stop('values must be numeric, logical or factor') } if (length(values) == 1) { values <- rep(values, ncell(x)) } if (length(values) == ncell(x)) { x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@file@name <- "" x@file@driver <- "" x@data@values <- values x <- setMinMax(x) return(x) } else { stop("length(values) is not equal to ncell(x), or to 1") } } ) setMethod('setValues', signature(x='RasterStack'), function(x, values, layer=-1, ...) { if (layer > 0) { stopifnot(layer <= nlayers(x)) x[[layer]] <- setValues(x[[layer]], values, ...) return(x) } else { b <- brick(x, values=FALSE) setValues(b, values, ...) } } ) setMethod('setValues', signature(x='RasterBrick', values="ANY"), function(x, values, layer=-1, ...) { layer <- layer[1] if (is.array(values) & !is.matrix(values)) { dm <- dim(values) if (length(dm) != 3) { stop('array has wrong number of dimensions (needs to be 3)') } dmb <- dim(x) transpose <- FALSE if (dmb[1] == dm[2] & dmb[2] == dm[1]) { #if (dm[1] == dm[2]) { warning('assuming values should be transposed') } transpose <- TRUE } else if (dmb[1] != dm[1] | dmb[2] != dm[2]) { stop('dimensions of array do not match the RasterBrick') } # speed imrovements suggested by Justin McGrath # http://pastebin.com/uuLvsrYc if (!transpose) { values <- aperm(values, c(2, 1, 3)) } attributes(values) <- NULL dim(values) <- c(dm[1] * dm[2], dm[3]) ### } else if ( ! (is.vector(values) | is.matrix(values)) ) { stop('values must be a vector or a matrix') } if (!(is.numeric(values) | is.integer(values) | is.logical(values))) { stop('values must be numeric, integer or logical.') } # rownr <- round(rownr) if (layer < 1) { if (!is.matrix(values)) { values <- matrix(values, nrow=ncell(x), ncol=nlayers(x)) } if (nrow(values) == ncell(x)) { x@file@name <- "" x@file@driver <- "" x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@data@nlayers <- ncol(values) cn <- colnames(values) if (!is.null(cn)) { names(x) <- cn } x@data@values <- values x <- setMinMax(x) } else { stop("the size of 'values' is not correct") } } else { nlx <- nlayers(x) if (nlx==0) { x@data@nlayers <- 1 } bind <- FALSE layer <- round(layer) if (layer > nlx) { if (layer == nlx + 1) { bind <- TRUE } else { stop('layer number too high') } } if (length(values) == ncell(x)) { if ( inMemory(x) ) { if (bind) { x@data@values <- cbind(x@data@values, values) x@data@nlayers <- as.integer(x@data@nlayers + 1) } else { x@data@values[,layer] <- values } rge <- range(values, na.rm=TRUE) x@data@min[layer] <- rge[1] x@data@max[layer] <- rge[2] } else { if (canProcessInMemory(x)) { if (hasValues(x)) { x <- readAll(x) x@file@name <- "" x@file@driver <- "" x@data@inmemory <- TRUE x@data@fromdisk <- FALSE } else { x@data@values <- matrix(NA, nrow=ncell(x), ncol=nlx) x@data@min <- rep(Inf, nlx) x@data@max <- rep(-Inf, nlx) x@data@haveminmax <- TRUE x@data@inmemory <- TRUE } if (bind) { x@data@values <- cbind(x@data@values, values) x@data@nlayers <- as.integer(x@data@nlayers + 1) } else { x@data@values[,layer] <- values } rge <- range(values, na.rm=TRUE) x@data@min[layer] <- rge[1] x@data@max[layer] <- rge[2] } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='setValues',) r <- brick(x) nc <- ncol(x) if (bind) { r@data@nlayers <- as.integer(r@data@nlayers + 1) r <- writeStart(r, filename=rasterTmpFile(), format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- cbind(v, values[cellFromRowCol(x, tr$row[i], 1):cellFromRowCol(x, tr$row[i]+tr$nrows[i]-1, nc)]) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { r <- writeStart(r, filename=rasterTmpFile(), format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v[, layer] <- values[cellFromRowCol(x, tr$row[i], 1):cellFromRowCol(x, tr$row[i]+tr$nrows[i]-1, nc)] r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) return(r) } } } else { stop("length(values) is not equal to ncell(x)") } } return(x) } ) setMethod('setValues', signature(x='RasterLayerSparse'), function(x, values, index=NULL, ...) { stopifnot(is.vector(values)) if (!(is.numeric(values) | is.integer(values) | is.logical(values))) { stop('values must be numeric, integer or logical.') } if (is.null(index)) { if (! hasValues(x)) { stop('you must supply an index argument if the RasterLayerSparse does not have values') } stopifnot(length(x@index) == length(values)) } else { stopifnot(is.vector(index)) stopifnot(length(index) == length(values)) stopifnot(all(index > 0 | index <= ncell(x))) x@index <- index } x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@file@name <- "" x@file@driver <- "" x@data@values <- values x <- setMinMax(x) return(x) } ) raster/R/zzz.R0000644000176200001440000000067014507510157012743 0ustar liggesusers loadModule("spmod", TRUE) #.onLoad <- function(lib, pkg) { # pkg.info <- utils::packageDescription('raster') # packageStartupMessage(paste("raster ", pkg.info[["Version"]], " (", pkg.info["Date"], ")", sep="")) # wd <- getwd() # options('startup.working.directory'=wd) # fn <- paste(wd, '/rasterOptions_', pkg.info[["Version"]], sep='') # .loadOptions(fn) # try( removeTmpFiles( .tmptime() ), silent=TRUE ) # return(invisible(0)) #} raster/R/scale.R0000644000176200001440000000140514507510157013172 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 setMethod('scale', signature('Raster'), function(x, center=TRUE, scale=TRUE) { if (canProcessInMemory(x)) { v <- values(x) x <- setValues(x, scale(v, center=center, scale=scale)) return(x) } if (!is.logical(center)) { stopifnot(length(center) == nlayers(x)) x <- x - center } else if (center) { m <- cellStats(x, 'mean', na.rm=TRUE) x <- x - m } if (!is.logical(scale)) { stopifnot(length(scale) == nlayers(x)) x <- x / scale } else if (scale) { if (center[1] & is.logical(center[1])) { st <- cellStats(x, 'sd', na.rm=TRUE) } else { st <- cellStats(x, 'rms', na.rm=TRUE) } x <- x / st } x } ) raster/R/extractPolygons.R0000644000176200001440000002424314507510157015315 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='SpatialPolygons'), function(x, y, fun=NULL, na.rm=FALSE, exact=FALSE, weights=FALSE, normalizeWeights=TRUE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...){ #px <-.getCRS(x, asText=FALSE) px <-.getCRS(x) comp <- compareCRS(px,.getCRS(y), unknown=TRUE) if (!comp) { #.requireRgdal() warning('Transforming SpatialPolygons to the crs of the Raster') y <- sp::spTransform(y, px) } spbb <- sp::bbox(y) rsbb <- bbox(x) addres <- max(res(x)) npol <- length(y@polygons) res <- list() res[[npol+1]] <- NA if (!is.null(fun)) { cellnumbers <- FALSE if (weights || exact) { if (!is.null(fun)) { fun <- match.fun(fun) test <- try(methods::slot(fun, 'generic') == 'mean', silent=TRUE) if (!isTRUE(test)) { warning('"fun" was changed to "mean"; other functions cannot be used when "weights=TRUE"' ) } } fun <- function(x, ...) { # some complexity here because different layers could # have different NA cells if ( is.null(x) ) { return(rep(NA, nl)) } w <- x[,nl+1] x <- x[,-(nl+1), drop=FALSE] x <- x * w w <- matrix(rep(w, nl), ncol=nl) w[is.na(x)] <- NA w <- colSums(w, na.rm=TRUE) x <- apply(x, 1, function(X) { X / w } ) if (!is.null(dim(x))) { rowSums(x, na.rm=na.rm) } else { sum(x, na.rm=na.rm) } } } if (sp) { df <- TRUE } doFun <- TRUE } else { if (sp) { sp <- FALSE df <- FALSE warning('argument sp=TRUE is ignored if fun=NULL') #} else if (df) { # df <- FALSE # warning('argument df=TRUE is ignored if fun=NULL') } doFun <- FALSE } if (missing(layer)) { layer <- 1 } else { layer <- max(min(nlayers(x), layer), 1) } if (missing(nl)) { nl <- nlayers(x) - layer + 1 } else { nl <- max(min(nlayers(x)-layer+1, nl), 1) } if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { if (df) { res <- data.frame(matrix(ncol=1, nrow=0)) colnames(res) <- 'ID' return(res) } return(res[1:npol]) } rr <- raster(x) pb <- pbCreate(npol, label='extract', ...) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(npol, length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() .sendCall <- eval( parse( text="parallel:::sendCall") ) parallel::clusterExport(cl, c('rsbb', 'rr', 'weights', 'exact', 'addres', 'cellnumbers', 'small'), envir=environment()) clFun <- function(i, pp) { spbb <- sp::bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) if (normalizeWeights) { weight <- xy[,3] / sum(xy[,3]) } else { weight <- xy[,3] #/ 100 } xy <- xy[, -3, drop=FALSE] } else if (exact) { erc <- crop(x, rc) xy <- exactextractr::exact_extract(erc, pp, include_cell=cellnumbers, progress=FALSE)[[1]] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) r <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch very small polygons if (exact) { if (weights) { if (normalizeWeights) { xy$coverage_fraction <- xy$coverage_fraction / sum(xy$coverage_fraction) } colnames(xy)[ncol(xy)] <- "weight" } else { xy$coverage_fraction <- NULL } if (cellnumbers) { nms <- colnames(xy) # not good if there is a layer called cell nms <- c("cell", nms[nms != "cell"]) xy <- xy[,nms] } r <- as.matrix(xy) } else { r <- .xyValues(x, xy, layer=layer, nl=nl) if (weights) { if (cellnumbers) { cell <- cellFromXY(x, xy) r <- cbind(cell, r, weight) } else { r <- cbind(r, weight) } } else if (cellnumbers) { cell <- cellFromXY(x, xy) r <- cbind(cell, r) } } } else { if (small) { ppp <- pp@polygons[[1]]@Polygons ishole <- sapply(ppp, function(z)z@hole) xy <- lapply(ppp, function(z)z@coords) xy <- xy[!ishole] if (length(xy) > 0) { cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z)), use.names = FALSE)) value <- .cellValues(x, cell, layer=layer, nl=nl) if (weights | exact) { weight=rep(1/NROW(value), NROW(value)) if (cellnumbers) { r <- cbind(cell, value, weight) } else { r <- cbind(value, weight) } } else if (cellnumbers) { r <- cbind(cell, value) } else { r <- value } } else { r <- NULL } } else { r <- NULL } } } r } for (ni in 1:nodes) { .sendCall(cl[[ni]], clFun, list(ni, y[ni,]), tag=ni) } for (i in 1:npol) { d <- .recvOneData(cl) if (! d$value$success) { stop('cluster error at polygon: ', i) } if (doFun) { if (!is.null(d$value$value)) { if (nl > 1 & !(weights | exact)) { res[[d$value$tag]] <- apply(d$value$value, 2, fun, na.rm=na.rm) } else { res[[d$value$tag]] <- fun(d$value$value, na.rm=na.rm) } } } else { res[[d$value$tag]] <- d$value$value } ni <- ni + 1 if (ni <= npol) { .sendCall(cl[[d$node]], clFun, list(ni, y[ni,]), tag=ni) } pbStep(pb, i) } } else { for (i in 1:npol) { pp <- y[i,] spbb <- sp::bbox(pp) if (spbb[1,1] >= rsbb[1,2] | spbb[1,2] <= rsbb[1,1] | spbb[2,1] >= rsbb[2,2] | spbb[2,2] <= rsbb[2,1]) { # do nothing; res[[i]] <- NULL } else { rc <- crop(rr, extent(pp)+addres) if (exact) { #erc <- crop(x, rc) xy <- exactextractr::exact_extract(x, pp, include_cell=cellnumbers, progress=FALSE)[[1]] } else if (weights) { rc <- .polygonsToRaster(pp, rc, getCover=TRUE, silent=TRUE) rc[rc==0] <- NA xy <- rasterToPoints(rc) if (normalizeWeights) { weight <- xy[,3] / sum(xy[,3]) } else { weight <- xy[,3] #/ 100 } xy <- xy[,-3,drop=FALSE] } else { rc <- .polygonsToRaster(pp, rc, silent=TRUE) xy <- rasterToPoints(rc)[,-3,drop=FALSE] } if (length(xy) > 0) { # catch holes or very small polygons if (exact) { if (weights) { if (normalizeWeights) { xy$coverage_fraction <- xy$coverage_fraction / sum(xy$coverage_fraction) } colnames(xy)[ncol(xy)] <- "weight" } else { xy$coverage_fraction <- NULL } if (cellnumbers) { nms <- colnames(xy) # not good if there is a layer called cell nms <- c("cell", nms[nms != "cell"]) xy <- xy[,nms] } if (ncol(xy) == 1) { res[[i]] <- unlist(xy, use.names =FALSE) } else { res[[i]] <- as.matrix(xy) } } else if (weights) { value <- .xyValues(x, xy, layer=layer, nl=nl) if (cellnumbers) { cell <- cellFromXY(x, xy) res[[i]] <- cbind(cell, value, weight) } else { res[[i]] <- cbind(value, weight) } } else if (cellnumbers) { value <- .xyValues(x, xy, layer=layer, nl=nl) cell <- cellFromXY(x, xy) res[[i]] <- cbind(cell, value) } else { res[[i]] <- .xyValues(x, xy, layer=layer, nl=nl) } } else if (small) { ppp <- pp@polygons[[1]]@Polygons ishole <- sapply(ppp, function(z)z@hole) xy <- lapply(ppp, function(z)z@coords) xy <- xy[!ishole] if (length(xy) > 0) { cell <- unique(unlist(lapply(xy, function(z) cellFromXY(x, z))), use.names = FALSE) value <- .cellValues(x, cell, layer=layer, nl=nl) if (weights | exact) { weight <- rep(1/NROW(value), NROW(value)) if (cellnumbers) { res[[i]] <- cbind(cell, value, weight) } else { res[[i]] <- cbind(value, weight) } } else if (cellnumbers) { res[[i]] <- cbind(cell, value) } else { res[[i]] <- value } } # else do nothing; res[[i]] <- NULL } if (doFun) { if (!is.null(res[[i]])) { if (nl > 1 & !(weights | exact)) { res[[i]] <- apply(res[[i]], 2, fun, na.rm=na.rm) } else { res[[i]] <- fun(res[[i]], na.rm=na.rm) } } } } pbStep(pb) } } res <- res[1:npol] pbClose(pb) if (! is.null(fun)) { # try to simplify i <- sapply(res, length) if (length(unique(i[i != 0])) == 1) { if (any(i == 0)) { lng <- length(res) v <- do.call(rbind, res) res <- matrix(NA, nrow=lng, ncol=ncol(v)) res[which(i > 0), ] <- v } else { res <- do.call(rbind, res) } } else { if (sp) { warning('cannot return a sp object because the data length varies between polygons') sp <- FALSE df <- FALSE #} else if (df) { #warning('cannot return a data.frame because the data length varies between polygons') #df <- FALSE } } } if (df) { if (!is.list(res)) { res <- data.frame(ID=1:NROW(res), res) } else { res <- data.frame( do.call(rbind, lapply(1:length(res), function(x) if (!is.null(res[[x]])) cbind(x, res[[x]]))) ) } lyrs <- layer:(layer+nl-1) if (cellnumbers) { nms <- c('ID', 'cell', names(x)[lyrs]) } else { nms <- c('ID', names(x)[lyrs]) } if ((weights) & is.null(fun)) { nms <- c(nms, 'weight') } colnames(res) <- nms if (any(is.factor(x)) & factors) { i <- ifelse(cellnumbers, 1:2, 1) v <- res[, -i, drop=FALSE] if (ncol(v) == 1) { v <- data.frame(factorValues(x, v[,1], layer)) } else { v <- .insertFacts(x, v, lyrs) } res <- data.frame(res[,i,drop=FALSE], v) } } if (sp) { if (nrow(res) != npol) { warning('sp=TRUE is ignored because fun does not summarize the values of each polygon to a single number') return(res) } if (!.hasSlot(y, 'data') ) { y <- sp::SpatialPolygonsDataFrame(y, res[, -1, drop=FALSE]) } else { y@data <- cbind(y@data, res[, -1, drop=FALSE]) } return(y) } res } ) raster/R/extract.R0000644000176200001440000000054014507510157013554 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='Raster', y='vector'), function(x, y, ...){ y <- round(y) return( .cellValues(x, y, ...) ) }) setMethod('extract', signature(x='Raster', y='sf'), function(x, y, ...){ y <- .sf2sp(y) #if (is.list(x)) {} extract(x, y, ...) } ) raster/R/speasy.R0000644000176200001440000000243314507510157013411 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2015 # Version 1.0 # Licence GPL v3 # easy functions for creating SpatialLines* and SpatialPolygons* spLines <- function(x, ..., attr=NULL, crs="") { x <- c(list(x), list(...)) x <- rapply(x, sp::Line, how='replace') x <- lapply(1:length(x), function(i) sp::Lines(x[[i]], as.character(i))) x <- sp::SpatialLines(x) if (!is.null(attr)) { if (nrow(attr) == length(x)) { x <- sp::SpatialLinesDataFrame(x, attr) } else { msg <- paste('number of rows in attr (', nrow(attr), ') does not match the number of lines (', length(x), ')', sep='') stop(msg) } } if (!is.na(crs)) { crs(x) <- crs } x } spPolygons <- function(x, ..., attr=NULL, crs="") { x <- c(list(x), list(...)) x <- rapply(x, sp::Polygon, how='replace') x <- lapply(1:length(x), function(i) { if (length(x[[i]]) == 1) { sp::Polygons(x[i], as.character(i)) } else { sp::Polygons(x[[i]], as.character(i)) } }) x <- sp::SpatialPolygons(x) if (!is.null(attr)) { if (nrow(attr) == length(x)) { x <- sp::SpatialPolygonsDataFrame(x, attr) } else { msg <- paste('number of rows in attr (', nrow(attr), ') does not match the number of polygons (', length(x), ')', sep='') stop(msg) } } if (!is.na(crs)) { crs(x) <- crs } x } raster/R/makeProjString.R0000644000176200001440000000337614507510157015053 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .newCRS <- function(projs) { if (is.null(projs)) { prj <- sp::CRS() } else if (is.na(projs)) { prj <- sp::CRS() } else if (nchar(projs) < 3) { prj <- sp::CRS() } else { projs <- trim(projs) prj <- try(sp::CRS(projs), silent = TRUE) if (inherits(prj, "try-error")) { warning(paste(projs, 'is not a valid PROJ.4 crs string')) prj <- sp::CRS() } } return(prj) } # .makeProj <- function(projection='longlat', ..., ellipsoid="", datum="", asText=TRUE) { # prj <- rgdal::projInfo("proj") # ell <- rgdal::projInfo("ellps") # dat <- rgdal::projInfo("datum") # projection <- trim(projection) # ellipsoid <- trim(ellipsoid) # datum <- trim(datum) # if (!(projection %in% prj[,1])) { # stop("unknown projection. See rgdal::projInfo()") # } else { # pstr <- paste('+proj=',projection, sep="") # projname <- as.vector(prj[which(prj[,1]==projection), 2]) # } # pargs <- list(...) # if ( length(pargs) > 0 ) { # for (i in 1:length(pargs)) { # pstr <- paste(pstr, ' +', pargs[[i]], sep="") # } # } # if (ellipsoid != "") { # if (!(ellipsoid %in% ell[,1])) { # stop("unknown ellipsoid. See rgdal::projInfo('ellps')") # } else { # pstr <- paste(pstr, " +ellps=", ellipsoid, sep="") # # ellipname <- ell[which(ell[,1]==ellipsoid), 2] # } # } # if (datum != "") { # if (!(datum %in% dat[,1])) { # stop("unknown datum. See rgdal::projInfo('datum')") # } else { # pstr <- paste(pstr, " +datum=", datum, sep="") # # datumname <- as.vector(dat[which(dat[,1]==datum), 2]) # } # } # # cat("Projection: ", projname[1], "\n") # crs <- .newCRS(pstr) # if (asText) { # return(trim(crs@projargs)) # } else { # return(crs) # } # } raster/R/newPLot.R0000644000176200001440000001275114507510157013501 0ustar liggesusers# The functions below here were adapted from the functions in the fields package! (image.plot and subroutines) # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html # Adaptations for the raster package: # Author: Robert J. Hijmans # Date : May 2010 # Version 1.0 # Licence GPL v3 .plotSpace <- function(asp=1, legend.mar = 3.1, legend.width = 0.5, legend.shrink = 0.5) { pars <- graphics::par() char.size <- pars$cin[1] / pars$din[1] offset <- char.size * pars$mar[4] legend.width <- char.size * legend.width legend.mar <- legend.mar * char.size legendPlot <- pars$plt legendPlot[2] <- 1 - legend.mar legendPlot[1] <- legendPlot[2] - legend.width pr <- (legendPlot[4] - legendPlot[3]) * ((1 - legend.shrink)/2) legendPlot[4] <- legendPlot[4] - pr legendPlot[3] <- legendPlot[3] + pr bp <- pars$plt bp[2] <- min(bp[2], legendPlot[1] - offset) aspbp = (bp[4]-bp[3]) / (bp[2]-bp[1]) adj = aspbp / asp if (adj < 1) { adjust = (bp[4]-bp[3]) - ((bp[4]-bp[3]) * adj) } else { adjust = (bp[4]-bp[3]) / adj - ((bp[4]-bp[3])) } adjust <- adjust / 2 bp[3] <- bp[3] + adjust bp[4] <- bp[4] - adjust dp <- legendPlot[2] - legendPlot[1] legendPlot[1] <- min(bp[2] + 0.5 * offset, legendPlot[1]) legendPlot[2] <- legendPlot[1] + dp return(list(legendPlot = legendPlot, mainPlot = bp)) } .plotLegend <- function(z, col, legend.at='classic', lab.breaks = NULL, axis.args = NULL, legend.lab = NULL, legend.args = NULL, ...) { horizontal=FALSE ix <- 1 zlim <- range(z, na.rm = TRUE, finite=TRUE) zrange <- zlim[2]-zlim[1] if (zrange > 10) { decs <- 0 } else if (zrange > 1) { decs <- 1 } else { decs <- ceiling(abs(log10(zrange)) + 1) } pow <- 10^decs minz <- floor(zlim[1] * pow) / pow maxz <- ceiling(zlim[2] * pow) / pow zrange <- maxz - minz nlevel = length(col) binwidth <- c(0, 1:nlevel * (1/nlevel)) iy <- minz + zrange * binwidth # binwidth <- 1 + (maxz - minz)/nlevel # iy <- seq(minz, maxz, by = binwidth) iz <- matrix(iy, nrow = 1, ncol = length(iy)) breaks <- list(...)$breaks if (!is.null(breaks) & !is.null(lab.breaks)) { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { if (legend.at == 'quantile') { z <- z[is.finite(z)] at = stats::quantile(z, names=F, na.rm=TRUE) axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args) # at <- c(0, 1:5 * (1/5)) # at <- minz + zrange * at } else { at <- graphics::axTicks(2, c(minz, maxz, 4)) } at <- round(at, decs) axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at=at), axis.args) } if (!horizontal) { if (is.null(breaks)) { image(ix, iy, iz, xaxt="n", yaxt="n", xlab = "", ylab = "", col = col) } else { image(ix, iy, iz, xaxt="n", yaxt="n", xlab = "", ylab = "", col = col, breaks = breaks) } } else { if (is.null(breaks)) { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col) } else { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, breaks = breaks) } } axis.args = c(axis.args, cex.axis=0.75, tcl=-0.15, list(mgp=c(3, 0.4, 0)) ) do.call("axis", axis.args) #graphics::axis(axis.args$side, at=min(iz), las=ifelse(horizontal, 0, 2)) graphics::box() # title(main = list(legend.lab, cex=1, font=1)) if (!is.null(legend.lab)) { # graphics::mtext(legend.lab, side=3, line=0.75) #legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) legend.args <- list(text = legend.lab, side=3, line=0.75) } if (!is.null(legend.args)) { #do.call(graphics::mtext, legend.args) } } .plot2 <- function(x, maxpixels=100000, col=rev(terrain.colors(25)), xlab='', ylab='', asp, box=TRUE, add=FALSE, legend=TRUE, legend.at='', ...) { if (!add & missing(asp)) { if (couldBeLonLat(x)) { ym <- mean(x@extent@ymax + x@extent@ymin) asp <- min(5, 1/cos((ym * pi)/180)) } else { asp = 1 } } plotArea <- .plotSpace(asp) x <- sampleRegular(x, maxpixels, asRaster=TRUE, useGDAL=TRUE) xticks <- graphics::axTicks(1, c(xmin(x), xmax(x), 4)) yticks <- graphics::axTicks(2, c(ymin(x), ymax(x), 4)) if (xres(x) %% 1 == 0) xticks = round(xticks) if (yres(x) %% 1 == 0) yticks = round(yticks) y <- yFromRow(x, nrow(x):1) z <- t((getValues(x, format='matrix'))[nrow(x):1,]) x <- xFromCol(x,1:ncol(x)) if (add) { image(x=x, y=y, z=z, col=col, axes=FALSE, xlab=xlab, ylab=ylab, add=TRUE, ...) } else { if (legend) { graphics::par(pty = "m", plt=plotArea$legendPlot, err = -1) .plotLegend(z, col, legend.at=legend.at, ...) graphics::par(new=TRUE, plt=plotArea$mainPlot) } image(x=x, y=y, z=z, col=col, axes=FALSE, xlab=xlab, ylab=ylab, asp=asp, ...) graphics::axis(1, at=xticks, cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.25, 0)) las = ifelse(max(nchar(as.character(yticks)))> 5, 0, 1) graphics::axis(2, at=yticks, las = las, cex.axis=0.67, tcl=-0.3, mgp=c(3, 0.75, 0) ) #graphics::axis(3, at=xticks, labels=FALSE, lwd.ticks=0) #graphics::axis(4, at=yticks, labels=FALSE, lwd.ticks=0) if (box) graphics::box() } } #.plot2(r, legend=T) # .plot2(r, legend.at='quantile') # plot(wrld_simpl, add=T) raster/R/frbind.R0000644000176200001440000000260514507510157013352 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 # friendly rbind # rbinds data.frames with different column names .frbind <- function(x, ...) { if (! inherits(x, 'data.frame') ) { x <- data.frame(x) } d <- list(...) if (length(d) == 0) { return(x) } for (i in 1:length(d)) { dd <- d[[i]] if (! inherits(dd, 'data.frame')) { dd <- data.frame(dd) } cnx <- colnames(x) cnd <- colnames(dd) e <- cnx[(cnx %in% cnd)] for (j in e) { if (all(class(x[,j]) != class(dd[,j]))) { x[,j] <- as.character(x[,j]) dd[,j] <- as.character(dd[,j]) } } a <- which(!cnd %in% cnx) if (length(a) > 0) { zz <- dd[NULL, a, drop=FALSE] zz[1:nrow(x),] <- NA x <- cbind(x, zz) } b <- which(!cnx %in% cnd) if (length(b) > 0) { zz <- x[NULL, b, drop=FALSE] zz[1:nrow(dd),] <- NA dd <- cbind(dd, zz) } x <- rbind(x, dd) } x } .frbindMatrix <- function(x, ...) { d <- list(...) if (length(d) == 0) { return(x) } for (i in 1:length(d)) { dd <- d[[i]] cnx <- colnames(x) cnd <- colnames(dd) a <- which(!cnd %in% cnx) if (length(a) > 0) { zz <- dd[NULL, a, drop=FALSE] zz[1:nrow(x),] <- NA x <- cbind(x, zz) } b <- which(!cnx %in% cnd) if (length(b) > 0) { zz <- x[NULL, b, drop=FALSE] zz[1:nrow(dd),] <- NA dd <- cbind(dd, zz) } x <- rbind(x, dd) } x } raster/R/netCDFutil.R0000644000176200001440000001063114507510157014105 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .getCRSfromGridMap4 <- function(g) { if (!is.null(g$epsg_code)) { crs <- g$epsg_code if (!grep("EPSG:", crs, ignore.case=TRUE)) { crs <- paste0("epsg:", crs) } return(crs) } sp <- g$standard_parallel if (length(sp) > 1) { g$standard_parallel1 <- sp[1] g$standard_parallel2 <- sp[2] g$standard_parallel <- NULL } vals <- sapply(g, function(i) i[1]) vars <- names(vals) if (any(vars %in% c("proj4", "crs_wkt", "spatial_ref"))) { crs=vals[vars %in% c("proj4", "crs_wkt", "spatial_ref")][1] return(crs) } # based on info at # http://trac.osgeo.org/gdal/wiki/NetCDF_ProjectionTestingStatus # accessed 7 October 2012 prj <- matrix(c("albers_conical_equal_area", "aea", "azimuthal_equidistant", "aeqd", "lambert_cylindrical_equal_area", "cea", "lambert_azimuthal_equal_area", "laea", "lambert_conformal_conic", "lcc", "latitude_longitude", "longlat", "mercator", "merc", "orthographic", "ortho", "polar_stereographic", "stere", "stereographic", "stere", "transverse_mercator", "tmerc"), ncol=2, byrow=TRUE) m <- matrix(c("grid_mapping_name", "+proj", "false_easting", "+x_0","false_northing", "+y_0", "scale_factor_at_projection_origin", "+k_0", "scale_factor_at_central_meridian", "+k_0", "standard_parallel", "+lat_1", "standard_parallel1", "+lat_1", "standard_parallel2", "+lat_2", "longitude_of_central_meridian", "+lon_0", "longitude_of_projection_origin", "+lon_0", "latitude_of_projection_origin", "+lat_0", "straight_vertical_longitude_from_pole", "+lon_0", "longitude_of_prime_meridian", "+pm", "semi_major_axis", "+a", "semi_minor_axis", "+b", "inverse_flattening", "+rf", "earth_radius", "+a"), ncol=2, byrow=TRUE) # add logic that if prime merid is defined but not centr merid. centr merid is same as prime. i <- match(vars, m[,1]) if (all(is.na(i))) { gg <- cbind(vars, vals) mtxt <- paste(apply(gg, 1, function(x) paste(x, collapse='=')), collapse='; ') warning("cannot process the crs\n", mtxt) return(NA) } else if (any(is.na(i))) { vr <- vars[is.na(i)] vl <- vals[is.na(i)] gg <- cbind(vr, vl) gg <- gg[!(gg[,1] %in% c("crs_wkt", "esri_pe_string")), ,drop=FALSE] if (NROW(gg) > 0) { mtxt <- paste(apply(gg, 1, function(x) paste(x, collapse='=')), collapse='\n') warning("cannot process these parts of the crs:\n", mtxt) } vars <- vars[!is.na(i)] vals <- vals[!is.na(i)] i <- stats::na.omit(i) } tab <- cbind(m[i,], vals) rr <- which(tab[,1] == "earth_radius") if (length(rr) > 0) { bb <- tab[rr,] bb[2] <- "+b" tab <- rbind(tab, bb) } p <- which(tab[,2] == '+proj') if (length(p) == 0) { warning("cannot create a valid crs\n", mtxt) return(NA) } else { tab <- rbind(tab[p, ], tab[-p, ]) } j <- match(tab[1,3], prj[,1]) tab[1,3] <- prj[j,2] cr <- paste(apply(tab[,2:3], 1, function(x) paste(x, collapse='=')), collapse=' ') crtst <- try(sp::CRS(cr), silent=TRUE) if ( inherits(crtst, "try-error")) { mtxt <- paste(m, collapse='; ') warning("cannot create a valid crs\n", mtxt) return(NA) } else { return(cr) } } .isNetCDF <- function(x) { fcon <- file(x, "rb") suppressWarnings( tst <- try( w <- readBin(fcon, what='character', n=1), silent=TRUE) ) close(fcon) if ( isTRUE((substr(w, 1, 3) == "CDF" ))) { return(TRUE) } else { return(FALSE) } } .getRasterDTypeFromCDF <- function(type) { if (type == "char" ) { return("INT1U") } else if (type == "byte" ) { return("INT1S") } else if (type == "short" ) { return("INT2S") } else if (type == "int" ) { return("INT4S") } else if (type == "integer" ) { return("INT4S") } else if (type == "float" ) { return("FLT4S") } else if (type =="double" ) { return("FLT8S") } else { return("FLT4S") } } .getNetCDFDType <- function(dtype) { if (!(dtype %in% c('LOG1S', 'INT1S', 'INT2S', 'INT4S', 'INT1U', 'INT2U', 'FLT4S', 'FLT8S'))) { stop('not a valid data type') } type <- .shortDataType(dtype) size <- dataSize(dtype) * 8 signed <- dataSigned(dtype) if (size == 8) { if (!signed) { return("char") #8-bit characters intended for representing text. } else { return("byte") } } else if (type == 'INT') { if (!signed) { warning('netcdf only stores signed integers') } if (size == 16) { return( "short" ) } else if (size == 32 ) { return( "integer" ) } else { return ( "double" ) } } else { if (size == 32) { return( "float" ) } else { return ( "double" ) } } } raster/R/distance.R0000644000176200001440000000476314507510157013707 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('distance', signature(x='RasterLayer', y='missing'), function(x, y, filename='', doEdge=TRUE, ...) { if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (inherits(pts, "try-error")) { return( .distanceRows(x, filename=filename, ...) ) } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a distance)') } out <- raster(x) filename <- trim(filename) if (couldBeLonLat(x)) { longlat=TRUE } else { longlat=FALSE } if (canProcessInMemory(out, 6)) { pb <- pbCreate(3, label='distance', ...) x <- values(x) i <- which(is.na(x)) if (length(i) < 1) { stop('raster has no NA values to compute distance to') } pbStep(pb) x[] <- 0 xy <- xyFromCell(out, i) x[i] <- .Call('_raster_distanceToNearestPoint', xy, pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') pbStep(pb) out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='distance', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- 0 if (length(j) > 0) { vals[j] <- .Call('_raster_distanceToNearestPoint', xy[j,,drop=FALSE], pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') } out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) setMethod('distance', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ...) { stats::dist(as.matrix(stack(x, y))) } ) setMethod('distance', signature(x='Spatial', y='Spatial'), function(x, y, ...) { # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # stopifnot(inherits(x, 'SpatialVector')) # stopifnot(inherits(y, 'SpatialVector')) # d <- rgeos::gDistance(x, y, byid=TRUE) # apply(d, 1, min) x = vect(x) y = vect(y) distance(x, y) } ) raster/R/shift.R0000644000176200001440000000264714507510157013231 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod('shift', signature(x='Raster'), function(x, dx=0, dy=0, filename='', ...) { dx <- as.numeric(dx[1]) dy <- as.numeric(dy[1]) stopifnot(!is.na(dx) | !is.na(dy)) e <- x@extent e@xmin <- e@xmin + dx e@ymin <- e@ymin + dy e@xmax <- e@xmax + dx e@ymax <- e@ymax + dy x@extent <- e if (filename != '') { x <- writeRaster(x, filename=filename, ...) } if (inherits(x, 'RasterStack')) { x@layers <- sapply(x@layers, function(i){ extent(i) <- e; i}) } return(x) } ) setMethod('shift', signature(x='SpatialPolygons'), function(x, dx=0, dy=0, ...) { a <- data.frame(geom(x)) a$x <- a$x + dx a$y <- a$y + dy a <- as(a, 'SpatialPolygons') crs(a) <- crs(x) if (inherits(x, 'SpatialPolygonsDataFrame')) { a <- sp::SpatialPolygonsDataFrame(a, x@data, match.ID = FALSE) } return(a) } ) setMethod('shift', signature(x='SpatialLines'), function(x, dx=0, dy=0, ...) { a <- data.frame(geom(x)) a$x <- a$x + dx a$y <- a$y + dy a <- as(a, 'SpatialLines') crs(a) <- crs(x) if (inherits(x, 'SpatialLinesDataFrame')) { a <- sp::SpatialLinesDataFrame(a, x@data, match.ID = FALSE) } return(a) } ) setMethod('shift', signature(x='SpatialPoints'), function(x, dx=0, dy=0, ...) { x@coords[,1] <- x@coords[,1] + dx x@coords[,2] <- x@coords[,2] + dy return(x) } ) raster/R/dataProperties.R0000644000176200001440000000306314507510157015073 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 #dataSize <- function(object) {return(object@file@datasize)} dataSize <- function(object) { if (!inherits(object, 'character')) { object <- dataType(object) } return( as.integer (substr(object, 4, 4)) ) } dataSigned <- function(object) { if (!inherits(object, 'character')) { object <- dataType(object) } ifelse(substr(object, 5, 5) == 'U', FALSE, TRUE ) } .shortDataType <- function(object) { if (!inherits(object, 'character')){ object <- dataType(object) } return( substr(object, 1, 3)) } dataType <- function(x) { if (inherits(x, 'RasterStack')) { return(sapply(x@layers, function(x) x@file@datanotation)) } else { return(x@file@datanotation) } } ..dataIndices <- function(object) { # return(object@data@indices) } fromDisk <- function(x) { if (inherits( x, 'RasterStack' )) { return( all( sapply( x@layers, function(x) x@data@fromdisk ))) } else { return( x@data@fromdisk ) } } setMethod("inMemory", signature(x="BasicRaster"), function(x) { if (inherits( x, 'RasterStack' )) { return( all( sapply( x@layers, function(x) x@data@inmemory ))) } else if (inherits(x, "Raster")) { return( x@data@inmemory ) } else { TRUE } } ) setMethod("hasValues", signature(x="BasicRaster"), function(x) { if (inherits(x, 'RasterStack')) { if (nlayers(x) > 0) return(TRUE) else return(FALSE) } else if (inherits(x, "Raster")) { if ( fromDisk(x) | inMemory(x) ) { return(TRUE) } else { return(FALSE) } } else { FALSE } } ) raster/R/kml_multiple.R0000644000176200001440000000723714507510157014612 0ustar liggesusers# Derived from functions GE_SpatialGrid and kmlOverlay # in the maptools package by Duncan Golicher, David Forrest and Roger Bivand # Adaptation for the raster package by Robert J. Hijmans # Date : October 2011 # Version 0.9 # Licence GPL v3 .zipKML <- function(kml, image, zip, overwrite=FALSE) { if (zip == "") { zip <- Sys.getenv('R_ZIPCMD', 'zip') } if (zip != "") { wd <- getwd() on.exit( setwd(wd) ) setwd(dirname(kml)) kml <- basename(kml) kmz <- extension(kml, '.kmz') if (file.exists(kmz)) { if (overwrite) { file.remove(kmz) } else { stop('kml file created, but kmz file exists, use "overwrite=TRUE" to overwrite it') } } image <- basename(image) if (zip=='7z') { kmzzip <- extension(kmz, '.zip') cmd <- paste(zip, 'a', kmzzip, kml, image, collapse=" ") file.rename(kmzzip, kmz) } else { cmd <- paste(c(zip, kmz, kml, image), collapse=" ") } sss <- try( system(cmd, intern=TRUE), silent=TRUE ) if (file.exists(kmz)) { files <- c(kml, image) files <- files[file.exists(files)] x <- file.remove(files) return(invisible(kmz)) } else { return(invisible(kml)) } } else { return(invisible(kml)) } } setMethod('KML', signature(x='RasterStackBrick'), function (x, filename, time=NULL, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) { if (! couldBeLonLat(x)) { stop("CRS of x must be longitude/latitude") } stopifnot(hasValues(x)) if (missing(filename)) { filename <- extension(basename(rasterTmpFile('G_')), '.kml') } nl <- nlayers(x) if (is.null(time)) { dotime <- FALSE atime <- time } else { dotime <- TRUE if (length(time) == nl) { when <- TRUE } else if (length(time) == nl+1) { when <- FALSE } else { stop('length(time) should equall nlayers(x) for "when", or (nlayers(x)+1) for "begin-end"') } } x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE) kmlfile <- filename extension(kmlfile) <- '.kml' if (file.exists(kmlfile)) { if (overwrite) { file.remove(kmlfile) } else { stop('kml file exists, use "overwrite=TRUE" to overwrite it') } } name <- names(x) kml <- c('', '') kml <- c(kml, c("", paste("", extension(basename(filename), ''), "", sep=''))) e <- extent(x) latlonbox <- c("\t", paste("\t\t", e@ymax, "", e@ymin, "", e@xmax, "", e@xmin, "", sep = ""), "\t", "") imagefile <- paste(extension(filename, ''), "_", 1:nl, ".png", sep="") for (i in 1:nl) { grDevices::png(filename = imagefile[i], width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg="transparent") if (!is.na(colNA)) { graphics::par(mar=c(0,0,0,0), bg=colNA) } else { graphics::par(mar=c(0,0,0,0)) } image(x[[i]], col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...) grDevices::dev.off() a <- c("", paste("\t", name[i], "", sep='')) if (dotime) { if (when) { atime <- c("\t", paste("\t\t", time[i], "", sep=''), "\t") } else { atime <- c("\t", paste("\t\t", time[i], "", sep=''), paste("\t\t", time[i+1], "", sep=''), "\t") } } kml <- c(kml, a, atime, paste("\t", basename(imagefile[i]), "", sep=''), latlonbox) } kml <- c(kml, "", "") cat(paste(kml, sep="", collapse="\n"), file=kmlfile, sep = "") .zipKML(kmlfile, imagefile, zip, overwrite=overwrite) } ) raster/R/compareCRS.R0000644000176200001440000000261414507510157014104 0ustar liggesusers# author Robert Hijmans # June 2010 # version 1.0 # license GPL3 .compareCRS <- function(...) { warning('use "compareCRS", not ".compareCRS"') compareCRS(...) } # see sp:identicalCRS(x, y) compareCRS <- function(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) { x <- tolower(projection(x)) y <- tolower(projection(y)) step1 <- function(z) { z <- gsub(' ', '', z) if (!verbatim) { z <- unlist( strsplit(z, '+', fixed=TRUE) )[-1] z <- do.call(rbind, strsplit(z, '=')) } z } if (verbatim) { if (!is.na(x) & !is.na(y)) { return(x==y) } else { if (is.na(x) & is.na(y)) { return(TRUE) # ?? } else if (unknown) { return(TRUE) } else { return(FALSE) } } } x <- step1(x) y <- step1(y) if (length(x) == 0 & length(y) == 0) { return(TRUE) } else if (length(x) == 0 | length(y) == 0) { if (unknown) { return(TRUE) } else { if (verbose) { message('Unknown crs') } return(FALSE) } } x <- x[x[,1] != 'towgs84', , drop=FALSE] x <- x[x[,1] != 'no_defs', , drop=FALSE] x <- x[which(x[,1] %in% y[,1]), ,drop=FALSE] y <- y[which(y[,1] %in% x[,1]), ,drop=FALSE] x <- x[order(x[,1]), ,drop=FALSE] y <- y[order(y[,1]), ,drop=FALSE] i <- x[,2] == y[,2] if (! all(i)) { if (verbose) { i <- which(!i) for (j in i) { message('+',x[j,1], ': ', x[j,2],' != ', y[j,2], '\n') } } return(FALSE) } return(TRUE) } raster/R/read.R0000644000176200001440000000342614507510157013023 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("readAll")) { setGeneric("readAll", function(object) standardGeneric("readAll")) } setMethod('readAll', signature(object='RasterLayer'), function(object){ if (! object@data@fromdisk) { warning('cannot read values; there is no file associated with this RasterLayer') return(object) } object@data@values <- .readRasterLayerValues(object, 1, object@nrows) suppressWarnings(object@data@min <- as.vector( min(object@data@values, na.rm=TRUE ) )) suppressWarnings(object@data@max <- as.vector( max(object@data@values, na.rm=TRUE ) )) object@data@haveminmax <- TRUE object@data@inmemory <- TRUE object@data@fromdisk <- FALSE object@file@name <- "" return(object) } ) setMethod('readAll', signature(object='RasterStack'), function(object){ for (i in seq(nlayers(object))) { if (! object@layers[[i]]@data@inmemory ) { object@layers[[i]] <- readAll(object@layers[[i]]) # object@layers[[i]]@data@values <- .readRasterLayerValues(object@layers[[i]], 1, object@nrows) } } return(object) } ) setMethod('readAll', signature(object='RasterBrick'), function(object){ if (! object@data@fromdisk) { warning('cannot read values; there is no file associated with this RasterBrick') return(object) } object@data@values <- .readRasterBrickValues(object, 1, object@nrows) w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) rge <- apply(object@data@values, 2, FUN=function(x){ range(x, na.rm=TRUE) } ) object@data@min <- as.vector(rge[1,]) object@data@max <- as.vector(rge[2,]) object@data@haveminmax <- TRUE object@data@inmemory <- TRUE object@data@fromdisk <- FALSE object@file@name <- "" return(object) } ) raster/R/rotate.R0000644000176200001440000000240714507510157013404 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('rotate', signature(x='Raster'), function(x, filename='', ...) { e <- extent(x) if (e@xmin < -60) { warning('xmin is much smaller than zero. No rotation done') return(x) } xrange <- e@xmax - e@xmin if (xrange < 350 | xrange > 370 | e@xmin < -10 | e@xmax > 370) { if (xrange < 350 | xrange > 370 | e@xmin < -190 | e@xmax > 190) { warning('this does not look like an appropriate object for this function') } } xr <- xres(x) ext1 <- extent(-xr, 180, -100, 100) if (is.null(intersect(e, ext1 ))) { r1 <- NULL } else { r1 <- crop(x, ext1) } ext2 <- extent(180, 360+xr, -100, 100) if (is.null(intersect(e, ext2 ))) { r2 <- NULL } else { r2 <- crop(x, ext2) r2 <- shift(r2, -360) } ln <- names(x) if (is.null(r1)) { out <- r2 } else if (is.null(r2)) { out <- r1 } else { out <- merge(r1, r2, overlap=FALSE) } names(out) <- names(x) out@z <- x@z # suggested by Mike Sumner: p <- proj4string(out) if (length(grep("\\+over", p)) > 0) { projection(out) <- gsub("[[:space:]]\\+over", "", p) } if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } ) raster/R/imageplot.R0000644000176200001440000001757114507510157014077 0ustar liggesusers# The functions below here were taken from the fields package !!! (image.plot and subroutines) # to be adjusted for the RasterLayer object. # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html .imageplot <- function (x, y, z, add=FALSE, legend=TRUE, nlevel = 64, horizontal = FALSE, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html legend.shrink = 0.5, legend.width = 0.6, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, graphics.reset = FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, col = heat.colors(nlevel), lab.breaks = NULL, axis.args = NULL, legend.args = NULL, midpoint = FALSE, box=TRUE, useRaster=FALSE, ...) { zlim <- range(z, na.rm = TRUE) old.par <- graphics::par(no.readonly = TRUE) if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- .imageplotplt(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (!legend.only) { if (!add) { graphics::par(plt = bigplot) } image(x, y, z, add = add, col = col, useRaster=useRaster, ...) big.par <- graphics::par(no.readonly = TRUE) } else { box <- FALSE } if (legend) { if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { graphics::par(old.par) stop("plot region too small to add legend\n") } ix <- 1 minz <- zlim[1] maxz <- zlim[2] binwidth <- (maxz - minz)/nlevel midpoints <- seq(minz + binwidth/2, maxz - binwidth/2, by = binwidth) iy <- midpoints iz <- matrix(iy, nrow = 1, ncol = length(iy)) breaks <- list(...)$breaks graphics::par(new=TRUE, pty = "m", plt=smallplot, err = -1) if (!is.null(breaks)) { if (is.null(lab.breaks)) { lab.breaks <- as.character(breaks) } axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } if (!horizontal) { if (is.null(breaks)) { image(ix, iy, iz, xaxt="n", yaxt="n", xlab="", ylab="", col=col, useRaster=useRaster) } else { image(ix, iy, iz, xaxt="n", yaxt="n", xlab = "", ylab = "", col=col, breaks=breaks, useRaster=useRaster) } } else { if (is.null(breaks)) { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, useRaster=useRaster) } else { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, breaks = breaks, useRaster=useRaster) } } do.call("axis", axis.args) graphics::box() if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.mar - 2) } if (!is.null(legend.args)) { do.call(graphics::mtext, legend.args) } } mfg.save <- graphics::par()$mfg if (graphics.reset | add) { graphics::par(old.par) graphics::par(mfg = mfg.save, new = FALSE) } else { graphics::par(big.par) graphics::par(plt = big.par$plt, xpd = FALSE) graphics::par(mfg = mfg.save, new = FALSE) } if (!add & box ) graphics::box() invisible() } .polyimage <- function (x, y, z, col = heat.colors(64), transparent.color = "white", # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html midpoint = FALSE, zlim = range(z, na.rm = TRUE), xlim = range(x), ylim = range(y), add = FALSE, border = NA, ...) { polyimageregrid <- function (x) { temp.addcol <- function(X) { N <- ncol(X) cbind(X[, 1] - (X[, 2] - X[, 1]), X, (X[, N] - X[, (N - 1)]) + X[, N]) } M <- nrow(x) N <- ncol(x) x <- (x[, 1:(N - 1)] + x[, 2:N])/2 x <- (x[1:(M - 1), ] + x[2:M, ])/2 x <- t(temp.addcol(x)) t(temp.addcol(x)) } drapecolor <- function (z, col = heat.colors(64), zlim = NULL, transparent.color = "white", midpoint = TRUE) { eps <- 1e-07 if (is.null(zlim)) { zlim <- range(c(z), na.rm = TRUE) } z[(z < zlim[1]) | (z > zlim[2])] <- NA NC <- length(col) M <- nrow(z) N <- ncol(z) if (midpoint) { z <- (z[1:(M - 1), 1:(N - 1)] + z[2:M, 1:(N - 1)] + z[1:(M - 1), 2:N] + z[2:M, 2:N])/4 } dz <- (zlim[2] * (1 + eps) - zlim[1])/NC zcol <- floor((z - zlim[1])/dz + 1) ifelse(zcol > NC, transparent.color, col[zcol]) } Dx <- dim(x) Dy <- dim(y) if (any((Dx - Dy) != 0)) { stop(" x and y matrices should have same dimensions") } Dz <- dim(z) if (all((Dx - Dz) == 0) & !midpoint) { x <- polyimageregrid(x) y <- polyimageregrid(y) } zcol <- drapecolor(z, col = col, midpoint = midpoint, zlim = zlim, transparent.color = transparent.color) if (!add) { plot(xlim, ylim, type = "n", ...) } N <- ncol(x) Nm1 <- N - 1 M <- nrow(x) Mm1 <- M - 1 for (i in (1:Mm1)) { xp <- cbind(x[i, 1:Nm1], x[i + 1, 1:Nm1], x[i + 1, 2:N], x[i, 2:N], rep(NA, Nm1)) yp <- cbind(y[i, 1:Nm1], y[i + 1, 1:Nm1], y[i + 1, 2:N], y[i, 2:N], rep(NA, Nm1)) xp <- c(t(xp)) yp <- c(t(yp)) graphics::polygon(xp, yp, border = NA, col = c(zcol[i, 1:Nm1])) } } .imageplotplt <- function (x, add = FALSE, legend.shrink = 0.9, legend.width = 1, # fields, Tools for spatial data # Copyright 2004-2007, Institute for Mathematics Applied Geosciences # University Corporation for Atmospheric Research # Licensed under the GPL -- www.gpl.org/licenses/gpl.html horizontal = FALSE, legend.mar = NULL, bigplot = NULL, smallplot = NULL, ...) { old.par <- graphics::par(no.readonly = TRUE) if (is.null(smallplot)) stick <- TRUE else stick <- FALSE if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } char.size <- ifelse(horizontal, graphics::par()$cin[2]/graphics::par()$din[2], graphics::par()$cin[1]/graphics::par()$din[1]) offset <- char.size * ifelse(horizontal, graphics::par()$mar[1], graphics::par()$mar[4]) legend.width <- char.size * legend.width legend.mar <- legend.mar * char.size if (is.null(smallplot)) { smallplot <- old.par$plt if (horizontal) { smallplot[3] <- legend.mar smallplot[4] <- legend.width + smallplot[3] pr <- (smallplot[2] - smallplot[1]) * ((1 - legend.shrink)/2) smallplot[1] <- smallplot[1] + pr smallplot[2] <- smallplot[2] - pr } else { smallplot[2] <- 1 - legend.mar smallplot[1] <- smallplot[2] - legend.width pr <- (smallplot[4] - smallplot[3]) * ((1 - legend.shrink)/2) smallplot[4] <- smallplot[4] - pr smallplot[3] <- smallplot[3] + pr } } if (is.null(bigplot)) { bigplot <- old.par$plt if (!horizontal) { bigplot[2] <- min(bigplot[2], smallplot[1] - offset) } else { bottom.space <- old.par$mar[1] * char.size bigplot[3] <- smallplot[4] + offset } } if (stick & (!horizontal)) { dp <- smallplot[2] - smallplot[1] smallplot[1] <- min(bigplot[2] + offset, smallplot[1]) smallplot[2] <- smallplot[1] + dp } return(list(smallplot = smallplot, bigplot = bigplot)) } raster/R/projection.R0000644000176200001440000001205714507510157014264 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 # to be removed when released sp has this for crs #setMethod("wkt", signature(obj="ANY"), # function(obj) { # if (!inherits(obj, "CRS")) { # obj <- obj@crs # } else if (inherits(obj, c("sf", "sfc"))) { # obj <- sf::st_crs(obj) # obj <- as(obj, "CRS") # passes on WKT comment # } # # w <- comment(obj) # if (is.null(w)) { # warning("no wkt comment") # return("") # } else { # return(w) # } # } #) .CRS <- function(...) { .spCRS(...) } setMethod("wkt", signature(obj="Raster"), function(obj) { #w <- comment(obj@crs) #if (is.null(w)) { # warning("no wkt comment") # return("") #} else { # return(w) #} if (.hasSlot(obj, "srs")) { terra::crs(obj@srs) } else { NA @.srs_from_sp(obj@crs) } } ) .makeCRS <- function(user="", prj="", wkt="") { if (missing(user)) user = "" if (is.na(user)) user = "" if (is.na(prj)) prj = "" if (is.na(wkt)) wkt = "" if (wkt != "") { if (prj != "") { .spCRS(prj, SRS_string=wkt) } else { .spCRS(SRS_string=wkt) } } else if (user !="") { if (substr(trim(user), 1 ,1) == "+") { .spCRS(user) } else { .spCRS(SRS_string=user) } } else { .spCRS(prj) } } .getCRS <- function(x) { if (methods::extends(class(x), "CRS")) { return(x) } if ((length(x) == 0) || is.null(x)) { x <- .spCRS() } else if (methods::extends(class(x), "BasicRaster")) { #x <- x@crs if (!is.na(x@crs)) { x <- x@crs } else if (.hasSlot(x, "srs")) { x <- .makeCRS(x@srs) } else { x <- .spCRS() } } else if (methods::extends(class(x), "Spatial")) { x <- x@proj4string } else if (inherits(x, c("sf", "sfc"))) { x <- sf::st_crs(x) x <- as(x, "CRS") # passes on WKT comment } else if (inherits(x, "SpatRaster")) { x <- crs(x) x <- .makeCRS(x) } else if (inherits(x, "SpatVector")) { x <- crs(x, proj=TRUE) x <- .makeCRS(x) } else if (is.na(x)) { x <- .spCRS() } else if (is.character(x)) { x <- trimws(x) if (x == "") { x <- .spCRS() } else if (substr(x, 1, 4) == "EPSG") { x <- .spCRS(terra::crs(x, proj=TRUE)) } else if (substr(x, 1, 1) == "+") { x <- .spCRS(x) } else { x <- terra::crs(terra::crs(x), proj=TRUE) x <- .spCRS(x) } #if (trimws(x) == "") { # x <- return(CRS()) #} else { # wkt <- rgdal::showSRID(x) # x <- .spCRS() # x@projargs <- rgdal::showP4(wkt) # attr(x, "comment") <- wkt #} } else if (is.numeric(x)) { x <- paste0("EPSG:", round(x)) x <- .spCRS(terra::crs(x, proj=TRUE)) } else { x <- .spCRS() } # else if "is .spCRS" x } setMethod("crs", signature("ANY"), function(x, asText=FALSE, ...) { projection(x, asText=asText) } ) setMethod("crs<-", signature("BasicRaster", "ANY"), function(x, ..., value) { projection(x) <- value x } ) #rgdal::showWKT(projection(x))) setMethod("crs<-", signature("Spatial", "ANY"), function(x, ..., value) { if (!inherits(value, "CRS")) { if (is.na(value)) { value <- .spCRS() } else if (is.character(value)) { value <- .spCRS(value) } else { value <- .spCRS(value) } } suppressWarnings(x@proj4string <- value) x } ) setMethod("is.na", signature(x="CRS"), function(x) { is.na(x@projargs) } ) "projection<-" <- function(x, value) { crsvalue <- .getCRS(value) srsvalue <- .getSRS(value) if (inherits(x, "RasterStack")) { if (nlayers(x) > 0) { for (i in 1:nlayers(x)) { # x@layers[[i]]@crs <- crsvalue if (.hasSlot(x@layers[[i]], "srs")) { x@layers[[i]]@srs <- srsvalue } } } } if (inherits(x, "Spatial")) { x@proj4string <- crsvalue } else { #x@crs <- crsvalue x@crs <- .spCRS() if (.hasSlot(x, "srs")) { x@srs <- srsvalue } } return(x) } projection <- function(x, asText=TRUE) { if (methods::extends(class(x), "BasicRaster")) { x <- .getCRS(x) } else if (methods::extends(class(x), "Spatial")) { x <- x@proj4string } else if (inherits(x, c("sf", "sfc"))) { crs = sf::st_crs(x) if (asText) { return(crs$proj4string) # extracts sp::proj4string from WKT } else { return(as(crs, "CRS")) # passes on WKT comment } } else if (inherits(x, "character")) { if (asText) { return(x) } else { return( .spCRS(x) ) } } else if (!inherits(x, "CRS")) { return(as.logical(NA)) } if (asText) { if (inherits(x, "CRS")) { if (is.na(x@projargs)) { return(as.character(NA)) } else { return(trim(x@projargs)) } } } else if (!inherits(x, "CRS")) { x <- .spCRS(x) } return(x) } setMethod("proj4string", signature("BasicRaster"), function(obj) { if (.hasSlot(obj, "srs")) { p4s <- try(suppressWarnings(terra::crs(obj@srs, proj=TRUE)), silent=TRUE) if (inherits(obj, "try-error") || (p4s=="")) { p4s <- as.character(NA) } } else { p4s <- obj@crs@projargs } p4s } ) setMethod("as.character", signature("CRS"), function(x, ...) { x@projargs } ) setMethod("proj4string", signature("CRS"), function(obj) { obj@projargs } ) setMethod("proj4string<-", signature("Raster"), function(obj, value) { crs(obj) <- value obj } ) raster/R/idwValue.R0000644000176200001440000000273014507510157013665 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 1.0 # Licence GPL v3 # under development ..idwValue <- function(raster, xy, ngb=4, pow=1, layer, n) { r <- raster(raster) longlat <- couldBeLonLat(r) cells <- cellFromXY(r, xy) adj <- adjacent(r, cells, ngb, pairs=TRUE, include=TRUE, id=TRUE) uc <- unique(adj[,3]) row1 <- rowFromCell(r, min(uc, na.rm=TRUE)) nrows <- row1 - 1 + rowFromCell(r, max(uc, na.rm=TRUE)) offs <- cellFromRowCol(r, row1, 1) - 1 cs <- uc - offs nl <- nlayers(raster) if (nl==1) { v <- cbind(uc, v=getValues(raster, row1, nrows)[cs]) } else { v <- cbind(uc, v=getValues(raster, row1, nrows)[cs,]) } m <- merge(adj, v, by.x='to', by.y=1) colnames(xy) <- c('x', 'y') m <- merge(m, cbind(1:nrow(xy), xy), by.x='id', by.y=1) pd <- pointDistance(m[,c('x', 'y')], xyFromCell(r, m$to), lonlat=longlat) / 1000 pd <- pd^pow pd[pd==0] <- 1e-12 if (nl==1) { pd[is.na(m$v)] <- NA as.vector( tapply(m$v*(1/pd), m$id, sum, na.rm=TRUE) / tapply(1/pd, m$id, sum, na.rm=TRUE) ) #cbind(as.integer(names(res)), res) } else { lys <- 4:(4+nl-1) a1 <- aggregate(m[,lys]*(1/pd), list(m$id), sum) a2 <- aggregate(1/pd, list(m$id), sum) res <- as.matrix(a1[,-1]) / as.vector(as.matrix(a2[,-1])) res <- cbind(as.vector(a1[,1]), res) res[, -1] } } #a=raster(nc=10,nr=10) #xmin(a)=55 #projection(a) = "+proj=utm +zone=33" #a[] = 1:ncell(a) #a[50:75]=NA #r = disaggregate(raster(a), 3) #r[] = .idwValue(a, sp::coordinates(r)) #plot(r) raster/R/replaceProperties.R0000644000176200001440000000245614507510157015602 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("ncol<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { dim(x) <- c(nrow(x), value) return(x) } ) setMethod("nrow<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { dim(x) <- c(value, ncol(x)) return(x) } ) setMethod("xmin<-", signature('Extent', 'numeric'), function(x, ..., value) { x@xmin <- value return(x) } ) setMethod("xmax<-", signature('Extent', 'numeric'), function(x, ..., value) { x@xmax <- value return(x) } ) setMethod("ymin<-", signature('Extent', 'numeric'), function(x, ..., value) { x@ymin <- value return(x) } ) setMethod("ymax<-", signature('Extent', 'numeric'), function(x, ..., value) { x@ymax <- value return(x) } ) setMethod("xmin<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@xmin <- value return(x) } ) setMethod("xmax<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@xmax <- value return(x) } ) setMethod("ymin<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@ymin <- value return(x) } ) setMethod("ymax<-", signature('BasicRaster', 'numeric'), function(x, ..., value) { x@extent@ymax <- value return(x) } ) raster/R/shp.R0000644000176200001440000000464214507510157012703 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.1 # Licence GPL v3 if (!isGeneric("shapefile")) { setGeneric("shapefile", function(x, ...) standardGeneric("shapefile")) } setMethod('shapefile', signature(x='character'), function(x, stringsAsFactors=FALSE, verbose=FALSE, warnPRJ=TRUE, ...) { x <- normalizePath(x, winslash = "/", mustWork = FALSE) shp <- extension(x, '.shp') stopifnot(file.exists(x)) stopifnot(file.exists(extension(x, '.shx'))) stopifnot(file.exists(extension(x, '.dbf'))) if (warnPRJ & !file.exists(extension(x, '.prj'))) { warning('.prj file is missing') } v <- vect(x) as(v, "Spatial") #rgdal::readOGR(dirname(x), fn, stringsAsFactors=stringsAsFactors, verbose=verbose, ...) } ) setMethod('shapefile', signature(x='Spatial'), function(x, filename='', overwrite=FALSE, ...) { stopifnot(filename != '') filename <- normalizePath(filename, winslash = "/", mustWork = FALSE) extension(filename) <- '.shp' if (file.exists(filename)) { if (!overwrite) { stop('file exists, use overwrite=TRUE to overwrite it') } } layer <- basename(filename) extension(layer) <- '' if (!inherits(x, 'Spatial')) { stop('To write a shapefile you need to provide an object of class Spatial*') } else { if (inherits(x, 'SpatialPixels')) { if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPointsDataFrame') } else { x <- as(x, 'SpatialPoints') } warning('Writing SpatialPixels to a shapefile. Writing to a raster file format might be more desirable') } else if ( inherits(x, 'SpatialGrid') ) { stop('These data cannot be written to a shapefile') } if (!.hasSlot(x, 'data')) { if (inherits(x, 'SpatialPolygons')) { x <- sp::SpatialPolygonsDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE) } else if (inherits(x, 'SpatialLines')) { x <- sp::SpatialLinesDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE) } else if (inherits(x, 'SpatialPoints')) { x <- sp::SpatialPointsDataFrame(x, data.frame(ID=1:length(x)), match.ID=FALSE) } else { stop('These data cannot be written to a shapefile') } } } x <- vect(x) writeVector(x, filename, filetype='ESRI Shapefile', layer=layer, overwrite=overwrite) #rgdal::writeOGR(x, filename, layer, driver='ESRI Shapefile', overwrite_layer=overwrite, ...) #extension(filename) <- '.cpg' #writeLines(encoding, filename, sep="") } ) raster/R/kml.R0000644000176200001440000000656214507510157012677 0ustar liggesusers# Derived, with only minor changes, from functions GE_SpatialGrid and kml Overlay # in the maptools package. These were written by Duncan Golicher, David Forrest and Roger Bivand # Adaptation for the raster packcage by Robert J. Hijmans, # Date : March 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("KML")) { setGeneric("KML", function(x, ...) standardGeneric("KML")) } setMethod('KML', signature(x='Spatial'), function (x, filename, zip='', overwrite=FALSE, ...) { # .requireRgdal() # if (! is.na(projection(x))) { # if (! isLonLat(x) ) { # warning('transforming data to longitude/latitude') ### this did not catch the output! # sp::spTransform(x, sp::CRS('+proj=longlat +datum=WGS84')) # } # } # if (!.hasSlot(x, 'data') ) { # x <- sp::addAttrToGeom(x, data.frame(id=1:length(x)), match.ID=FALSE) # } x <- vect(x) if (ncol(x) == 0) { x$id <- 1:nrow(x) } p <- crs(x) if (p != "") { if (!is.lonlat(x) ) { warning('transforming data to longitude/latitude') x <- sp::spTransform(x, sp::CRS('+proj=longlat +datum=WGS84')) } } 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)) } writeVector(x, filename, name, ...) #rgdal::writeOGR(x, filename, name, 'KML', ...) .zipKML(filename, '', zip, overwrite=overwrite) } ) setMethod('KML', signature(x='RasterLayer'), function (x, filename, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) { if (! couldBeLonLat(x)) { stop("CRS of x must be longitude / latitude") } if (nlayers(x) > 1) { x <- x[[1]] } stopifnot(hasValues(x)) if (missing(filename)) { filename <- extension(basename(rasterTmpFile('G_')), '.kml') } x <- sampleRegular(x, size=maxpixels, asRaster = TRUE, useGDAL=TRUE) imagefile <- filename extension(imagefile) <- '.png' kmlfile <- kmzfile <- filename extension(kmlfile) <- '.kml' if (file.exists(kmlfile)) { if (overwrite) { file.remove(kmlfile) } else { stop('kml file exists, use "overwrite=TRUE" to overwrite it') } } grDevices::png(filename = imagefile, width=max(480, blur*ncol(x)), height=max(480,blur*nrow(x)), bg="transparent") if (!is.na(colNA)) { graphics::par(mar=c(0,0,0,0), bg=colNA) } else { graphics::par(mar=c(0,0,0,0)) } image(x, col=col, axes=FALSE, useRaster=TRUE, maxpixels=maxpixels, ...) grDevices::dev.off() name <- names(x)[1] if (name == "") { name <- 'x' } kml <- c('', '', "") kmname <- paste("", name, "", sep = "") icon <- paste("", basename(imagefile), "0.75", sep = "") e <- extent(x) latlonbox <- c("\t", paste("\t\t", e@ymax, "", e@ymin, "", e@xmax, "", e@xmin, "", sep = ""), "\t") footer <- "" kml <- c(kml, kmname, icon, latlonbox, footer) f <- file(kmlfile, 'wt', encoding='UTF-8') cat(paste(kml, sep="", collapse="\n"), file=f, sep="") close(f) .zipKML(kmlfile, imagefile, zip, overwrite=overwrite) } ) raster/R/sampleRandom.R0000644000176200001440000000721314507510157014530 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('sampleRandom', signature(x='Raster'), function(x, size, na.rm=TRUE, ext=NULL, cells=FALSE, rowcol=FALSE, xy=FALSE, sp=FALSE, asRaster=FALSE, ...) { if (!hasValues(x)) { stop('No values associated with the Raster object') } size <- round(size) stopifnot(size > 0) r <- raster(x) if (asRaster) { if (! is.null(ext)) { x <- crop(x, ext) } if (size >= ncell(x)) { return(x) } if (na.rm) { x <- sampleRandom(x, min(ncell(r), size), cells=TRUE, na.rm=TRUE) r <- rasterize(xyFromCell(r, x[,1]), r, x[,-1], ...) } else { cells <- sample(ncell(r), size) x <- extract(x, cells) r <- rasterize(xyFromCell(r, cells), r, x, ...) } return(r) } stopifnot(size <= ncell(x)) nc <- ncell(r) layn <- names(x) removeCells <- FALSE if (sp | rowcol | xy) { removeCells <- ! cells cells <- TRUE } if ( canProcessInMemory(x) ) { if (is.null(ext)) { x <- getValues(x) } else { x <- crop(x, ext) rc <- raster(x) x <- getValues(x) } if (cells) { if (is.null(ext)) { x <- cbind(cell=1:nc, value=x) } else { XY <- xyFromCell(rc, 1:ncell(rc)) cell <- cellFromXY(r, XY) x <- cbind(cell=cell, x) } } if (na.rm) { x <- stats::na.omit(x) } if (is.matrix(x)) { # get rid of omit attributes d <- dim(x) x <- matrix(as.vector(x), d[1], d[2]) if ( nrow(x) > size) { s <- sampleInt(nrow(x), size) x <- x[s, ,drop=FALSE] } } else { # get rid of omit attributes x <- as.vector(x) s <- sampleInt(length(x), size) x <- x[s] } } else { if (! is.null(ext)) { xx <- crop(x, ext) nc <- ncell(xx) if (size > nc) { size <- nc warning('size set to the number of cells within "ext": ', size) } } if (size >= nc) { if (is.null(ext)) { x <- getValues(x) } else { r <- raster(x) x <- getValues(xx) } if (cells) { if (is.null(ext)) { x <- cbind(cell=1:nc, value=x) } else { XY <- xyFromCell(xx, 1:ncell(xx)) cell <- cellFromXY(r, XY) x <- cbind(cell, x) } } if (na.rm) { x <- stats::na.omit(x) # get rid of omit attributes if (is.matrix(x)) { d <- dim(x) x <- matrix(as.vector(x), d[1], d[2]) } else { x <- as.vector(x) } } } else { if (na.rm) { N <- 4 * size } else { N <- size } N <- min(N, nc) rcells <- sampleInt(nc, N) if (!is.null(ext)) { XY <- xyFromCell(xx, rcells) rcells <- cellFromXY(r, XY) } x <- .cellValues(x, rcells) if (cells) { x <- cbind(cell=rcells, value=x) } if (na.rm) { x <- stats::na.omit(x) if (is.matrix(x)) { d <- dim(x) x <- matrix(as.vector(x), d[1], d[2]) if (nrow(x) > size) { x <- x[1:size, ] } } else { x <- as.vector(x) if ( length(x) > size ) { x <- x[1:size] } } } } } if (is.matrix(x)) { if (cells) { colnames(x) <- c('cell', layn) if (xy) { XY <- xyFromCell(r, x[,1]) x <- cbind(x[,1,drop=FALSE], XY, x[,2:ncol(x),drop=FALSE]) } if (rowcol) { rc <- cbind(row=rowFromCell(r, x[,1]), col=colFromCell(r, x[,1])) x <- cbind(x[ , 1, drop=FALSE], rc, x[ , 2:ncol(x), drop=FALSE]) } if (sp) { if (!xy) { XY <- data.frame(xyFromCell(r, x[,1])) } if (removeCells) { x <- x[,-1,drop=FALSE] } x <- sp::SpatialPointsDataFrame(XY, data=data.frame(x), proj4string=.getCRS((r))) } else if (removeCells) { x <- x[,-1,drop=FALSE] } } else { colnames(x) <- layn } } return(x) } ) raster/R/simplifyPols.R0000644000176200001440000000111014507510157014566 0ustar liggesusers .simplifyPolygons <- function(p) { g <- geom(p) out <- NULL for (i in 1:g[nrow(g), 'cump']) { gg <- g[g[,3]==i, ] keep <- rep(TRUE, nrow(gg)) for (j in 2:(nrow(gg)-1)) { if (gg[j,'x'] == gg[j-1,'x'] & gg[j,'x'] == gg[j+1,'x']) { keep[j] <- FALSE } else if (gg[j,'y'] == gg[j-1,'y'] & gg[j,'y'] == gg[j+1,'y']) { keep[j] <- FALSE } } gg <- gg[keep, ] out <- rbind(out, gg) } out <- as(data.frame(out), 'SpatialPolygons') out@proj4string <- p@proj4string if (.hasSlot(p, 'data')) { out <- sp::SpatialPolygonsDataFrame(out, p@data) } out } raster/R/fixDBFnames.R0000644000176200001440000000142014507510157014226 0ustar liggesusers .fixDBFNames <- function(x, verbose=TRUE) { n <- gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', x) ) nn <- n n <- gsub('[^[:alnum:]]', '_', n) n[nchar(n) > 10] <- gsub('_', '', n[nchar(n) > 10]) n[n==''] <- 'field' n <- gsub('^[^[:alpha:]]', 'X', n) n <- substr(n, 1, 10) # duplicate names nn <- as.matrix(table(n)) i <- which(nn > 1) if (! is.null(i)) { names <- rownames(nn)[i] n[n %in% names] <- substr(n[n %in% names], 1, 9) n <- make.unique(n, sep = "") } if (verbose) { i <- x == n if (! all(i)) { x <- rbind(x, n) colnames(x) <- paste('col_', 1:ncol(x), sep="") x <- x[, !i, drop=FALSE] rownames(x) = c('original name', 'adjusted name') print(x) } } return(n) } raster/R/cover.R0000644000176200001440000000412314507510157013221 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('cover', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ..., filename=''){ rasters <- .makeRasterList(x, y, ...) if (length(rasters) == 1) { return(rasters[[1]]) } compareRaster(rasters) nl <- sapply(rasters, nlayers) if (max(nl) > 1) { stop("Only single layer (RasterLayer) objects can be used if 'x' and 'y' have a single layer") } outRaster <- raster(x) filename <- trim(filename) dots <- list(...) if (is.null(dots$format)) { format <- .filetype(filename=filename) } else { format <- dots$format } if (is.null(dots$overwrite)) { overwrite <- .overwrite() } else { overwrite <- dots$overwrite } if (is.null(dots$progress)) { progress <- .progress() } else { progress <- dots$progress } if (is.null(dots$datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } else { datatype <- dots$datatype } if (canProcessInMemory(x, length(rasters) + 2)) { v <- getValues( rasters[[1]] ) for (j in 2:length(rasters)) { v[is.na(v)] <- getValues(rasters[[j]])[is.na(v)] } outRaster <- setValues(outRaster, v) if (filename != '') { outRaster <- writeRaster(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } } else { if (filename == '') { filename <- rasterTmpFile() } outRaster <- writeStart(outRaster, filename=filename, format=format, datatype=datatype, overwrite=overwrite ) tr <- blockSize(outRaster, length(rasters)) pb <- pbCreate(tr$n, progress=progress, label='cover') for (i in 1:tr$n) { v <- getValues( rasters[[1]], row=tr$row[i], nrows=tr$nrows[i] ) if (! is.matrix(v) ) { v <- matrix(v, ncol=1) } for (j in 2:length(rasters)) { vv <- getValues(rasters[[j]], row=tr$row[i], nrows=tr$nrows[i]) v[is.na(v)] <- vv[is.na(v)] } outRaster <- writeValues(outRaster, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) outRaster <- writeStop(outRaster) } return(outRaster) } ) raster/R/hdrErdasRaw.R0000644000176200001440000000347514507510157014322 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .writeHdrErdasRaw <- function(raster) { hdrfile <- filename(raster) extension(hdrfile) <- ".raw" thefile <- file(hdrfile, "w") # open an txt file connectionis cat("IMAGINE_RAW_FILE\n", file = thefile) cat("PIXEL_FILES ", .setFileExtensionValues(raster@file@name), "\n", file = thefile) # this may not work. Some implementations may ignore this keyword and expect the pixelfile to have the same file name, no extension. cat("HEIGHT ", nrow(raster), "\n", file = thefile) cat("WIDTH ", ncol(raster), "\n", file = thefile) cat("NUM_LAYERS ", nbands(raster), "\n", file = thefile) if (.shortDataType(raster@file@datanotation) == 'INT') { dd <- "S" } else { dd <- "F" } nbits <- dataSize(raster@file@datanotation) * 8 dtype <- paste(dd, nbits, sep="") cat("DATA_TYPE ", dtype, "\n", file = thefile) #U1, U2, U4, U8, U16, U32 #S16, S32 #F32, and F64. if (.Platform$endian == "little") { btorder <- "LSB" } else { btorder <- "MSB" } cat("BYTE_ORDER ", btorder, "\n", file = thefile) #Required for DATA_TYPE values of U16, S16, U32, S32 cat("FORMAT ", "BIL", "\n", file = thefile) cat("DATA_OFFSET 0\n", file = thefile) cat("END_RAW_FILE\n", file = thefile) cat("\n\n", file = thefile) cat("The below is additional metadata, not part of the ERDAS raw format\n", file = thefile) cat("----------------------------------------------------------------\n", file = thefile) cat("CREATOR=R package:raster\n", file = thefile) cat("CREATED=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n", file = thefile) cat("Projection=", proj4string(raster), "\n", file = thefile) cat("MinValue=", minValue(raster), "\n", file = thefile) cat("MaxValue=", maxValue(raster), "\n", file = thefile) close(thefile) .worldFile(raster, ".rww") } raster/R/as.spatial.R0000644000176200001440000000445014507510157014145 0ustar liggesusers setAs("data.frame", "SpatialPolygons", function(from) { v <- colnames(from)[5] if (v == "x") { obs <- unique(from$object) sp <- list() for (i in 1:length(obs)) { s <- from[from$object==obs[i], ] p <- unique(s$part) pp <- list() for (j in 1:length(p)) { ss <- s[s$part==p[j], ] pol <- sp::Polygon( as.matrix(ss[,c('x', 'y')] )) if (ss$hole[1]) { pol@hole <- TRUE } pp[[j]] <- pol } sp[[i]] <- sp::Polygons(pp, as.character(i)) } } else if (v == "hole") { colnames(from)[1] <- "id" obs <- unique(from$id) sp <- list() for (i in 1:length(obs)) { s <- from[from$id==obs[i], ] p <- unique(s$part) pp <- list() jj <- 1 for (j in 1:length(p)) { ss <- s[s$part==p[j], ] hi <- ss$hole > 0 holes <- ss[hi, ] ss <- ss[!hi,] pol <- sp::Polygon( as.matrix(ss[,c("x", "y")] )) pp[[jj]] <- pol jj <- jj + 1 if (nrow(holes) > 0) { uh <- unique(holes$hole) for (k in uh) { pol <- sp::Polygon( as.matrix(holes[holes$hole==k, c("x", "y")] )) pol@hole <- TRUE pp[[jj]] <- pol jj <- jj + 1 } } sp[[i]] <- sp::Polygons(pp, as.character(i)) } } } else { stop("cannot process this data.frame") } sp::SpatialPolygons(sp) } ) setAs("data.frame", "SpatialPolygonsDataFrame", function(from) { x <- as(from, "SpatialPolygons") if (ncol(from) > 6) { d <- unique(from[, -c(2:6), drop=FALSE]) rownames(d) <- d$object d <- d[, -1, drop=FALSE] sp::SpatialPolygonsDataFrame(x, d) } else { x } } ) setAs("data.frame", "SpatialLines", function(from) { colnames(from)[1] <- "object" obs <- unique(from$object) sp <- list() for (i in 1:length(obs)) { s <- from[from$object==obs[i], ] p <- unique(s$part) pp <- list() for (j in 1:length(p)) { ss <- s[s$part==p[j], ] ln <- sp::Line(as.matrix(ss[,c("x", "y")])) pp[[j]] <- ln } sp[[i]] <- sp::Lines(pp, as.character(i)) } sp::SpatialLines(sp) } ) setAs("data.frame", "SpatialLinesDataFrame", function(from) { x <- as(from, "SpatialLines") if (ncol(from) > 5) { d <- unique(from[, -c(2:5), drop=FALSE]) rownames(d) <- d$object d <- d[, -1, drop=FALSE] sp::SpatialLinesDataFrame(x, d) } else { x } } ) raster/R/as.matrix.R0000644000176200001440000000174714507510157014022 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 setMethod('as.matrix', signature(x='RasterLayer'), function(x, maxpixels, ...) { if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } return( getValues(x, format='matrix') ) }) setMethod('as.matrix', signature(x='RasterStackBrick'), function(x, maxpixels, ...){ if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } return( getValues(x) ) }) setMethod('as.matrix', signature(x='Extent'), function(x, ...) { b <- bbox(x) rownames(b) <- c('x', 'y') b }) # mode argument is ignored as mode=mode gave an error on R-devel setMethod('as.vector', signature(x='Extent'), function(x, mode='any') { as.vector(c(x@xmin, x@xmax, x@ymin, x@ymax)) }) setMethod('as.vector', signature(x='Raster'), function(x, mode='any') { as.vector(getValues(x)) }) raster/R/ncell.R0000644000176200001440000000056214507510157013203 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod('ncell', signature(x='BasicRaster'), function(x) { return(as.numeric(x@ncols) * x@nrows) } ) setMethod('ncell', signature(x='ANY'), function(x) { NROW(x) * NCOL(x) } ) setMethod('length', signature(x='BasicRaster'), function(x) { ncell(x) * nlayers(x) } ) raster/R/netCDFreadCells.R0000644000176200001440000001101414507510157015022 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2010 # Version 1.0 # Licence GPL v3 .readRasterCellsNetCDF <- function(x, cells) { if (canProcessInMemory(x, 2)) { # read all r <- getValues(x) r <- r[cells] return(r) } row1 <- rowFromCell(x, min(cells)) row2 <- rowFromCell(x, max(cells)) if ((row2 - row1) < 10 ) { # read only rows needed ncl <- (row2 - row1 + 1) * x@ncols r <- raster(nrow=1, ncol=ncl) v <- getValues(x, row1, row2-row1+1) v <- v[cells-cellFromRowCol(x, row1, 1)+1] return(v) } # read row by row colrow <- matrix(ncol=3, nrow=length(cells)) colrow[,1] <- colFromCell(x, cells) colrow[,2] <- rowFromCell(x, cells) colrow[,3] <- NA rows <- sort(unique(colrow[,2])) readrows <- rows if ( x@file@toptobottom ) { readrows <- x@nrows - readrows + 1 } zvar = x@data@zvar time = x@data@band nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) if (nc$var[[zvar]]$ndims == 1) { ncx <- x@ncols count <- ncx for (i in 1:length(rows)) { start <- (readrows[i]-1) * ncx + 1 v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else if (nc$var[[zvar]]$ndims == 2) { count <- c(x@ncols, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i]) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else if (nc$var[[zvar]]$ndims == 3) { count <- c(x@ncols, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], time) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { if (x@data@dim3 == 4) { count <- c(x@ncols, 1, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], x@data@level, time) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } else { count <- c(x@ncols, 1, 1, 1) for (i in 1:length(rows)) { start <- c(1, readrows[i], time, x@data@level) v <- as.vector(ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count)) thisrow <- subset(colrow, colrow[,2] == rows[i]) colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] } } } colrow <- colrow[,3] #if (!is.na(x@file@nodatavalue)) { colrow[colrow==x@file@nodatavalue] <- NA } #colrow <- x@data@add_offset + colrow * x@data@scale_factor colrow[colrow == x@file@nodatavalue] <- NA return(colrow) } .readBrickCellsNetCDF <- function(x, cells, layer, nl) { i <- which(!is.na(cells)) if (length(cells) > 1000) { if (canProcessInMemory(x, 2)) { # read all endlayer <- layer+nl-1 r <- getValues(x) r <- r[cells, layer:endlayer] return(r) } } # read cell by cell zvar <- x@data@zvar dim3 <- x@data@dim3 cols <- colFromCell(x, cells) rows <- rowFromCell(x, cells) if ( x@file@toptobottom ) { rows <- x@nrows - rows + 1 } nc <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) # this needs to be optimized. Read chunks and extract cells j <- which(!is.na(cells)) if (nc$var[[zvar]]$ndims == 2) { count <- c(1, 1) res <- matrix(NA, nrow=length(cells), ncol=1) for (i in j) { start <- c(cols[i], rows[i]) res[i] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } else if (nc$var[[zvar]]$ndims == 3) { count <- c(1, 1, nl) res <- matrix(NA, nrow=length(cells), ncol=nl) for (i in j) { start <- c(cols[i], rows[i], layer) res[i,] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } else { if (x@data@dim3 == 4) { count <- c(1, 1, 1, nl) res <- matrix(NA, nrow=length(cells), ncol=nl) for (i in j) { start <- c(cols[i], rows[i], x@data@level, layer) res[i,] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } else { count <- c(1, 1, nl, 1) res <- matrix(nrow=length(cells), ncol=nl) for (i in 1:length(cells)) { start <- c(cols[i], rows[i], layer, x@data@level) res[i,] <- ncdf4::ncvar_get(nc, varid=zvar, start=start, count=count) } } } #if (!is.na(x@file@nodatavalue)) { res[res==x@file@nodatavalue] <- NA } #res <- x@data@add_offset + res * x@data@scale_factor res[res == x@file@nodatavalue] <- NA return(res) } raster/R/extractPoints_sp.R0000644000176200001440000000355314507510157015462 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2014 # Version 1.0 # Licence GPL v3 setMethod('extract', signature(x='SpatialPolygons', y='SpatialPoints'), function(x, y, ...){ x <- vect(x) y <- vect(y) extract(x, y, ...) # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # if (! identical( .proj4string(x), .proj4string(y)) ) { # warning('non identical crs') # y@proj4string <- x@proj4string # } # i <- rgeos::gIntersects(y, x, byid=TRUE) # j <- cbind(1:length(y), rep(1:length(x), each=length(y)), as.vector(t(i))) # j <- j[j[,3] == 1, -3, drop=FALSE] # colnames(j) <- c('point.ID', 'poly.ID') # if (.hasSlot(x, 'data')) { # r <- data.frame(j, x@data[j[,2], ,drop=FALSE], row.names=NULL) # } else { # r <- data.frame(j, row.names=NULL) # } # q <- data.frame(point.ID = 1:length(y)) # merge(q, r, by='point.ID', all=TRUE) }) setMethod('extract', signature(x='SpatialPolygons', y='data.frame'), function(x, y, ...) { stopifnot(ncol(y) == 2) y <- as.matrix(y) stopifnot(is.numeric(y[1,1])) extract(x, y, ...) } ) setMethod('extract', signature(x='SpatialPolygons', y='matrix'), function(x, y, ...) { stopifnot(ncol(y) == 2) stopifnot(is.numeric(y[1,1])) i <- which(rowSums(is.na(y)) == 0) if (length(i) == 0) { r <- cbind(data.frame(point.ID=1:nrow(y), poly.ID=NA), x@data[0,][1:nrow(y),]) rownames(r) <- NULL } else if (length(i) < nrow(y)) { sp <- sp::SpatialPoints(y[i,], proj4string=x@proj4string) v <- extract(x, sp, ...) r <- cbind(data.frame(point.ID=1:nrow(y), poly.ID=NA), x@data[0,][1:nrow(y),]) if (nrow(v) == nrow(sp)) { # no overlapping polygons r[i, ] <- v } else { r <- r[! r$point.ID %in% i, ] r <- rbind(r, v) r <- r[order(r$point.ID), ] } rownames(r) <- NULL } else { sp <- sp::SpatialPoints(y, proj4string=x@proj4string) r <- extract(x, sp, ...) } return(r) } ) raster/R/writeStartStopAscii.R0000644000176200001440000000342414507510157016075 0ustar liggesusers# Author: Robert J. Hijmans # Date : May 2010 # Version 0.9 # Licence GPL v3 .startAsciiWriting <- function(x, filename, NAflag, ...) { filename <- trim(filename) if (filename == '') { stop('provide a filename') } x@file@name <- filename x@file@driver <- 'ascii' overwrite <- .overwrite(...) dtype <- .shortDataType(.datatype(...)) x@file@datanotation = .datatype(...) dtype <- .shortDataType(x@file@datanotation) attr(x@file, "dtype") <- dtype if (!missing(NAflag)) { x@file@nodatavalue <- NAflag } else if (!is.finite( x@file@nodatavalue) ) { x@file@nodatavalue <- -3.4e+38 } resdif <- abs((yres(x) - xres(x)) / yres(x) ) if (resdif > 0.01) { stop(paste("x has unequal horizontal and vertical resolutions. Such data cannot be stored in arc-ascii format")) } else if (resdif > 0.001) { warning("ignoring the slightly unequal horizontal and vertical resolutions") } if (!overwrite & file.exists(filename)) { stop(paste(filename, "exists. Use 'overwrite=TRUE'")) } thefile <- file(filename, "w") # open an txt file connection cat("NCOLS", ncol(x), "\n", file = thefile) cat("NROWS", nrow(x), "\n", file = thefile) cat("XLLCORNER", as.character(xmin(x)), "\n", file = thefile) cat("YLLCORNER", as.character(ymin(x)), "\n", file = thefile) cat("CELLSIZE", as.character(xres(x)), "\n", file = thefile) cat("NODATA_value", x@file@nodatavalue, "\n", file = thefile) close(thefile) #close connection return(x) } .stopAsciiWriting <- function(x) { x@data@haveminmax <- TRUE if (x@file@dtype == "INT") { x@data@min <- round(x@data@min) x@data@max <- round(x@data@max) # } else if ( x@file@dtype =='LOG' ) { # raster@data@min <- as.logical(raster@data@min) # raster@data@max <- as.logical(raster@data@max) } return( raster( x@file@name ) ) } raster/R/drivers.R0000644000176200001440000000230314507510157013557 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2008 # Version 0.9 # Licence GPL v3 .nativeDrivers <- function() { return( c("raster", "SAGA", "IDRISI", "IDRISIold", "BIL", "BSQ", "BIP") ) } .nativeDriversLong <- function() { return( c("R-raster", "SAGA GIS", "IDRISI", "IDRISI (img/doc)", "Band by Line", "Band Sequential", "Band by Pixel") ) } .isNativeDriver <- function(d) { return( d %in% .nativeDrivers() ) } writeFormats <- function() { ## if ( .requireRgdal(FALSE) ) { gd <- .gdalWriteFormats() short <- c(.nativeDrivers(), 'ascii', 'CDF', as.vector(gd[,1])) long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', as.vector(gd[,2])) # short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', as.vector(gd[,1])) # long <- c(.nativeDriversLong(), 'Arc ASCII', 'NetCDF', 'big.matrix', as.vector(gd[,2])) #} else { # short <- c(.nativeDrivers(), 'ascii', 'CDF', "") # long <- c(.nativeDriversLong(), "Arc ASCII", "NetCDF", "", "rgdal not installed") # short <- c(.nativeDrivers(), 'ascii', 'CDF', 'big', "") # long <- c(.nativeDriversLong(), "Arc ASCII", "NetCDF", "big.matrix", "", "rgdal not installed") #} m <- cbind(short, long) colnames(m) <- c("name", "long_name") return(m) } raster/R/setFileExt.R0000644000176200001440000000226114507510157014160 0ustar liggesusers# raster package # Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .setFileExtensionValues <- function(fname, type='raster') { if (type == 'raster') { extension(fname) <- ".gri" } else if (type == 'SAGA') { extension(fname) <- ".sdat" } else if (type == 'IDRISI') { extension(fname) <- ".rst" } else if (type == 'IDRISIold') { extension(fname) <- ".img" } else if (type == 'BIL') { extension(fname) <- ".bil" } else if (type == 'BIP') { extension(fname) <- ".bip" } else if (type == 'BSQ') { extension(fname) <- ".bsq" # } else if (type == 'big.matrix') { # extension(fname) <- ".big" } else { stop('unknown file format') } return(fname) } .setFileExtensionHeader <- function(fname, type='raster') { if (type == 'raster') { extension(fname) <- ".grd" } else if (type == 'SAGA') { extension(fname) <- "sgrd" } else if (type == 'IDRISI') { extension(fname) <- ".rdc" } else if (type == 'IDRISIold') { extension(fname) <- ".doc" } else if (type %in% c('BIL', 'BSQ', 'BIP')) { extension(fname) <- ".hdr" } else if (type == 'big.matrix') { extension(fname) <- ".brd" } else { stop('unknown file format') } return(fname) } raster/R/RGB.R0000644000176200001440000000530514507510157012520 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 # partly based on functions in the pixmap package by Friedrich Leisch setMethod("RGB", signature(x='RasterLayer'), function(x, filename='', col=rainbow(25), breaks=NULL, alpha=FALSE, colNA='white',zlim=NULL, zlimcol=NULL, ext=NULL, ...) { getCols <- function(x, col, breaks=NULL, r=NULL, colNA=NA) { if (!is.null(breaks)) { breaks <- sort(breaks) x <- as.numeric(cut(x, breaks, include.lowest=TRUE)) } else { x <- (x - r[1])/ (r[2] - r[1]) x <- round(x * (length(col)-1) + 1) } x <- col[x] if (!is.na(colNA)) { x[is.na(x)] <- grDevices::rgb(t(grDevices::col2rgb(colNA)), maxColorValue=255) } x } if (!is.null(ext)) { x <- crop(x, ext) } if (alpha) { out <- brick(x, nl=4, values=FALSE) } else { out <- brick(x, nl=3, values=FALSE) } names(out) <- c('red', 'green', 'blue', 'alpha')[1:nlayers(out)] if (canProcessInMemory(out)) { x <- getValues(x) if (is.logical(x)) { x <- as.integer(x) } x[is.infinite(x)] <- NA if (!is.null(zlim)) { if (!is.null(zlimcol)) { x[x < zlim[1]] <- zlim[1] x[x > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { x[x < zlim[1] | x > zlim[2]] <- NA } } w <- getOption('warn') options('warn'=-1) if (is.null(breaks)) { zrange <- range(x, zlim, na.rm=TRUE) } else { zrange <- range(x, zlim, breaks, na.rm=TRUE) } options('warn'=w) if (zrange[1] == zrange[2]) { zrange[1] <- zrange[1] - 0.001 zrange[2] <- zrange[2] + 0.001 } x <- getCols(x, col, breaks, zrange, colNA) x <- grDevices::col2rgb(x, alpha=alpha) out <- setValues(out, t(x)) if (filename != '') { out <- writeRaster(out, filename, datatype='INT2U', ...) } return(out) } else { r <- c(minValue(x), maxValue(x)) if (is.null(breaks)) { zrange <- range(r, zlim, na.rm=TRUE) } else { zrange <- range(r, zlim, breaks, na.rm=TRUE) } if (zrange[1] == zrange[2]) { zrange[1] <- zrange[1] - 0.001 zrange[2] <- zrange[2] + 0.001 } tr <- blockSize(out) pb <- pbCreate(tr$n, label='RGB', ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (!is.null(zlim)) { if (!is.null(zlimcol)) { v[v < zlim[1]] <- zlim[1] v[v > zlim[2]] <- zlim[2] } else { #if (is.na(zlimcol)) { v[v < zlim[1] | v > zlim[2]] <- NA } } v <- getCols(v, col, breaks, zrange, colNA) v <- grDevices::col2rgb(as.vector(v), alpha=alpha) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb) } pbClose(pb) return ( writeStop(out) ) } } ) #x = raster(nr=10, nc=10, vals=1:100) #y = RGB(x) #plotRGB(y) raster/R/netCDFtoRasterGMT.R0000644000176200001440000000223114507510157015300 0ustar liggesusers# Author: Robert J. Hijmans # Date: March 2013 # Version 1.0 # Licence GPL v3 .rasterObjectFromCDF_GMT <- function(nc) { stopifnot(requireNamespace("ncdf4")) dims <- ncdf4::ncvar_get(nc, "dimension", 1) xr <- ncdf4::ncvar_get(nc, "x_range", 1) yr <- ncdf4::ncvar_get(nc, "y_range", 1) zr <- ncdf4::ncvar_get(nc, "z_range", 1) sp <- ncdf4::ncvar_get(nc, "spacing", 1) zvar = 'z' crs <- NA if (xr[1] > -181 & xr[2] < 181 & yr[1] > -91 & yr[2] < 91 ) { crs <- "+proj=longlat +datum=WGS84" } dif1 <- abs(((xr[2] - xr[1]) / dims[1]) - sp[2]) dif2 <- abs(((xr[2] - xr[1]) / (dims[1]-1)) - sp[2]) if (dif1 < dif2) { # 30 sec GEBCO data r <- raster(xmn=xr[1], xmx=xr[2], ymn=yr[1], ymx=yr[2], ncol=dims[1], nrow=dims[2], crs=crs) } else { # 1 min data resx <- (xr[2] - xr[1]) / (dims[1]-1) resy <- (yr[2] - yr[1]) / (dims[2]-1) r <- raster(xmn=xr[1]-(0.5*resx), xmx=xr[2]+(0.5*resx), ymn=yr[1]-(0.5*resy), ymx=yr[2]+(0.5*resy), ncol=dims[1], nrow=dims[2], crs=crs) } r@file@name <- nc$filename r@file@toptobottom <- FALSE attr(r@data, "zvar") <- zvar attr(r@data, "dim3") <- 1 r@file@driver <- "netcdf" r@data@fromdisk <- TRUE return(r) } raster/R/ratify.R0000644000176200001440000000634214507510157013406 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric("ratify")) {setGeneric("ratify", function(x, ...) standardGeneric("ratify"))} setMethod("ratify", signature(x="Raster"), function(x, filename="", count=FALSE, ...) { stopifnot(nlayers(x) == 1) if (count) { f <- freq(x, useNA='no') f <- data.frame(f) colnames(f) <- c('ID', 'COUNT') } else { f <- data.frame(ID=unique(x)) } x@data@isfactor <- TRUE x@data@attributes <- list(f) if (filename != '') { x <- writeRaster(x, filename, ...) # only native format stores this, hence re-assign these: x@data@isfactor <- TRUE x@data@attributes <- list(f) } return(x) } ) .unweightRAT <- function(rat, fun='mean') { fun <- .makeTextFun(fun) x <- stats::na.omit(rat) cols <- 3:ncol(x) cls <- sapply(x[,cols,drop=FALSE], class) if (fun %in% c('min', 'max')) { if (any(cls %in% 'factor')) { warning('you cannot use a mean value for a factor') i <- which(cls %in% 'factor') + 2 x[, i] <- NA } x <- aggregate(x[,cols], x[,1,drop=FALSE], fun) x <- data.frame(ID=x[,1], COUNT=NA, x[,cols-1]) } else if (fun == 'mean') { if (any(! cls %in% c('integer', 'numeric'))) { warning('you cannot use a mean value for a variable that is not a number') i <- which(! cls %in% c('integer', 'numeric')) + 2 x[, i] <- NA } v <- aggregate(x[,2] * x[,cols], x[,1,drop=FALSE], sum) w <- aggregate(x[,2], x[,1,drop=FALSE], sum) v[,cols-1] <- v[,cols-1]/w[,2] x <- cbind(ID=v[,1], COUNT=NA, value=v[,cols-1]) } else if (fun == 'largest') { ids <- unique(x[,1]) j <- list() for (i in 1:length(ids)) { v <- subset(x, x[,1]==ids[i]) j[[i]] <- v[which.max(v[,2]), ] } return( do.call(rbind, j) ) } else if (fun == 'smallest') { ids <- unique(x[,1]) j <- list() for (i in 1:length(ids)) { v <- subset(x, x[,1]==ids[i]) j[[i]] <- v[which.min(v[,2]), ] } return( do.call(rbind, j) ) } else { stop('argument "fun" is not valid (should be "mean", "min", "max", "smallest", or "largest"') } colnames(x)[cols] <- colnames(rat)[cols] merge(unique(rat[,1,drop=FALSE]), x, by=1, all.x=TRUE) } deratify <- function(x, att=NULL, layer=1, complete=FALSE, drop=TRUE, fun='mean', filename='', ...) { x <- x[[layer]] rats <- is.factor(x) if (!rats) { warning('This layer is not a factor') return(x) } RAT <- levels(x)[[1]] if (NCOL(RAT) > 2) { if (colnames(RAT)[2] == '_WEIGHT_') { levels(x) <- .unweightRAT(RAT, fun) } } else if (NCOL(RAT) == 1) { if (complete) { x@data@isfactor <- FALSE x@data@attributes <- list() return(x) } else { warning('this layer already has a single factor level (use "complete=TRUE" to remove it)') return(x) } } nms <- colnames(RAT) if (!is.null(att)) { if (is.character(att)) { att <- stats::na.omit(match(att, nms)) if (length(att) == 0) { stop("argument 'att' does not include valid names") } } RAT <- RAT[ , c(1, att), drop=FALSE] } cc <- 2:ncol(RAT) if (drop) { for (i in cc) { options('warn'=-1) suppressWarnings(v <- as.numeric(as.character(RAT[,i]))) if (isTRUE(all(RAT[,i] == v))) { RAT[,i] <- v } } } subs(x, RAT, by=1, which=cc, subsWithNA=TRUE, filename=filename, ...) } raster/R/scalebar.R0000644000176200001440000001004514507510157013657 0ustar liggesusers# Author: Robert J. Hijmans # scalebar partly based on Josh Gray' code in http://spatiallyexplicit.wordpress.com/2011/06/07/crop-circles/ # Date : July 2011 # Version 1.0 # Licence GPL v3 .destPoint <- function (p, d, b=90, r=6378137) { toRad <- pi/180 lon1 <- p[, 1] * toRad lat1 <- p[, 2] * toRad b <- b * toRad lat2 <- asin(sin(lat1) * cos(d/r) + cos(lat1) * sin(d/r) * cos(b)) lon2 <- lon1 + atan2(sin(b) * sin(d/r) * cos(lat1), cos(d/r) - sin(lat1) * sin(lat2)) lon2 <- (lon2 + pi)%%(2 * pi) - pi cbind(lon2, lat2)/toRad } .oldscalebar <- function(object, xy=click(), length=100000, label='100 km', offset=0.3, lwd=4, ... ) { object <- raster(object) if (couldBeLonLat(object)) { midy <- object@extent@ymax - 0.5 * (object@extent@ymax - object@extent@ymin) p <- cbind(0, midy) d <- .destPoint(p, length) length <- d[1,1] } xy2 <- xy xy2[1,1] <- xy2[1,1] + length lines(rbind(xy, xy2), lwd=lwd, ...) xy[1,1] <- xy[1,1] + 0.5 * length xy[1,2] <- xy[1,2] + offset * length text(xy[1,1], xy[1,2], label, ...) } .arrow <- function(d, xy=click(), head=0.1, ...) { graphics::arrows(xy[1], xy[2], xy[1], xy[2]+d, length=head, ...) lines(rbind(xy, rbind(cbind(xy[1], xy[2]-d))), ...) text(xy[1,1], xy[1,2]-(0.25*d), 'N') } scalebar <- function(d, xy=NULL, type='line', divs=2, below='', lonlat=NULL, label, adj=c(0.5, -0.5), lwd=2, ...){ stopifnot(type %in% c('line', 'bar')) pr <- graphics::par() if (is.null(lonlat)) { if ( pr$usr[1] > -181 & pr$usr[2] < 181 & pr$yaxp[1] > -200 & pr$yaxp[2] < 200 ) { lonlat <- TRUE } else { lonlat <- FALSE } } if (lonlat) { lat <- mean(pr$yaxp[1:2]) if (missing(d)) { dx <- (pr$usr[2] - pr$usr[1]) / 10 d <- pointDistance(cbind(0, lat), cbind(dx, lat), TRUE) d <- signif(d / 1000, 2) label <- NULL } p <- cbind(0, lat) dd <- .destPoint(p, d * 1000) dd <- dd[1,1] } else { if (missing(d)) { d <- round(10*(pr$usr[2] - pr$usr[1])/10) / 10 label <- NULL } dd <- d } if(is.null(xy)) { padding=c(5,5) / 100 #defaults to a lower left hand position parrange <- c(pr$usr[2] - pr$usr[1], pr$usr[4] - pr$usr[3]) xy <- c(pr$usr[1]+(padding[1]*parrange[1]), pr$usr[3]+(padding[2]*parrange[2])) } if (type == 'line') { lines(matrix(c(xy[1], xy[2], xy[1]+dd, xy[2]), byrow=T, nrow=2), lwd=lwd, ...) if (missing(label)) { label <- paste(d) } if (is.null(label)) { label <- paste(d) } if (missing(adj)) { adj <- c(0.5, -0.2-lwd/20 ) } text(xy[1]+(0.5*dd), xy[2],labels=label, adj=adj,...) } else if (type == 'bar') { stopifnot(divs > 0) if (missing(adj)) { adj <- c(0.5, -1 ) } lwd <- dd / 25 if (divs==2) { half <- xy[1] + dd / 2 graphics::polygon(c(xy[1], xy[1], half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='white') graphics::polygon(c(half, half, xy[1]+dd, xy[1]+dd ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='black') if (missing(label)) { label <- c('0', '', d) } if (is.null(label)) { label <- c('0', '', d) } text(xy[1], xy[2],labels=label[1], adj=adj,...) text(xy[1]+0.5*dd, xy[2],labels=label[2], adj=adj,...) text(xy[1]+dd, xy[2],labels=label[3], adj=adj,...) } else { q1 <- xy[1] + dd / 4 half <- xy[1] + dd / 2 q3 <- xy[1] + 3 * dd / 4 end <- xy[1] + dd graphics::polygon(c(xy[1], xy[1], q1, q1), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='white') graphics::polygon(c(q1, q1, half, half), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='black') graphics::polygon(c(half, half, q3, q3 ), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='white') graphics::polygon(c(q3, q3, end, end), c(xy[2], xy[2]+lwd, xy[2]+lwd, xy[2]), col='black') if (missing(label)) { label <- c('0', round(0.5*d), d) } if (is.null(label)) { label <- c('0', round(0.5*d), d) } text(xy[1], xy[2], labels=label[1], adj=adj,...) text(half, xy[2], labels=label[2], adj=adj,...) text(end, xy[2],labels=label[3], adj=adj,...) } if (below != "") { adj[2] <- -adj[2] text(xy[1]+(0.5*dd), xy[2], labels=below, adj=adj,...) } } } raster/R/xyValuesBuffer.R0000644000176200001440000001415014507510157015056 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .xyvBuf <- function(object, xy, buffer, fun=NULL, na.rm=TRUE, layer, nl, cellnumbers=FALSE, small=FALSE, onlycells=FALSE) { buffer <- abs(buffer) if (length(buffer == 1)) { buffer <- rep(buffer, times=nrow(xy)) } else if (length(buffer) != nrow(xy) | ! is.vector(buffer) ) { stop('buffer should be a single value or a vector of length==nrow(xy)') } buffer[is.na(buffer)] <- 0 if (onlycells) { cellnumbers <- TRUE fun <- NULL small <- TRUE object <- raster(object) } else if (! is.null(fun)) { cellnumbers <- FALSE } cv <- list() obj <- raster(object) # ? centralcells <- cellFromXY(obj, xy) # needs to deal with global wrapping.... if (couldBeLonLat(obj)) { # from m to degrees bufy <- buffer / 111319.5 ymx <- pmin(90, xy[,2] + bufy) ymn <- pmax(-90, xy[,2] - bufy) bufx1 <- buffer / pointDistance(cbind(0, ymx), cbind(1, ymx), lonlat=TRUE) bufx2 <- buffer / pointDistance(cbind(0, ymn), cbind(1, ymn), lonlat=TRUE) bufx <- pmax(bufx1, bufx2) cn <- colFromX(obj, xy[,1]-bufx) cx <- colFromX(obj, xy[,1]+bufx) cn[is.na(cn) & (xy[,1]-bufx <= xmin(obj) & xy[,1]+bufx >= xmin(obj))] <- 1 cx[is.na(cx) & (xy[,1]-bufx <= xmax(obj) & xy[,1]+bufx > xmax(obj))] <- ncol(obj) rn <- rowFromY(obj, xy[,2]+bufy) rx <- rowFromY(obj, xy[,2]-bufy) rn[is.na(rn) & (xy[,2]-bufy <= ymax(obj) & xy[,2]+bufy >= ymax(obj))] <- 1 rx[is.na(rx) & (xy[,2]-bufy <= ymin(obj) & xy[,2]+bufy >= ymin(obj))] <- nrow(obj) for (i in 1:nrow(xy)) { s <- sum(rn[i], rx[i], cn[i], cx[i]) if (is.na(s)) { cv[[i]] <- NA } else { if (onlycells) { value <- i } else { value <- getValuesBlock(object, rn[i], rx[i]-rn[i]+1, cn[i], cx[i]-cn[i]+1) } cell <- cellFromRowColCombine(obj, rn[i]:rx[i], cn[i]:cx[i]) coords <- xyFromCell(obj, cell) if (cellnumbers) { pd <- cbind(pointDistance(xy[i,], coords, lonlat=TRUE), cell, value) } else { pd <- cbind(pointDistance(xy[i,], coords, lonlat=TRUE), value) } if (nrow(pd) > 1) { v <- pd[pd[,1] <= buffer[i], -1] if (NROW(v) == 0) { cv[[i]] <- pd[which.min(pd[,1]), -1] } else { cv[[i]] <- v } } else { cv[[i]] <- pd[,-1] } } } } else { cn <- colFromX(obj, xy[,1]-buffer) cx <- colFromX(obj, xy[,1]+buffer) cn[is.na(cn) & (xy[,1]-buffer <= xmin(obj) & xy[,1]+buffer >= xmin(obj))] <- 1 cx[is.na(cx) & (xy[,1]-buffer <= xmax(obj) & xy[,1]+buffer > xmax(obj))] <- ncol(obj) rn <- rowFromY(obj, xy[,2]+buffer) rx <- rowFromY(obj, xy[,2]-buffer) rn[is.na(rn) & (xy[,2]-buffer <= ymax(obj) & xy[,2]+buffer >= ymax(obj))] <- 1 rx[is.na(rx) & (xy[,2]-buffer <= ymin(obj) & xy[,2]+buffer >= ymin(obj))] <- nrow(obj) if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nrow(xy), length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() parallel::clusterExport(cl, c('object', 'obj', 'cellnumbers'), envir=environment()) clFun2 <- function(i, xy, rn, rx, cn, cx) { s <- sum(rn, rx, cn, cx) if (is.na(s)) { return(NA) } else { if (onlycells) { value <- i } else { value <- getValuesBlock(object, rn, rx-rn+1, cn, cx-cn+1) } cell <- cellFromRowColCombine(obj, rn:rx, cn:cx) coords <- xyFromCell(obj, cell) if (cellnumbers) { pd <- cbind(pointDistance(xy, coords, lonlat=TRUE), cell, value) } else { pd <- cbind(pointDistance(xy, coords, lonlat=TRUE), value) } if (nrow(pd) > 1) { pd <- pd[pd[,1] <= buffer[i], -1] } else { pd <- pd[,-1] } return(pd) } } .sendCall <- eval( parse( text="parallel:::sendCall") ) for (i in 1:nodes) { .sendCall(cl[[i]], clFun2, list(i, xy[i, ,drop=FALSE], rn[i], rx[i], cn[i], cx[i]), tag=i) } for (i in 1:nrow(xy)) { d <- .recvOneData(cl) if (! d$value$success) { print(d) stop('cluster error') } else { cv[[i]] <- d$value$value } ni <- nodes + i if (ni <= nrow(xy)) { .sendCall(cl[[d$node]], clFun2, list(ni, xy[i, ,drop=FALSE], rn[i], rx[i], cn[i], cx[i]), tag=i) } } } else { for (i in 1:nrow(xy)) { s <- sum(rn[i], rx[i], cn[i], cx[i]) if (is.na(s)) { cv[[i]] <- NA } else { if (onlycells) { value <- i } else { value <- getValuesBlock(object, rn[i], rx[i]-rn[i]+1, cn[i], cx[i]-cn[i]+1) } cell <- cellFromRowColCombine(obj, rn[i]:rx[i], cn[i]:cx[i]) coords <- xyFromCell(obj, cell) if (cellnumbers) { pd <- cbind(pointDistance(xy[i,], coords, lonlat=FALSE), cell, value) } else { pd <- cbind(pointDistance(xy[i,], coords, lonlat=FALSE), value) } if (nrow(pd) > 1) { cv[[i]] <- pd[pd[,1] <= buffer[i], -1] } else { cv[[i]] <- pd[,-1] } } } } } if (small) { i <- sapply(cv, function(x) length(x)==0) if (any(i)) { i <- which(i) if (onlycells) { vv <- cbind(cellFromXY(object, xy[i, ,drop=FALSE]), NA) } else { vv <- extract(object, xy[i, ,drop=FALSE], na.rm=na.rm, layer=layer, nl=nl, cellnumbers=cellnumbers) } if (NCOL(vv) > 1) { for (j in 1:length(i)) { cv[[ i[j] ]] <- vv[j, ] } } else { for (j in 1:length(i)) { cv[[ i[j] ]] <- vv[j] } } } } nls <- nlayers(object) nms <- names(object) if (nls > 1) { if (layer > 1 | nl < nls) { lyrs <- layer:(layer+nl-1) nms <- nms[ lyrs ] cv <- lapply(cv, function(x) x[, lyrs ]) } } if (! is.null(fun)) { fun <- match.fun(fun) if (na.rm) { fun2 <- function(x){ x <- stats::na.omit(x) if (length(x) > 0) { return(fun(x)) } else { return(NA) } } } else { fun2 <- fun } #if (inherits(object, 'RasterLayer')) { if (nl == 1) { cv <- unlist(lapply(cv, fun2), use.names = FALSE) } else { np <- length(cv) cv <- lapply(cv, function(x) { if (!is.matrix(x)) { x <- t(matrix(x)) } apply(x, 2, fun2)} ) cv <- matrix(unlist(cv, use.names = FALSE), nrow=np, byrow=TRUE) colnames(cv) <- nms } } return(cv) } raster/R/math.R0000644000176200001440000000740514507510157013042 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("Math", signature(x='Raster'), function(x){ if (!hasValues(x)) { return(x) } #funname <- as.character(sys.call(sys.parent())[[1]]) funname <- .Generic nl <- nlayers(x) if (nl > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (substr(funname, 1, 3) == 'cum' ) { if (nl == 1) { if (canProcessInMemory(r, 3)) { r <- setValues(r, do.call(funname, list(values(x)))) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) x <- readStart(x) last <- 0 for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (i==1) { v <- do.call(funname, list(v)) } else { v <- do.call(funname, list(c(last, v)))[-1] } last <- v[length(v)] r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } if (canProcessInMemory(r, 3)) { r <- setValues(r, t( apply(getValues(x), 1, funname)) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- t( apply(getValues(x, row=tr$row[i], nrows=tr$nrows[i]), 1, funname) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { r <- setValues(r, methods::callGeneric(getValues(x))) } else { if (funname %in% c('floor', 'ceiling', 'trunc')) { datatype <- 'INT4S' } else { datatype <- .datatype() } tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- methods::callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } } return(r) } ) setMethod("Math2", signature(x='Raster'), function (x, digits=0) { digits <- round(digits) if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, methods::callGeneric( getValues(x), digits)) } else { if (digits <= 0) { datatype <- 'INT4S' } else { datatype <- .datatype() } tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, filename=rasterTmpFile(), datatype=datatype, format=.filetype(), overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- methods::callGeneric( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), digits ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } ) if (!isGeneric("log")) { setGeneric("log", function(x, ...) standardGeneric("log")) } setMethod("log", signature(x='Raster'), function(x, base=exp(1)){ nl <- nlayers(x) if (nl > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, log(values(x), base=base)) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='math') r <- writeStart(r, '', overwrite=TRUE ) x <- readStart(x) for (i in 1:tr$n) { v <- log( getValues(x, row=tr$row[i], nrows=tr$nrows[i]), base=base ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) x <- readStop(x) pbClose(pb) } return(r) } ) raster/R/extend.R0000644000176200001440000000722714507510157013402 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Licence GPL v3 # revised November 2011 # version 1.0 setMethod('extend', signature(x='Extent'), # function by Etienne B. Racine function(x, y, ...) { if (length(y) == 1) { y <- rep(y, 4) } else if (length(y) == 2) { y <- rep(y, each=2) } else if (! length(y) == 4 ) { stop('argument "y" should be a vector of 1, 2, or 4 elements') } x@xmin <- x@xmin - y[1] x@xmax <- x@xmax + y[2] x@ymin <- x@ymin - y[3] x@ymax <- x@ymax + y[4] methods::validObject(x) x } ) setMethod('extend', signature(x='Raster'), function(x, y, value=NA, snap='near', filename='', ...) { if (is.vector(y)) { if (length(y) <= 2) { adj <- abs(y) * rev(res(x)) y <- extent(x) y@ymin <- y@ymin - adj[1] y@ymax <- y@ymax + adj[1] y@xmin <- y@xmin - adj[2] y@xmax <- y@xmax + adj[2] } } test <- try ( y <- extent(y), silent=TRUE ) if (inherits(test, "try-error")) { stop('Cannot get an Extent object from argument y') } filename <- trim(filename) y <- alignExtent(y, x, snap=snap) # only expanding here, not cropping y <- union(y, extent(x)) if (nlayers(x) <= 1) { out <- raster(x) leg <- x@legend } else { out <- brick(x, values=FALSE) leg <- methods::new('.RasterLegend') } out@data@names <- names(x) out <- setExtent(out, y, keepres=TRUE) if (any(is.factor(x))) { # if (is.na(value)) { perhaps need to check if value is a level levels(out) <- levels(x) } if (nrow(x) == nrow(out) & ncol(x) == ncol(out)) { # nothing to do. return(x) } if (! hasValues(x) ) { return(out) } dtp <- FALSE datatype <- list(...)$datatype if (is.null(datatype)) { datatype <- unique(dataType(x)) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } dtp <- TRUE } if (canProcessInMemory(out)) { d <- matrix(value, nrow=ncell(out), ncol=nlayers(x)) d[cellsFromExtent(out, extent(x)), ] <- getValues(x) x <- setValues(out, d) if (filename != '') { if (dtp) { x <- writeRaster(x, filename=filename, datatype=datatype, ...) } else { x <- writeRaster(x, filename=filename, ...) } } return(x) } else { tr <- blockSize(out) tr$old <- rep(TRUE, tr$n) startrow <- rowFromY(out, yFromRow(x, 1)) endrow <- rowFromY(out, yFromRow(x, nrow(x))) if (endrow < nrow(out) | startrow > 1) { if (nrow(out) > endrow) { continuerow <- endrow + 1 } else { continuerow <- NULL } tr$row <- sort(unique(c(tr$row, startrow, continuerow))) tr$nrows <- c(tr$row[-1], nrow(out)+1) - tr$row tr$n <- length(tr$row) tr$old <- (tr$row <= endrow) & ((tr$row+tr$nrows-1) >= startrow) } startcol <- colFromX(out, xFromCol(x, 1)) endcol <- colFromX(out, xFromCol(x, ncol(x))) pb <- pbCreate(tr$n, label='extend', ...) if (dtp) { out <- writeStart(out, filename=filename, datatype=datatype, ... ) } else { out <- writeStart(out, filename=filename, ... ) } if ((startcol == 1) & endcol == ncol(out)) { # to make it faster for this case for (i in 1:tr$n) { if (tr$old[i]) { d <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) } else { d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) } out <- writeValues(out, d, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { d <- matrix(value, nrow=tr$nrows[i] * ncol(out), ncol=nlayers(out)) if (tr$old[i]) { cells <- startcol:endcol + rep((0:(tr$nrows[i]-1)) * ncol(out), each=endcol-startcol+1) d[cells, ] <- getValues(x, (tr$row[i]-startrow+1), tr$nrows[i]) } out <- writeValues(out, d, tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) return(out) } } ) raster/R/area.R0000644000176200001440000001315114507510157013014 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .cellArea <- function(x, r=6378137) { # currently not used dlonR2 <- xres(x) * (pi / 180) * r^2 lat <- yFromRow(x, 1:nrow(x)) lat <- cbind(lat, lat) dlat <- yres(x) lat[,1] <- lat[,1] + 0.5 * dlat lat[,2] <- lat[,2] - 0.5 * dlat lat <- sin(lat * (pi / 180) ) # for one column: abs(lat[,2] - lat[,1]) * dlonR2 } setMethod('area', signature(x='SpatialPolygons'), function(x, ...) { if (couldBeLonLat(x)) { if (!isLonLat(x)) { warning('assuming that the crs is longitude/latitude!') } lonlat = TRUE } else { lonlat = FALSE } g <- geom(x) .Call('_raster_get_area_polygon', PACKAGE = 'raster', g, lonlat) } ) setMethod('area', signature(x='RasterLayer'), function(x, filename='', na.rm=FALSE, weights=FALSE, ...) { out <- raster(x) if (na.rm) { if (! hasValues(x) ) { na.rm <- FALSE warning("'x' has no values, ignoring 'na.rm=TRUE'") rm(x) } } else { rm(x) } if (! couldBeLonLat(out)) { warning('This function is only useful for Raster* objects with a longitude/latitude coordinates') ar <- prod(res(out)) return( init(out, function(x) ar, filename=filename, ...) ) } filename <- trim(filename) if (!canProcessInMemory(out, 3) & filename == '') { filename <- rasterTmpFile() } if (filename == '') { v <- matrix(NA, ncol=nrow(out), nrow=ncol(out)) } else { if (weights) { outfname = filename filename = rasterTmpFile() } out <- writeStart(out, filename=filename, ...) } dy <- .geodist(0, 0, 0, yres(out)) y <- yFromRow(out, 1:nrow(out)) dx <- .geodist(0, y, xres(out), y) tr <- blockSize(out) pb <- pbCreate(tr$n, label='area', ...) for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) if (na.rm) { a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA } if (filename == "") { v[,r] <- vv } else { out <- writeValues(out, vv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (filename == "") { v <- as.vector(v) if (weights) { v <- v / sum(v, na.rm=TRUE) } values(out) <- v } else { out <- writeStop(out) if (weights) { total <- cellStats(out, 'sum') out <- calc(out, fun=function(x){x/total}, filename=outfname, ...) } } return(out) } ) setMethod('area', signature(x='RasterStackBrick'), function(x, filename='', na.rm=FALSE, weights=FALSE, ...) { if (! na.rm) { return( area(raster(x), filename=filename, na.rm=FALSE, weights=weights, ...) ) } out <- brick(x, values=FALSE) if (! couldBeLonLat(out)) { stop('This function is only useful for Raster* objects with a longitude/latitude coordinates') } filename <- trim(filename) if (!canProcessInMemory(out) & filename == '') { filename <- rasterTmpFile() } nl <- nlayers(out) if (filename == '') { v <- matrix(NA, ncol=nl, nrow=ncell(out)) } else { if (weights) { outfname = filename filename = rasterTmpFile() } out <- writeStart(out, filename=filename, ...) } dy <- pointDistance(c(0,0),c(0, yres(out) ), lonlat=TRUE) y <- yFromRow(out, 1:nrow(out)) dx <- pointDistance(cbind(0, y), cbind(xres(out), y), lonlat=TRUE) if (.doCluster() ) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(nrow(out), length(cl)) message('Using cluster with ', nodes, ' nodes') utils::flush.console() tr <- blockSize(out, minblocks=nodes) pb <- pbCreate(tr$n, label='area', ...) # clFun <- function(i, tr, dx, dy, out, nl) { clFun <- function(i) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) vv <- matrix(rep(vv, times=nl), ncol=nl) a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA return(vv) } .sendCall <- eval( parse( text="parallel:::sendCall") ) parallel::clusterExport(cl, c('tr', 'dx', 'dy', 'out', 'nl'), envir=environment()) for (i in 1:nodes) { .sendCall(cl[[i]], clFun, list(i), tag=i) } for (i in 1:tr$n) { d <- .recvOneData(cl) if (! d$value$success ) { print(d) stop('cluster error') } if (filename == "") { r <- tr$row[d$value$tag]:(tr$row[d$value$tag]+tr$nrows[d$value$tag]-1) start <- (r[1]-1) * ncol(out) + 1 end <- r[length(r)] * ncol(out) v[start:end, ] <- d$value$value } else { out <- writeValues(out, d$value$value, tr$row[d$value$tag]) } if ((nodes + i) <= tr$n) { # .sendCall(cl[[d$node]], clFun, list(nodes+i, tr, dx, dy, out, nl), tag=nodes+i) .sendCall(cl[[d$node]], clFun, list(nodes+i), tag=nodes+i) } pbStep(pb, i) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='area', ...) #rows <- 1 for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) vv <- dx[r] * dy / 1000000 vv <- rep(vv, each=out@ncols) vv <- matrix(rep(vv, times=nl), ncol=nl) a <- getValues(x, tr$row[i], tr$nrows[i]) vv[is.na(a)] <- NA if (filename == "") { start <- (r[1]-1) * ncol(out) + 1 end <- r[length(r)] * ncol(out) v[start:end, ] <- vv } else { out <- writeValues(out, vv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) } if (filename == "") { if (weights) { total <- colSums(v, na.rm=TRUE) v <- t( t(v) / total ) } values(out) <- v } else { out <- writeStop(out) if (weights) { total <- cellStats(out, 'sum') out <- calc(out, fun=function(x){x / total}, filename=outfname, ...) } } return(out) } ) raster/R/movingFun.R0000644000176200001440000000203014507510157014046 0ustar liggesusers# Author: Robert Hijmans # November 2009 # License GPL3 # First versions were based on the rollFun function implemented by Diethelm Wuertz in the # fTrading package # Version: 2100.76 # Published: 2009-09-29 movingFun <- function(x, n, fun=mean, type='around', circular=FALSE, na.rm=FALSE) { n <- round(abs(n)) if (n == 0) { stop('n == 0') } x = as.vector(x) lng <- length(x) if (type == 'around') { hn <- floor(n/2) if (circular) { x <- c(x[(lng-hn+1):lng], x, x[1:hn]) } else { x <- c(rep(NA, hn), x, rep(NA, hn)) } } else if (type == 'to') { if (circular) { x <- c(x[(lng-n+2):lng], x) } else { x <- c(rep(NA, n-1), x) } } else if (type == 'from') { if (circular) { x <- c(x, x[1:n]) } else { x <- c(x, rep(NA, n)) } } else { stop('unknown type; should be "around", "to", or "from"') } m <- matrix(ncol=n, nrow=lng) for (i in 1:n) { m[,i] <- x[i:(lng+i-1)] } apply(m, MARGIN=1, FUN=fun, na.rm=na.rm) } .roll <- function(x, n) { # by Josh O'Brien x[(seq_along(x) - (n+1)) %% length(x) + 1] } raster/R/rowSums.R0000644000176200001440000000470014720735265013571 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2015 # Version 1.0 # Licence GPL v3 setMethod('rowSums', signature(x='Raster'), function(x, na.rm = FALSE, dims = 1L, ...) { nl <- nlayers(x) if (canProcessInMemory(x)) { if(nl == 1) { # colSums because of row-wise Raster objects and col-wise R matrices and return(.colSums(getValues(x), ncol(x), nrow(x), na.rm=na.rm, ...)) } else { r <- .colSums(getValues(x), ncol(x), nrow(x)*nl, na.rm=na.rm, ...) r <- matrix(r, ncol=nl) colnames(r) <- names(x) return(r) } } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='rowSums', ...) nc <- ncol(x) if(nl == 1) { s <- list() for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) s[[i]] <- .colSums(v, nc, tr$nrows[i], na.rm=na.rm, ...) } return(unlist(s, use.names = FALSE)) } else { s <- list() for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) s[[i]] <- .colSums(v, nc, tr$nrows[i]*nl, na.rm=na.rm, ...) } s <- t(matrix(unlist(s), nrow=nl)) colnames(s) <- names(x) return(s) } } } ) setMethod('colSums', signature(x='Raster'), function(x, na.rm = FALSE, dims = 1L, ...) { nl <- nlayers(x) if (canProcessInMemory(x)) { if(nl == 1) { return(.colSums(as.matrix(x), nrow(x), ncol(x), na.rm=na.rm, ...)) } else { r <- getValues(x) s <- list() nc <- ncol(x) nr <- nrow(x) for (i in 1:nl) { v <- matrix(r[,i], nrow=nc) s[[i]] <- .rowSums(v, nc, nr, na.rm=na.rm, ...) } s <- matrix(unlist(s), ncol=nl) colnames(s) <- names(x) return(s) } } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='colSums', ...) nc <- ncol(x) if(nl == 1) { s <- list() for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) s[[i]] <- .colSums(matrix(v, nrow=tr$nrows[i], byrow=TRUE), tr$nrows[i], nc, na.rm=na.rm, ...) } s <- colSums(matrix(unlist(s), nrow=tr$n, byrow=T)) return(s) } else { s <- matrix(nrow=tr$n, ncol=nc*nl) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) for (j in 1:nl) { k <- (j-1) * nc + 1 k <- k:(k+nc-1) s[i, k] <- .colSums(matrix(v[,j], nrow=tr$nrows[i], byrow=TRUE), tr$nrows[i], nc, na.rm=na.rm, ...) } } s <- matrix(.colSums(s, nrow(s), ncol(s), na.rm=na.rm), ncol=nl) colnames(s) <- names(x) return(s) } } } ) raster/R/getValuesRows.R0000644000176200001440000000440414507510157014717 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterStack', row='numeric', nrows='numeric'), function(x, row, nrows) { for (i in 1:nlayers(x)) { if (i==1) { v <- getValues(x@layers[[i]], row, nrows) res <- matrix(ncol=nlayers(x), nrow=length(v)) res[,1] <- v } else { res[,i] <- getValues(x@layers[[i]], row, nrows) } } colnames(res) <- names(x) res } ) setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterLayer', row='numeric', nrows='numeric'), function(x, row, nrows, format='') { row <- round(row) nrows <- round(nrows) stopifnot(validRow(x, row)) stopifnot(nrows > 0) row <- min(x@nrows, max(1, row)) endrow <- max(min(x@nrows, row+nrows-1), row) nrows <- endrow - row + 1 if (inMemory(x)){ startcell <- cellFromRowCol(x, row, 1) endcell <- cellFromRowCol(x, row+nrows-1, x@ncols) v <- x@data@values[startcell:endcell] } else if ( fromDisk(x) ) { v <- .readRasterLayerValues(x, row, nrows) } else { v <- rep(NA, nrows * x@ncols) } if (format=='matrix') { v <- matrix(v, nrow=nrows, byrow=TRUE) rownames(v) <- row:(row+nrows-1) colnames(v) <- 1:ncol(v) } return(v) } ) setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterBrick', row='numeric', nrows='numeric'), function(x, row, nrows) { if (! validRow(x, row)) { stop(row, ' is not a valid rownumber') } row <- min(x@nrows, max(1, round(row))) endrow <- max(min(x@nrows, row+round(nrows)-1), row) nrows <- endrow - row + 1 if ( inMemory(x) ){ startcell <- cellFromRowCol(x, row, 1) endcell <- cellFromRowCol(x, row+nrows-1, x@ncols) res <- x@data@values[startcell:endcell, ,drop=FALSE] } else if (fromDisk(x)) { res <- .readRasterBrickValues(x, row, nrows) } else { res <- matrix(NA, nrow=nrows*ncol(x), ncol=nlayers(x)) } colnames(res) <- names(x) res } ) raster/R/rasterToPoints.R0000644000176200001440000000470714507510157015113 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2009 # Version 0.9 # Licence GPL v3 rasterToPoints <- function(x, fun=NULL, spatial=FALSE, ...) { nl <- nlayers(x) if (nl > 1) { if (! is.null(fun)) { stop('you can only supply a fun argument if "x" has a single layer') } } if (! inherits(x, 'RasterStack' )) { if ( ! fromDisk(x) & ! inMemory(x) ) { if (spatial) { crs <- .getCRS(x) return(sp::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), drop=FALSE], 1, function(x){ sum(is.na(x)) < length(x) }) xyv <- xyv[notna, ,drop=FALSE] } else { xyv <- stats::na.omit(xyv) attr(xyv, 'na.action') <- NULL } if (!is.null(fun)) { xyv <- subset(xyv, fun(xyv[,3])) } } else { xyv <- matrix(NA, ncol=2+nlayers(x), nrow=0) colnames(xyv) <- c('x', 'y', names(x)) X <- xFromCol(x, 1:ncol(x)) Y <- yFromRow(x, 1:nrow(x)) tr <- blockSize(x) pb <- pbCreate(tr$n, label='rasterize', ...) if (nl > 1) { for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xyvr <- cbind(rep(X, tr$nrows[i]), rep(Y[r], each=ncol(x)), getValues(x, row=tr$row[i], nrows=tr$nrows[i])) notna <- rowSums(is.na(xyvr[ , 3:ncol(xyvr), drop=FALSE])) < (ncol(xyvr)-2) xyvr <- xyvr[notna, ,drop=FALSE] xyv <- rbind(xyv, xyvr) pbStep(pb, i) } } else { # faster for (i in 1:tr$n) { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) xyvr <- cbind(rep(X, tr$nrows[i]), rep(Y[r], each=ncol(x)), v) xyvr <- subset(xyvr, !is.na(v)) if (!is.null(fun)) { xyvr <- subset(xyvr, fun(xyvr[,3])) } xyv <- rbind(xyv, xyvr) pbStep(pb, i) } } pbClose(pb) } if (spatial) { if (nrow(xyv) == 0) { xyv <- rbind(xyv, 0) v <- data.frame(xyv[ ,-c(1:2), drop=FALSE]) colnames(v) <- laynam crs <- .getCRS(x) s <- sp::SpatialPointsDataFrame(coords=xyv[,1:2,drop=FALSE], data=v, proj4string=crs ) return(s[0,]) } else { v <- data.frame(xyv[ ,-c(1:2), drop=FALSE]) colnames(v) <- laynam crs <- .getCRS(x) return( sp::SpatialPointsDataFrame(coords=xyv[,1:2,drop=FALSE], data=v, proj4string=crs ) ) } } else { colnames(xyv)[3:ncol(xyv)] <- laynam return(xyv) } } raster/R/text.R0000644000176200001440000000521514507510157013072 0ustar liggesusers# Author: Robert J. Hijmans # Date : August 2010 # Version 0.9 # Licence GPL v3 .haloText <- function(x, y=NULL, labels, col='black', hc='white', hw=0.1, ... ) { # with minor modifications from #From: Greg Snow imail.org> #Subject: Re: Text Contrast in a Plot #Newsgroups: gmane.comp.lang.r.general #Date: 2009-04-24 21:23:25 GMT xy <- grDevices::xy.coords(x,y) xo <- hw * graphics::strwidth('A') yo <- hw * graphics::strheight('A') theta <- seq(pi/4, 2*pi, length.out=8*hw*10) for (i in theta) { text( xy$x + cos(i)*xo, xy$y + sin(i)*yo, labels, col=hc, ... ) } text(xy$x, xy$y, labels, col=col, ... ) } setMethod('text', signature(x='RasterLayer'), function(x, labels, digits=0, fun=NULL, halo=FALSE, ...) { x <- rasterToPoints(x, fun=fun, spatial=FALSE) if (missing(labels)) { if (NCOL(x) > 2) { labels <- as.character(round(x[,3], digits=digits) ) } else { labels <- 1:NROW(x) } } if (halo) { .haloText(x[,1], x[,2], labels, ...) } else { text(x[,1], x[,2], labels, ...) } } ) setMethod('text', signature(x='RasterStackBrick'), function(x, labels, digits=0, fun=NULL, halo=FALSE, ...) { if (missing(labels)) { labels <- 1 } if (length(labels) != ncell(x)) { labels <- labels[1] if (is.character(labels)) { i <- which(labels == names(x)) if (i == 0) { i <- 1 } } x <- x[[labels]] x <- rasterToPoints(x, fun=fun, spatial=FALSE) labels <- as.character(round(x[,3], digits=digits) ) } if (halo) { .haloText(x[,1], x[,2], labels, ...) } else { text(x[,1], x[,2], labels, ...) } } ) setMethod('text', signature(x='SpatialPolygons'), function(x, labels, halo=FALSE, ...) { if (missing(labels)) { labels <- 1 } if (length(labels) == 1) { if (.hasSlot(x, 'data')) { if (labels %in% names(x)) { labels <- x@data[, labels] } } else { if (length(x)> 1) { labels <- 1:length(x) } } labels <- as.character(labels) } xy <- sp::coordinates(x)[,1:2,drop=FALSE] if (halo) { .haloText(xy[,1], xy[,2], labels, ...) } else { text(xy[,1], xy[,2], labels, ...) } } ) setMethod('text', signature(x='SpatialPoints'), function(x, labels, halo=FALSE, ...) { if (missing(labels)) { labels <- 1 } if (length(labels) == 1) { if (.hasSlot(x, 'data')) { if (labels %in% names(x)) { labels <- x@data[, labels] } } else { if (length(x)> 1) { labels <- 1:length(x) } } labels <- as.character(labels) } xy <- sp::coordinates(x)[,1:2,drop=FALSE] if (halo) { .haloText(xy[,1], xy[,2], labels, ...) } else { text(xy[,1], xy[,2], labels, ...) } } ) raster/R/modal.R0000644000176200001440000000262614507510157013205 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011, May 2015 # Version 1.0 # Licence GPL v3 setMethod('modal', signature(x='ANY'), function(x, ..., ties='random', na.rm=FALSE, freq=FALSE) { dots <- list(...) if ( length(dots) > 0 ) { # change fact to char because # c(x, ...) would change it to integers # and levels would a mess too with multiple objects if (is.factor(x)) { x <- as.character(x) dots <- unlist(lapply(dots, as.character)) } x <- c(x, unlist(dots)) } # NA itself cannot be the modal value # perhaps that should be allowed as an option z <- x[!is.na(x)] if (length(z) == 0) { return(NA) } else if (!na.rm & length(z) < length(x)) { return(NA) } if (freq) { if (length(z) == 1) { return(1) } else { return(max( table(z) )) } } ties <- match(ties[1], c('lowest', 'highest', 'first', 'random', 'NA')) - 1 if (is.na(ties)) { stop("the value of 'ties' should be 'lowest', 'highest', 'first', 'random' or 'NA'") } if (length(z) == 1) { return(z) } else if (is.numeric(z)) { w <- .getMode(z, ties=ties) } else if (is.logical(z)) { w <- as.logical(.getMode(z, ties=ties)) } else if (is.factor(z)) { w <- .getMode(z, ties=ties) w <- levels(z)[w] w <- factor(w, levels=levels(z)) } else { # character, perhaps others? z <- as.factor(z) w <- .getMode(z, ties=ties) w <- levels(z)[w] } return(w) } ) raster/R/srs.R0000644000176200001440000000311214507510157012707 0ustar liggesusers .srs_from_sp <- function(x) { crs <- x@projargs wk <- attr(x, "comment") if (!is.null(wk) && (!is.na(wk)) && (wk != "")) { wk } else { crs } } .getSRS <- function(x) { if (methods::extends(class(x), "CRS")) { a <- attr(x, "comment") if (is.null(a)) { x@projargs } else { a } } else if (is.null(x) || (length(x)==0)) { "" } else if (methods::extends(class(x), "BasicRaster")) { if (.hasSlot(x, "srs")) { if (x@srs != "") { x@srs } else { a <- attr(x@crs, "comment") if (is.null(a)) { x@crs@projargs } else { a } } } else { a <- attr(x@crs, "comment") if (is.null(a)) { x@crs@projargs } else { a } } } else if (methods::extends(class(x), "Spatial")) { x <- x@proj4string a <- attr(x, "comment") if (is.null(a)) { x@projargs } else { a } } else if (inherits(x, c("sf", "sfc"))) { sf::st_crs(x) } else if (inherits(x, "SpatRaster")) { crs(x, proj=TRUE) } else if (inherits(x, "SpatVector")) { crs(x, proj=TRUE) } else if (is.na(x)) { "" } else if (is.character(x)) { trimws(x) #r <- "" #try(r <- crs(rast(crs=trimws(x)), proj=TRUE)) #r # if (x == "") { # x <- .spCRS() # } else if (substr(x, 1, 1) == "+") { # x <- .spCRS(x) # } else { # x <- .spCRS(SRS_string = x) # } #if (trimws(x) == "") { # x <- return(CRS()) #} else { # wkt <- rgdal::showSRID(x) # x <- .spCRS() # x@projargs <- rgdal::showP4(wkt) # attr(x, "comment") <- wkt #} } else if (is.numeric(x)) { .getSRS(paste0("EPSG:", round(x))) } else { "" } # else if "is .spCRS" } raster/R/readAscii.R0000644000176200001440000000356314507510157013776 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .readAllAscii <- function(x) { filename <- trim(filename(x)) if (!file.exists(filename)) { stop(paste(filename, " does not exist")) } v <- as.numeric( scan(filename, skip=x@offset, what='character', quiet=TRUE) ) # if (x@file@nodatavalue < -10000) { # v[v <= x@file@nodatavalue ] <- NA # } else { v[v == x@file@nodatavalue ] <- NA # } return ( v ) } .readRowsAscii <- function(x, startrow, nrows, startcol=1, ncols=x@ncols) { if (startcol > 1 | ncols < x@ncols) { v <- matrix(nrow=ncols, ncol=nrows) endcol <- startcol+ncols-1 skiprows <- x@file@offset + startrow - 2 cols <- endcol-startcol+1 r <- raster(x) nrow(r) <- nrows tr <- blockSize(r, minblocks=1) for (i in 1:tr$n) { start <- skiprows + tr$row[i] d <- matrix( scan(filename(x), skip=start, nlines=tr$nrows[i], what='character', quiet=TRUE), ncol=tr$nrows[i]) v[,tr$row[i]:(tr$row[i]+tr$nrows[i]-1)] <- as.numeric(d[startcol:endcol, ]) } v <- as.vector(v) } else { skiprows <- x@file@offset + startrow - 1 v <- as.numeric ( scan(filename(x), skip=skiprows, nlines=nrows, what='character', quiet=TRUE) ) } # if (x@file@nodatavalue < 0) { # v[v <= x@file@nodatavalue ] <- NA # } else { v[v == x@file@nodatavalue ] <- NA # } return ( v ) } .readCellsAscii <- function(raster, cells) { colrow <- matrix(ncol=5, nrow=length(cells)) colrow <- matrix(ncol=5, nrow=length(cells)) colrow[,1] <- colFromCell(raster, cells) colrow[,2] <- rowFromCell(raster, cells) colrow[,3] <- cells colrow[,4] <- NA rows <- stats::na.omit(unique(colrow[order(colrow[,2]), 2])) for (i in 1:length(rows)) { v <- .readRowsAscii(raster, rows[i], 1, 1, raster@ncols) thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] colrow[colrow[,2] == rows[i],4] <- v[thisrow[,1]] } return(colrow[,4]) } raster/R/xyResolution.R0000644000176200001440000000242314507510157014630 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod('xres', signature(x='BasicRaster'), function(x) { if (rotated(x)) { return(x@rotation@geotrans[3]) } else { e <- x@extent return ( (e@xmax - e@xmin) / x@ncols ) } } ) setMethod('yres', signature(x='BasicRaster'), function(x) { if (rotated(x)) { return(x@rotation@geotrans[5]) } else { e <- x@extent return ( (e@ymax - e@ymin) / x@nrows ) } } ) setMethod('res', signature(x='BasicRaster'), function(x) { if (rotated(x)) { return(x@rotation@geotrans[c(2,6)]) } else { e <- x@extent xr <- (e@xmax - e@xmin) / x@ncols yr <- (e@ymax - e@ymin) / x@nrows return( c(xr, yr) ) } } ) setMethod('res<-', signature(x='BasicRaster'), function(x, value) { if (rotated(x)) { stop('cannot set the resolution of a rotated raster') } if (length(value) == 1) { xr=value yr=value } else { xr=value[1] yr=value[2] } bb <- extent(x) nc <- max(1, round( (bb@xmax - bb@xmin) / xr )) nr <- max(1, round( (bb@ymax - bb@ymin) / yr )) if (nr != x@nrows | nc != x@ncols) { if (methods::extends(class(x), "Raster")) { x <- clearValues(x) } } bb@xmax <- bb@xmin + nc * xr bb@ymin <- bb@ymax - nr * yr extent(x) <- bb dim(x) <- c(nr, nc) return(x) } ) raster/R/quantile.R0000644000176200001440000000161514507510157013730 0ustar liggesusers# Author: Robert J. Hijmans # r.hijmans@gmail.com # Date : October 2008 # Licence GPL v3 setMethod('quantile', signature(x='Raster'), function(x, ..., na.rm=TRUE, ncells=NULL) { if (is.null(ncells)) { v <- try ( getValues(x) ) if (inherits(v, "try-error")) { stop('raster too large. You can sample it with argument "ncells"') } } else { if (ncells >= ncell(x)) { v <- try ( getValues(x) ) } else { v <- try ( sampleRandom(x, ncells) ) } if (inherits(v, "try-error")) { stop('ncells too large') } } #if (na.rm) { # v <- stats::na.omit(v) #} if (nlayers(x)==1) { return(quantile(v, ..., na.rm=na.rm)) } else { # t(apply(v, 2, quantile, na.rm=TRUE)) q <- stats::quantile(v[,1], ..., na.rm=na.rm) for (i in 2:nlayers(x)) { q <- rbind(q, stats::quantile(v[,i], ..., na.rm=na.rm)) } rownames(q) <- names(x) return(q) } } ) raster/R/clump.R0000644000176200001440000000654014507510157013230 0ustar liggesusers# Authors: Robert J. Hijmans and Jacob van Etten, # Date : May 2010 # Version 1.0 # Licence GPL v3 # RH: updated for igraph (from igraph0) # sept 23, 2012 .smallClump <- function(x, directions=8) { x1 <- raster(x) val <- which(getValues(x) != 0) if (length(val) == 0) { return( setValues(x1, NA) ) } adjv <- as.vector(t(adjacent(x1, val, directions=directions, target=val, pairs=TRUE))) # RH. To fix problem of missing single cells, perhaps more efficient than "include=T" in adjacent add <- val[! val %in% adjv] adjv <- c(adjv, rep(add, each=2)) cl <- igraph::clusters(igraph::graph(adjv, directed=FALSE))$membership[val] cl <- as.numeric(as.factor(cl)) # RH force 1 to n x1[val] <- cl return(x1) } setMethod('clump', signature(x='RasterLayer'), function(x, filename='', directions=8, gaps=TRUE, ...) { if( !requireNamespace("igraph")) { stop('you need to install the igraph package to be able to use this function') } if (! directions %in% c(4,8)) { stop('directions should be 4 or 8') } filename <- trim(filename) if (filename != "" & file.exists(filename)) { if (! .overwrite(...)) { stop("file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it") } } datatype <- list(...)$datatype out <- raster(x) if (canProcessInMemory(out, 3)) { x <- .smallClump(x, directions) names(x) <- 'clumps' if (filename != '') { if (is.null(datatype)) { x <- writeRaster(x, filename, datatype='INT4S') } else { x <- writeRaster(x, filename, ...) } } return(x) } # else names(out) <- 'clumps' out <- writeStart(out, filename=rasterTmpFile(), datatype='INT4S') tr <- blockSize(out, minrows=3) pb <- pbCreate(tr$n, label='clump', ...) ext <- c(xmin(out), xmax(out), ymax(out), NA) maxval <- 0 rcl <- matrix(nrow=0, ncol=2) for (i in 1:tr$n) { ext[4] <- yFromRow(out, tr$row[i]) + 0.5 * yres(out) endrow <- tr$row[i] + tr$nrows[i] - 1 ext[3] <- yFromRow(out, endrow) - 1.5 * yres(out) # one additional row for overlap xc <- crop(x, extent(ext)) xc <- .smallClump(xc, directions) + maxval if (i > 1) { firstrow <- getValues(xc, 1) rc <- stats::na.omit(unique(cbind(lastrow, firstrow))) rcl <- rbind(rcl, rc) } lastrow <- getValues(xc, nrow(xc)) mv <- maxValue(xc) if (!is.na(mv)) { maxval <- mv } out <- writeValues(out, getValues(xc, 1, tr$nrows[i]), tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) if (nrow(rcl) > 0) { g <- igraph::graph.edgelist(rcl, directed=FALSE) clumps <- igraph::clusters(g)$membership rc <- cbind(igraph::V(g), clumps) i <- rc[,1] != rc[,2] rc <- rc[i, ,drop=FALSE] if (is.null(datatype)) { out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) } else { out <- subs(out, data.frame(rc), subsWithNA=FALSE, filename=filename, ...) } return(out) } else if (!gaps) { un <- unique(out) un <- data.frame(cbind(un, clumps=1:length(un))) if (is.null(datatype)) { return( subs(out, un, subsWithNA=FALSE, filename=filename, datatype='INT4S', ...) ) } else { return( subs(out, un, subsWithNA=FALSE, filename=filename, ...) ) } } else if (filename != '') { if (is.null(datatype)) { return( writeRaster(out, filename=filename, datatype='INT4S', ...) ) } else { return( writeRaster(out, filename=filename, ...) ) } } else { return(out) } } ) raster/R/stackFile.R0000644000176200001440000000250214507510157014007 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 stackOpen <- function(stackfile) { f <- utils::read.table(stackfile, as.is=FALSE, strip.white=TRUE) if (dim(f)[2] > 1) { s <- stack(as.vector(f[,1]), bands=as.vector(f[,2])) } else { s <- stack(as.vector(f[,1])) } s@filename <- stackfile return(s) } ..stackOpen <- function(stackfile, quick=FALSE) { f <- utils::read.table(stackfile, as.is=FALSE, strip.white=TRUE) if (quick) { if (dim(f)[2] > 1) { s <- .quickStack(f[,1], f[,2], f[,3]) } else { s <- .quickStack(f[,1]) } } else { if (dim(f)[2] > 1) { s <- stack(as.vector(f[,1]), bands=as.vector(f[,2])) } else { s <- stack(as.vector(f[,1])) } } s@filename <- stackfile return(s) } stackSave <- function(x, filename) { filename <- trim(filename) if (filename == "") { stop('Provide a non empty filename.') } info <- t( sapply(x@layers, function(i) c(i@file@name, i@file@nbands, i@data@band)) ) if (any(info[,1] == '')) { stop("cannot save a RasterStack that has layers that only exist in memory. Use writeRaster first/instead.") } if (any(info[,2] != '1')) { utils::write.table(info, filename, row.names=FALSE, col.names=FALSE) } else { utils::write.table(info[,1], filename, row.names=FALSE, col.names=FALSE) } x@filename <- filename return(x) } raster/R/rasterFromSurferFile.R0000644000176200001440000000621414507510157016221 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 .isSurferFile <- function(filename, version=FALSE) { con <- file(filename, "rb") id <- readBin(con, "character", n=1, size=4) close(con) if (id == 'DSBB') { if (version) { return(6) } else { return (TRUE) } } con <- file(filename, "rb") id <- readBin(con, "numeric", n=1, size=4) close(con) if (id == as.numeric(0x42525344)) { if (version) { return(7) } else { return (TRUE) } } else { return (FALSE) } } .rasterFromSurferFile <- function(filename) { v <- .isSurferFile(filename, TRUE) if (v == 6) { return ( .rasterFromSurfer6(filename) ) } else if (v == 7) { return ( .rasterFromSurfer7(filename) ) } else { stop ('not a (recognized) binary Surfer file') } } .rasterFromSurfer6 <- function(filename) { con <- file(filename, "rb") r <- raster() id <- readBin(con, "character", n=1, size=4) r@ncols <- readBin(con, "int", n=1, size=2) r@rows <- readBin(con, "int", n=1, size=2) r@extent@xmin <- readBin(con, "double", n=1, size=8) r@extent@xmax <- readBin(con, "double", n=1, size=8) r@extent@ymin <- readBin(con, "double", n=1, size=8) r@extent@ymax <- readBin(con, "double", n=1, size=8) r@data@min <- readBin(con, "double", n=1, size=8) r@data@max <- readBin(con, "double", n=1, size=8) close(con) r@file@offset <- 56 r@file@toptobottom <- FALSE dataType(r) <- 'FLT4S' r@data@fromdisk <- TRUE r@file@driver <- "surfer" return(r) } .rasterFromSurfer7 <- function(filename) { # source: http://www.geospatialdesigns.com/surfer7_format.htm con <- file(filename, "rb") r <- raster() id <- readBin(con, "numeric", n=1, size=4) size <- readBin(con, "numeric", n=1, size=4) offset <- size + 8 seek(con, size, origin = "current") id <- readBin(con, "numeric", n=1, size=4) if (id != as.numeric(0x44495247)) { # should be 0x44495247 grid section # get size and skip to the next section stop('file with this section not yet supported') } size <- readBin(con, "numeric", n=1, size=4) offset <- offset + size + 8 r@rows <- as.integer(readBin(con, "numeric", n=1, size=4)) r@cols <- as.integer(readBin(con, "numeric", n=1, size=4)) r@extent@xmin <- readBin(con, "double", n=1, size=8) r@extent@ymin <- readBin(con, "double", n=1, size=8) xr <- readBin(con, "double", n=1, size=8) yr <- readBin(con, "double", n=1, size=8) r@extent@xmax <- r@extent@xmin + xr * r@cols r@extent@ymax <- r@extent@ymin + yr * r@rows r@data@min <- readBin(con, "double", n=1, size=8) r@data@max <- readBin(con, "double", n=1, size=8) rotation <- readBin(con, "double", n=1, size=8) if (rotation != 0) { stop('rotation != 0, cannot use this file') } r@data@max <- readBin(con, "double", n=1, size=8) r@file@nodatavalue <- readBin(con, "double", n=1, size=8) id <- readBin(con, "numeric", n=1, size=4) size <- readBin(con, "numeric", n=1, size=4) close(con) r@file@offset <- offset + 8 r@file@toptobottom <- FALSE if (ncell(r) / size == 4) { dataType(r) <- 'FLT4S' } else if (ncell(r) / size == 8) { dataType(r) <- 'FLT8S' } else { stop('sorry; cannot process this file') } r@file@driver <- "surfer" return(r) } raster/R/rasterFromASCII.R0000644000176200001440000000612014507510157014777 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromASCIIFile <- function(filename, offset=6, crs="", ...) { offset <- as.integer(offset) stopifnot(offset > 2) splitasc <- function(s) { s <- trim(s) spl <- unlist(strsplit(s, ''), use.names = FALSE) pos <- which(spl==' ')[1] first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } filename <- trim(filename) if (!file.exists(filename)) { stop(paste(filename, " does not exist")) } con <- file(filename, "rt") lines <- readLines(con, n=offset) close(con) ini <- lapply(lines, splitasc) ini <- matrix(unlist(ini, use.names = FALSE), ncol=2, byrow=TRUE) ini[,1] = toupper(ini[,1]) suppressWarnings( test <- sum(as.numeric(ini[,1]), na.rm=TRUE) > 0 ) if (test) { m <- 'The header of this file appears to be incorrect: there are numbers where there should be keywords' if (offset != 6) { m <- paste(m, '\n Are you using a wrong offset?', sep='') } stop(m) } nodataval <- xn <- yn <- d <- nr <- nc <- xc <- yc <- NA for (i in 1:nrow(ini)) { if (ini[i,1] == "NCOLS") { nc <- as.integer(ini[i,2]) } else if (ini[i,1] == "NROWS") { nr <- as.integer(ini[i,2]) } else if (ini[i,1] == "XLLCORNER") { xn <- as.numeric(ini[i,2]) } else if (ini[i,1] == "XLLCENTER") { xc <- as.numeric(ini[i,2]) } else if (ini[i,1] == "YLLCORNER") { yn <- as.numeric(ini[i,2]) } else if (ini[i,1] == "YLLCENTER") { yc <- as.numeric(ini[i,2]) } else if (ini[i,1] == "CELLSIZE") { d <- as.numeric(ini[i,2]) } else if (ini[i,1] == "NODATA_VALUE") { try (nodataval <- as.numeric(ini[i,2]), silent=TRUE) } else if (ini[i,1] == "NODATA") { try (nodataval <- as.numeric(ini[i,2]), silent=TRUE) } } if (is.na(nr)) stop('"NROWS" not detected') if (is.na(nc)) stop('"NCOLS" not detected') if (is.na(nodataval)) { warning('"NODATA_VALUE" not detected. Setting it to -Inf\n You can set it to another value with function "NAvalue"') nodataval <- -Inf } offwarn <- FALSE if (is.na(d)) { warning('"CELLSIZE" not detected. Setting it to 1.'); offwarn = TRUE d <- 1 } else if (d==0) { warning('"CELLSIZE" is reported as zero. Setting it to 1.'); d <- 1 } d <- abs(d) if (is.na(xn)) { if (is.na(xc)) { warning('"XLLCORNER" tag not detected. Setting it to 0.') offwarn = TRUE xn <- 0 } else { xn <- xc - 0.5 * d } } if (is.na(yn)) { if (is.na(yc)) { warning('"YLLCORNER" tag not detected. Setting it to 0.'); offwarn = TRUE yn <- 0 } else { yn <- yc - 0.5 * d } } if (offwarn) { m <- 'The georeference of this object is probably wrong\n' if (offset != 6) { m <- paste(m, ' Are you using a wrong offset? Proceed with caution!\n', sep='') } warning(m) } xx <- xn + nc * d yx <- yn + nr * d x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs='') x@data@fromdisk <- TRUE x@file@offset <- offset x@file@driver <- 'ascii' x@file@nodatavalue <- nodataval x@file@name <- filename if (!is.na(crs)) { projection(x) <- .spCRS() } return(x) } raster/R/stackQuick.R0000644000176200001440000000565114507510157014214 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2011 # Version 1.0 # Licence GPL v3 .quickStack <- function(files, nbands=1, band=1, native=FALSE) { r <- raster(files[[1]], native=native) if (length(nbands) == 1) { nbands <- rep(nbands, length(files)) } else { stopifnot(length(files == length(nbands))) } nbands <- as.integer(nbands) band <- as.integer(band) if (length(band) == 1) { band <- rep(band, length(files)) } else { stopifnot(length(files == length(band))) } r@data@haveminmax <- FALSE r@file@nbands <- nbands[1] r@data@band <- band[1] ln <- extension(basename(unlist(files)), '') s <- stack(r) s@layers <- sapply(1:length(files), function(i){ r@file@name <- files[[i]] r@file@nbands <- nbands[i] r@data@band <- band[i] r@data@names <- ln[i] r } ) s } .quickStackOneFile <- function(filename, bands=NULL, native=FALSE) { b <- brick(filename, native=native) .stackFromBrick(b, bands=bands) } .stackFromBrick <- function(b, bands=NULL) { nbands <- nlayers(b) if (is.null(bands)) { bands <- 1:nbands } else { if (is.character(bands)) { bands <- match(bands, names(b)) } bands <- bands[bands %in% 1:nbands] if (length(bands)==0) { bands <- 1:nbands } } bands <- as.integer(bands) havemnmx <- b@data@haveminmax if (havemnmx) { mn <- minValue(b) mx <- maxValue(b) } ln <- names(b) if (inMemory(b)) { r <- b[[ bands[1] ]] s <- stack(r) if (length(bands) > 1) { if (havemnmx) { s@layers <- sapply( bands, function(i) { r@data@values <- b@data@values[,i] r@data@names <- ln[i] r@data@min <- mn[i] r@data@max <- mx[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } else { s@layers <- sapply(bands, function(i){ r@data@values <- b@data@values[,i] r@data@names <- ln[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } } return(s) } r <- raster(b, bands[1]) s <- stack(r) if (length(bands) > 1) { if (havemnmx) { s@layers <- sapply(bands, function(i){ r@data@band <- i r@data@names <- ln[i] r@data@min <- mn[i] r@data@max <- mx[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } else { s@layers <- sapply(bands, function(i){ r@data@band <- i r@data@names <- ln[i] if (length(b@data@isfactor) >= i) { if (isTRUE(b@data@isfactor[i])) { r@data@isfactor <- b@data@isfactor[i] r@data@attributes <- b@data@attributes[i] } } r }) } } s } raster/R/intDataType.R0000644000176200001440000000404014507510157014327 0ustar liggesusers# raster package # Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 .checkIntDataType <- function(mn, mx, dtype) { mn <- round(mn) mx <- round(mx) ok <- TRUE if (dtype == 'INT') { return(.getIntDataType(mn, mx) ) } else if (dtype == 'INT1S') { if (mn < -127 | mx > 128) { ok <- FALSE } } else if (dtype == 'INT1U') { if (mn < 0 | mx > 256) { ok <- FALSE } } else if (dtype == 'INT2S') { if (mn < -32767 | mx > 32768) { ok <- FALSE } } else if (dtype == 'INT2U') { if (mn <= 0 | mx > 65534 ) { ok <- FALSE } } else if (dtype == 'INT4S') { if (mn < -2147483647 | mx > 2147483648 ) { ok <- FALSE } } else if (dtype == 'INT4U') { if (mn < 0 | mx > 2^32 ) { ok <- FALSE } # } else if (dtype == 'INT8S') { # if (mn < -2^63/2 | mx > 2^64/2) { # ok <- FALSE # } } else { stop('unknown integer type:', dtype) } if (!ok) { dtype <- .getIntDataType(mn, mx) warning('changed INT data type to: ', dtype) } return(dtype) } .getIntDataType <- function(mn, mx) { # optimize the number of bytes within the datatype if (mn > -128 & mx < 128) { datatype <- 'INT1S' } else if (mn >=0 & mx < 256) { datatype <- 'INT1U' } else if (mn > -32767 & mx < 32768) { datatype <- 'INT2S' } else if (mn >= 0 & mx < 65534 ) { datatype <- 'INT2U' } else if (mn > -2147483647 & mx < 2147483648 ) { datatype <- 'INT4S' } else if (mn > 0 & mx < 2^32 ) { datatype <- 'INT4U' ## } else if (mn > -(2^63/2) & mx < (2^64/2)) { # datatype <- 'INT8S' } else { stop('these values are too large to be saved as integers') } return(datatype) } ..intSetNA <- function(v, dtype) { if (dtype == 'INT1S') { v[v < -127 | v > 128] <- NA } else if (dtype == 'INT1U') { v[v <=0 | v > 256] <- NA } else if (dtype == 'INT2S') { v[v < -32767 | v > 32768] <- NA } else if (dtype == 'INT2U') { v[v <= 0 | v > 65534] <- NA } else if (dtype == 'INT4S') { v[v < -2147483647 | v > 2147483648] <- NA } else if (dtype == 'INT8S') { v[v < -2^63/2 | v > 2^64/2] <- NA } return(v) } raster/R/corLocal.R0000644000176200001440000001054114507510157013642 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2014 # Version 1.0 # Licence GPL v3 setMethod('corLocal', signature(x='RasterLayer', y='RasterLayer'), function(x, y, ngb=5, method = c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) { compareRaster(x,y) if (test) { out <- brick(x, values=FALSE, nl=2) names(out) <- c(method[1], 'p-value') } else { out <- raster(x) names(out) <- c(method[1]) } if (canProcessInMemory(x, n=2*ngb)) { vx <- getValuesFocal(x, 1, nrow(x), ngb=ngb) vy <- getValuesFocal(y, 1, nrow(y), ngb=ngb) if (test) { v <- matrix(NA, ncol=2, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[i, ] <- c(a$estimate, a$p.value) } } } else { v <- rep(NA, ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { v[i] <- stats::cor(z[,1], z[,2], method=method) } } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='corLocal', ...) out <- writeStart(out, filename=filename, ...) if (test) { for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- matrix(NA, ncol=2, nrow=nrow(vx)) for (j in 1:nrow(vx)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[j, ] <- c(a$estimate, a$p.value) } } out <- writeValues(out, v, tr$row[i]) } } else { for (i in 1:tr$n) { vx <- getValuesFocal(x, tr$row[i], tr$nrows[i], ngb=ngb) vy <- getValuesFocal(y, tr$row[i], tr$nrows[i], ngb=ngb) v <- rep(NA, nrow(vx)) for (j in 1:length(v)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { v[j] <- stats::cor(z[,1], z[,2], method=method) } } out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } ) setMethod('corLocal', signature(x='RasterStackBrick', y='RasterStackBrick'), function(x, y, method = c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) { compareRaster(x,y) nl1 <- nlayers(x) nl2 <- nlayers(y) if (nl1 != nl2) { stop('nlayers does not match') } if (nl1 < 3) { stop('number of layers should be > 2') } if (test) { out <- brick(x, values=FALSE, nl=2) names(out) <- c(method[1], 'p-value') } else { out <- raster(x) names(out) <- c(method[1]) } if (canProcessInMemory(x)) { vx <- getValues(x) vy <- getValues(y) if (test) { v <- matrix(NA, ncol=2, nrow=ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[i, ] <- c(a$estimate, a$p.value) } } } else { v <- rep(NA, ncell(x)) for (i in 1:ncell(x)) { z <- stats::na.omit(cbind(vx[i,], vy[i,])) if (nrow(z) > 2) { v[i] <- stats::cor(z[,1], z[,2], method=method) } } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='corLocal', ...) out <- writeStart(out, filename=filename, ...) if (test) { for (i in 1:tr$n) { vx <- getValues(x, tr$row[i], tr$nrows[i]) vy <- getValues(y, tr$row[i], tr$nrows[i]) v <- matrix(NA, ncol=2, nrow=nrow(vx)) for (j in 1:nrow(vx)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { a <- stats::cor.test(z[,1], z[,2], method=method) v[j, ] <- c(a$estimate, a$p.value) } } out <- writeValues(out, v, tr$row[i]) } } else { for (i in 1:tr$n) { vx <- getValues(x, tr$row[i], tr$nrows[i]) vy <- getValues(y, tr$row[i], tr$nrows[i]) v <- rep(NA, nrow(vx)) for (j in 1:length(v)) { z <- stats::na.omit(cbind(vx[j,], vy[j,])) if (nrow(z) > 2) { v[j] <- stats::cor(z[,1], z[,2], method=method) } } out <- writeValues(out, v, tr$row[i]) } } return(writeStop(out)) } } ) raster/R/blockSize.R0000644000176200001440000000172614507510157014036 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 setMethod("blockSize", signature(x="Raster"), function(x, chunksize, n=nlayers(x), minblocks=4, minrows=1) { n <- max(n, 1) if (missing(chunksize)) { bs <- .chunk() } else { bs <- chunksize } blockrows <- try(methods::slot(x@file, 'blockrows'), silent=TRUE) if (inherits(blockrows, 'try-error')) { blockrows <- 1 } blockrows <- max(blockrows, 1) nr <- nrow(x) size <- min(nr, max(1, floor(bs / (ncol(x) * n * 8)))) # min number of chunks if (size > 1) { minblocks <- min(nr, max(1, minblocks)) size <- min(ceiling(nr/minblocks), size) } size <- min(max(size, minrows), nr) size <- max(minrows, blockrows * round(size / blockrows)) nb <- ceiling(nr / size) row <- (0:(nb-1))*size + 1 nrows <- rep(size, length(row)) dif = nb * size - nr nrows[length(nrows)] = nrows[length(nrows)] - dif return(list(row=row, nrows=nrows, n=nb)) } ) raster/R/factor.R0000644000176200001440000001070714507510157013366 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2010 / June 2012 # Version 1.0 # Licence GPL v3 factorValues <- function(x, v, layer=1, att=NULL, append.names=FALSE) { stopifnot(is.factor(x)[layer]) rat <- levels(x)[[layer]] if (!is.data.frame(rat)) { rat <- rat[[1]] } # if (colnames(rat)[2]=='WEIGHT') { # i <- which(match(rat$ID, round(v))==1) # } else { i <- match(round(v), rat$ID) # } r <- rat[i, -1, drop=FALSE] rownames(r) <- NULL if (!is.null(att)) { if (is.character(att)) { att <- stats::na.omit(match(att, colnames(r))) if (length(att) == 0) { warning("att does not includes valid names") } else { r <- r[, att, drop=FALSE] } } else { r <- r[, att, drop=FALSE] } } if (append.names) { colnames(r) <- paste(names(x)[layer], colnames(r), sep="_") } r } .insertFacts <- function(x, v, lyrs) { facts <- is.factor(x)[lyrs] if (!any(facts)) { return(v) } i <- which(facts) v <- lapply(1:length(facts), function(i) { if (facts[i]) { data.frame(factorValues(x, v[, i], i, append.names=TRUE)) } else { v[, i, drop=FALSE] } } ) do.call(data.frame, v) } setMethod('is.factor', signature(x='Raster'), function(x) { f <- x@data@isfactor nl <- nlayers(x) if (length(f) < nl) { f <- c(f, rep(FALSE, nl))[1:nl] } f } ) setMethod('is.factor', signature(x='RasterStack'), function(x) { if (nlayers(x) > 0) { s <- sapply(x@layers, function(x) x@data@isfactor) return(s) } else { return(FALSE) } } ) if (!isGeneric("levels")) { setGeneric("levels", function(x) standardGeneric("levels")) } setMethod('levels', signature(x='Raster'), function(x) { f <- is.factor(x) if (any(f)) { if (inherits(x, 'RasterStack')) { return( sapply(x@layers, function(i) i@data@attributes) ) } else { return(x@data@attributes) } } else { return(NULL) } } ) .checkLevels <- function(old, newv) { if (! is.data.frame(newv)) { stop('new raster attributes (factor values) should be in a data.frame (inside a list)') } if (! ncol(newv) > 0) { stop('the number of columns in the raster attributes (factors) data.frame should be > 0') } if (! colnames(newv)[1] == c('ID')) { stop('the first column name of the raster attributes (factors) data.frame should be "ID"') } if (!is.null(old)) { # if (colnames(newv)[2] == 'WEIGHT') { # if (nrow(newv) < nrow(old)) { # warning('the number of rows in the raster attributes (factors) data.frame is lower than expected (values missing?)') # } # if (! all(unique(sort(newv[,1])) == sort(unique(old[,1])))) { # warning('the values in the "ID" column in the raster attributes (factors) data.frame have changed') # } # } else { if (! nrow(newv) == nrow(old)) { warning('the number of rows in the raster attributes (factors) data.frame is unexpected') } if (! all(sort(newv[,1]) == sort(old[,1]))) { warning('the values in the "ID" column in the raster attributes (factors) data.frame have changed') } # } } newv[, 1] <- as.integer(newv[, 1]) # if (colnames(newv)[2] == 'WEIGHT') { # newv[, 2] <- as.numeric(newv[, 2]) # } newv } setMethod('levels<-', signature(x='Raster'), function(x, value) { if (is.null(value)) { return(x) } isfact <- is.factor(x) if (inherits(x, 'RasterLayer')) { if (!is.data.frame(value)) { if (is.list(value)) { value <- value[[1]] } } value <- .checkLevels(levels(x)[[1]], value) x@data@attributes <- list(value) x@data@isfactor <- TRUE return(x) } i <- sapply(value, function(x) length(x) > 0) if ( any(i) ) { stopifnot (length(value) == nlayers(x)) levs <- levels(x) for (j in which(i)) { a <- levs[[j]] b <- value[[j]] if (is.list(a)) a <- a[[1]] if (is.list(b)) b <- b[[1]] value[[j]] <- .checkLevels(a, b) } x@data@attributes <- value x@data@isfactor <- i } else { x@data@attributes <- list() } x@data@isfactor <- i return(x) } ) setMethod('as.factor', signature(x='RasterLayer'), function(x) { ratify(x) } ) if (!isGeneric("asFactor")) { setGeneric("asFactor", function(x, ...) standardGeneric("asFactor")) } setMethod('asFactor', signature(x='RasterLayer'), function(x, value=NULL, ...) { #warning("please use as.factor") x@data@isfactor <- TRUE if (is.null(value) ) { #x <- round(x) #this makes methods::slot( isfactor FALSE again x@data@attributes <- list(data.frame(VALUE=unique(x))) } else { x@data@attributes <- value } return(x) } ) raster/R/bilinearValue.R0000644000176200001440000000622214507510157014667 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Licence GPL v3 # updated November 2011 # version 1.0 .bilinearValue <- function(raster, xyCoords, layer, n) { #bilinear <- function(xy, x, y, v) { # .doBilinear(xy, x, y, v) #} r <- raster(raster) nls <- nlayers(raster) four <- fourCellsFromXY(r, xyCoords, duplicates=FALSE) xy4 <- matrix(xyFromCell(r, as.vector(four)), ncol=8) x <- rbind(.doSpmin(xy4[,1], xy4[,3]), .doSpmax(xy4[,1], xy4[,3])) y <- rbind(.doSpmin(xy4[,5], xy4[,6]), .doSpmax(xy4[,5], xy4[,6])) # data.frame is faster than cbind in this case (less copying?) xy4 <- data.frame( x = c(x[1,], x[1,], x[2,], x[2,]), y = c(y[1,], y[2,], y[1,], y[2,]) ) cells <- cellFromXY(r, xy4) suppressWarnings(row1 <- rowFromCell(r, min(cells, na.rm=TRUE))) if (is.na(row1)) { if (nls == 1) { return(rep(NA, nrow(xyCoords))) } else { return(matrix(NA, nrow= nrow(xyCoords), ncol=nls)) } } nrows <- rowFromCell(r, max(cells, na.rm=TRUE)) - row1 + 1 offs <- cellFromRowCol(r, row1, 1) - 1 cells <- cells - offs if (nls == 1) { vv <- getValues(raster, row1, nrows) v <- matrix( vv[cells], ncol=4) res <- rep(NA, nrow(v)) rs <- rowSums(is.na(v)) i <- rs==3 if (sum(i) > 0) { cells <- cellFromXY(raster, xyCoords[i,]) - offs res[i] <- vv[cells] } i <- rs > 0 & rs < 3 if (sum(i) > 0) { vv <- v[i,,drop=FALSE] vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2] vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1] vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4] vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3] vmean <- rep(rowMeans(vv, na.rm=TRUE), 4) vv[is.na(vv)] <- vmean[is.na(vv)] # res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], vv) res[i] <- .doBilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv) } i <- rs==0 if (sum(i) > 0) { # res[i] <- bilinear(xyCoords[i,1], xyCoords[i,2], x[1,i], x[2,i], y[1,i], y[2,i], v[i,]) res[i] <- .doBilinear(xyCoords[i, ,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE]) } res } else { if (missing(layer)) { layer <- 1 } if (missing(n)) { n <- (nls-layer+1) } lyrs <- layer:(layer+n-1) allres <- matrix(ncol=length(lyrs), nrow=nrow(xyCoords)) colnames(allres) <- names(raster)[lyrs] cvv <- getValues(raster, row1, nrows)[, lyrs] cv <- cvv[cells,] for (j in 1:ncol(cv)) { v <- matrix(cv[, j], ncol=4) res <- rep(NA, nrow(v)) rs <- rowSums(is.na(v)) i <- rs==3 if (sum(i) > 0) { cells <- cellFromXY(raster, xyCoords[i,]) - offs res[i] <- cvv[cells, j] } i <- rs > 0 & rs < 3 if (sum(i) > 0) { vv <- v[i,,drop=FALSE] vv[is.na(vv[,1]),1] <- vv[is.na(vv[,1]),2] vv[is.na(vv[,2]),2] <- vv[is.na(vv[,2]),1] vv[is.na(vv[,3]),3] <- vv[is.na(vv[,3]),4] vv[is.na(vv[,4]),4] <- vv[is.na(vv[,4]),3] vmean <- rep(rowMeans(vv, na.rm=TRUE), 4) vv[is.na(vv)] <- vmean[is.na(vv)] res[i] <- .doBilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], vv) } i <- rs==0 if (sum(i) > 0) { res[i] <- .doBilinear(xyCoords[i,,drop=FALSE], x[,i,drop=FALSE], y[,i,drop=FALSE], v[i,,drop=FALSE]) } allres[,j] <- res } allres } } raster/R/destair.R0000644000176200001440000000171514507510157013542 0ustar liggesusers .destair <- function(x, keepExtent=TRUE) { pts <- data.frame(geom(as(x, 'SpatialPolygons'))) if (keepExtent) { bb <- sp::bbox(x) ptsx1 <- pts[,5] == bb[1,1] ptsx2 <- pts[,5] == bb[1,2] ptsy1 <- pts[,6] == bb[2,1] ptsy2 <- pts[,6] == bb[2,2] } u <- unique(pts$cump) for (j in u) { k <- pts$cump==j p <- pts[k, 5:6] p <- rbind(p[(nrow(p)-1), ,drop=FALSE], p, p[2,,drop=FALSE]) dx <- diff(p$x) dy <- diff(p$y) tf1 <- rowSums( cbind(dx[-length(dx)], dy[-1]) ) tf2 <- rowSums( cbind(dx[-1], dy[-length(dy)]) ) i <- which(tf1==0 | tf2==0) + 1 p[i, ] <- (p[i-1, ] + p[i+1, ] + 2 * p[i, ]) / 4 pts[k, 5:6] <- p[-c(1, nrow(p)),] } if (keepExtent) { pts[ptsx1,5] <- bb[1,1] pts[ptsx2,5] <- bb[1,2] pts[ptsy1,6] <- bb[2,1] pts[ptsy2,6] <- bb[2,2] } r <- as(pts, 'SpatialPolygons') row.names(r) <- row.names(x) crs(r) <- .getCRS(x) if (.hasSlot(x, 'data')) { r <- sp::SpatialPolygonsDataFrame(r, x@data) } r } raster/R/writeStartStop.R0000644000176200001440000000554714560142476015140 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod("writeStart", signature(x="RasterLayer", filename="character"), function(x, filename, options=NULL, format, prj=FALSE, ...) { if (trim(filename) == "") { filename <- rasterTmpFile() } filename <- .fullFilename(filename, expand=TRUE) if (!file.exists(dirname(filename))) { stop("Attempting to write a file to a path that does not exist:\n ", dirname(filename)) } filetype <- .filetype(format=format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype=="ascii") { x <- .startAsciiWriting(x, filename, ...) } else if ( filetype %in% .nativeDrivers() ) { x <- .startRasterWriting(x, filename, format=filetype, ...) } else if ( filetype == "CDF" ) { x <- .startWriteCDF(x, filename, ...) # } else if ( filetype == "big.matrix" ) { # x <- .startBigMatrixWriting(x, filename, ...) } else { x <- .startGDALwriting(x, filename, gdal=options, format=filetype, ...) } if (prj) { wk <- wkt(x) if (wk != "") { writeLines(wk, 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, gdal=options, format=filetype, ...) } if (prj) { crs <-.getCRS(x) if (!is.na(crs)) { writeLines(wkt(x), extension(filename, "prj") ) } } return(x) }) setMethod("writeStop", signature(x="RasterLayer"), function(x) { driver <- x@file@driver if ( driver %in% .nativeDrivers() ) { return( .stopRasterWriting(x) ) # } else if ( driver == "big.matrix" ) { # return( .stopBigMatrixWriting(x) ) } else if ( driver == "ascii" ) { return( .stopAsciiWriting(x) ) } else if ( driver == "netcdf" ) { return( .stopWriteCDF(x) ) } else { return( .stopGDALwriting(x) ) } } ) setMethod("writeStop", signature(x="RasterBrick"), function(x) { driver <- x@file@driver if (driver %in% .nativeDrivers()) { return( .stopRasterWriting(x) ) } else if ( driver == "netcdf" ) { return( .stopWriteCDF(x) ) # } else if ( driver == "big.matrix" ) { # return( .stopBigMatrixWriting(x) ) } else { return( .stopGDALwriting(x) ) } } ) raster/R/labels.R0000644000176200001440000000146714507510157013355 0ustar liggesusers .polygonLabelPosition <- function(x, cex=1) { xy <- sp::coordinates(x) # make sure that labels are inside of polygons sx <- sp::geometry(x) k <- extract(sx, xy) k <- which(k[,1] != k[,2]) if (length(k) > 0) { for (i in k) { pol <- sx[i, ] e <- extent(pol) p1 <- xy[i, ,drop=FALSE] dx <- 0.25 * (e@xmax - e@xmin) dy <- 0.25 * (e@ymax - e@ymin) fixed <- FALSE for (j in 1:4) { if (j < 3) { p[1,1] <- p1[1,1] - dx } else { p[1,1] <- p1[1,1] + dx } if (j %in% c(2,3)) { p[1,2] <- p1[1,2] - dy } else { p[1,2] <- p1[1,2] + dy } z <- extract(pol, rbind(p,p)) if (!is.na(z[1,2])) { xy[i, ] <- p break fixed <- TRUE } } if (!fixed) print(paste(i, 'not fixed')) } } # make sure that labels do not overlap? xy } raster/R/sparse.R0000644000176200001440000001256014507510157013404 0ustar liggesusers#to be removed #setAs('RasterLayerSparse', 'RasterLayer', function(from){ raster(from) } ) setClass ("RasterLayerSparse", contains = "RasterLayer", representation ( index = "vector" ), prototype ( index = vector(mode="numeric") ) ) setMethod('raster', signature(x='RasterLayerSparse'), function(x) { r <- raster(x@extent, nrows=x@nrows, ncols=x@ncols, crs=.getCRS(x)) if (length(stats::na.omit(x@data@values)) > 0) { v <- rep(NA, ncell(r)) v[x@index] <- x@data@values setValues(r, v) } else { r } } ) setClass (".RasterBrickSparse", contains = "RasterBrick", representation ( index = "vector" ), prototype ( index = vector(mode="numeric") ) ) setAs('RasterLayer', 'RasterLayerSparse', function(from){ x <- methods::new('RasterLayerSparse') v <- stats::na.omit(cbind(1:ncell(from), getValues(from))) setValues(x, v[,2], v[,1]) } ) setMethod("Arith", signature(e1='RasterLayerSparse', e2='numeric'), function(e1, e2){ if (!hasValues(e1)) { stop('RasterLayerSparse has no values') } stopifnot(length(e2) == 1) setValues(e1, methods::callGeneric(as.numeric(e1@data@values), e2)) } ) setMethod("Arith", signature(e1='numeric', e2='RasterLayerSparse'), function(e1, e2){ if (!hasValues(e2)) { stop('RasterLayerSparse has no values') } stopifnot(length(e1) == 1) setValues(e2, methods::callGeneric(as.numeric(e2@data@values), e1) ) } ) setMethod("Math", signature(x='RasterLayerSparse'), function(x){ if (!hasValues(x)) { return(x) } # funname <- as.character(sys.call(sys.parent())[[1]]) funname <- .Generic if (substr(funname, 1, 3) == 'cum' ) { setValues(x, do.call(funname, list(x@data@values))) } else { setValues(x, methods::callGeneric(x@data@values)) } } ) setMethod('setValues', signature(x='RasterLayerSparse'), function(x, values, index=NULL, ...) { stopifnot(is.vector(values)) if (!(is.numeric(values) | is.integer(values) | is.logical(values))) { stop('values must be numeric, integer or logical.') } if (is.null(index)) { if (! hasValues(x)) { stop('you must supply an index argument if the RasterLayerSparse does not have values') } stopifnot(length(x@index) == length(values)) } else { stopifnot(is.vector(index)) stopifnot(length(index) == length(values)) stopifnot(all(index > 0 | index <= ncell(x))) x@index <- index } x@data@inmemory <- TRUE x@data@fromdisk <- FALSE x@file@name <- "" x@file@driver <- "" x@data@values <- values x <- setMinMax(x) return(x) } ) setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='missing'), function(x, row, nrows) { getValues(x, row=row, nrows=1) } ) setMethod('getValues', signature(x='RasterLayerSparse', row='numeric', nrows='numeric'), function(x, row, nrows, format='') { row <- round(row) nrows <- round(nrows) stopifnot(validRow(x, row)) stopifnot(nrows > 0) row <- min(x@nrows, max(1, row)) endrow <- max(min(x@nrows, row+nrows-1), row) nrows <- endrow - row + 1 nc <- ncol(x) startcell <- cellFromRowCol(row, 1) lastcell <- cellFromRowCol(endrow, nc) if (inMemory(x)){ i <- which(x@index >= startcell & x@index <= lastcell) if (length(i) > 0) { v <- cellFromRowColCombine(x, row:endrow, 1:nc) m <- match(i, v) v[] <- NA v[m] <- x@data@values[i] } else { v <- rep(NA, nrows * x@ncols) } } else if ( fromDisk(x) ) { # not yet implemented ## v <- .readRasterLayerValues(x, row, nrows) } else { v <- rep(NA, nrows * x@ncols) } if (format=='matrix') { v <- matrix(v, nrow=nrows, byrow=TRUE) rownames(v) <- row:(row+nrows-1) colnames(v) <- 1:ncol(v) } return(v) } ) setMethod('getValuesBlock', signature(x='RasterLayerSparse'), function(x=1, row, nrows=1, col=1, ncols=(ncol(x)-col+1), format='', ...) { row <- max(1, min(x@nrows, round(row[1]))) lastrow <- min(x@nrows, row + round(nrows[1]) - 1) nrows <- lastrow - row + 1 col <- max(1, min(x@ncols, round(col[1]))) lastcol <- col + round(ncols[1]) - 1 ncols <- lastcol - col + 1 startcell <- cellFromRowCol(x, row, col) lastcell <- cellFromRowCol(x, lastrow, lastcol) if (!(validRow(x, row))) { stop(paste(row, 'is not a valid rownumber')) } if ( inMemory(x) ) { i <- which(x@index >= startcell & x@index <= lastcell) if (length(i) > 0) { res <- cellFromRowColCombine(x, row:lastrow, col:lastcol) m <- match(i, res) res[] <- NA res[m] <- x@data@values[i] } else { res <- rep(NA, nrows * ncols) } } else if ( fromDisk(x) ) { # not yet implemented #if (! fromDisk(x)) { # return(rep(NA, times=(lastcell-startcell+1))) #} #res <- .readRasterLayerValues(x, row, nrows, col, ncols, is.open) } else { res <- rep(NA, nrows * ncols) } if (format=='matrix') { res = matrix(res, nrow=nrows , ncol=ncols, byrow=TRUE ) colnames(res) <- col:lastcol rownames(res) <- row:lastrow } res } ) setMethod("getValues", signature(x='RasterLayerSparse', row='missing', nrows='missing'), function(x, format='') { cr <- c(x@ncols, x@nrows) if ( inMemory(x) ) { i <- x@index v <- x@data@values x <- rep(NA, ncell(x)) x[i] <- v } else if ( fromDisk(x) ) { # not yet implemented ### x <- .readRasterLayerValues(x, 1, x@nrows) } else { x <- rep(NA, ncell(x)) } if (format=='matrix') { x <- matrix(x, ncol=cr[1], nrow=cr[2], byrow=TRUE) } return( x ) } ) raster/R/stackApply.R0000644000176200001440000000417414507510157014224 0ustar liggesusers# Author: Robert J. Hijmans # Date: August 2010 # Version 1 # Licence GPL v3 stackApply <- function(x, indices, fun, filename='', na.rm=TRUE, ...) { nl <- nlayers(x) if (nl == 1) { makemat <- TRUE } else { makemat <- FALSE } fnames <- FALSE if (is.factor(indices)) { nms <- levels(indices) indices <- as.integer(indices) fnames <- TRUE } ind <- vector(length=nl) # perhaps we need recycling: ind[] <- indices uin <- unique(ind) if (fnames) { layernames <- paste0('level_', nms[uin]) } else { layernames <- paste0('index_', uin) } nlout <- length(uin) if (nlout > 1) { out <- brick(x, values=FALSE) out@data@nlayers <- nlout } else { out <- raster(x) } names(out) <- layernames filename <- trim(filename) rowcalc <- FALSE fun <- .makeTextFun(fun) if (inherits(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==i, drop=FALSE], na.rm=na.rm)) } else { v <- lapply(uin, function(i, ...) apply(a[, ind==i, drop=FALSE], 1, fun, na.rm=na.rm)) } v <- do.call(cbind, v) out <- writeValues(out, v, tr$row[i]) pbStep(pb) } out <- writeStop(out) # only raster format stores layer names names(out) <- layernames pbClose(pb) return(out) } raster/R/slopeAspect.R0000644000176200001440000000443414507510157014372 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2011 # Version 1.0 # Licence GPL v3 slopeAspect <- function(dem, filename='', out=c('slope', 'aspect'), unit='radians', neighbors=8, flatAspect, ...) { warning('this function is deprecated. Please use function "terrain" instead') stopifnot(neighbors %in% c(4, 8)) stopifnot(! is.na(projection(dem)) ) unit <- trim(tolower(unit)) stopifnot(unit %in% c('degrees', 'radians')) filename <- trim(filename) out <- trim(tolower(out)) stopifnot(all(out %in% c('slope', 'aspect'))) if (length(out) == 1) { type <- out } else { type <- 'both' } res <- res(dem) dx <- res[1] dy <- res[2] if (neighbors == 8) { fX <- matrix(c(-1,-2,-1,0,0,0,1,2,1) / -8, nrow=3) fY <- matrix(c(-1,0,1,-2,0,2,-1,0,1) / 8, nrow=3) } else { # neighbors == 4 fX <- matrix(c(0,-1,0,0,0,0,0,1,0) / -2, nrow=3) fY <- matrix(c(0,0,0,-1,0,1,0,0,0) / 2, nrow=3) } lonlat <- isLonLat(dem) if (!lonlat & couldBeLonLat(dem)) { warning('assuming crs is longitude/latitude') lonlat <- TRUE } if (lonlat) { dy <- pointDistance(cbind(0,0), cbind(0, dy), lonlat=TRUE) fY <- fY / dy zy <- focal(dem, w=fY) zx <- focal(dem, w=fX) y <- yFromRow(dem, 1:nrow(dem)) dx <- .geodist(-dx, y, dx, y) / 2 zx <- t( t(zx) / dx) } else { fX <- fX / dx fY <- fY / dy zx <- focal(dem, w=fX) zy <- focal(dem, w=fY) } if (type == 'slope') { x <- atan( sqrt( zy^2 + zx^2 ) ) if (unit == 'degrees') { x <- x * (180 / pi) } names(x) <- 'slope' } else if (type == 'aspect') { x <- atan2(zy, zx) x <- ((0.5*pi)-x) %% (2*pi) if (unit == 'degrees') { x <- x * (180/pi) } if (!missing (flatAspect)) { slope <- sqrt( zy^2 + zx^2 ) aspect <- overlay(x, slope, fun=function(x, y) { x[y==0] <- flatAspect; return(x) } ) } names(x) <- 'aspect' } else { x <- atan( sqrt( zy^2 + zx^2 ) ) aspect <- atan2(zy, zx) aspect <- ((0.5*pi)-aspect) %% (2*pi) if (unit == 'degrees') { x <- x * (180/pi) aspect <- aspect * (180/pi) } if (!missing (flatAspect)) { aspect <- overlay(aspect, x, fun=function(x, y) { x[y==0] <- flatAspect; return(x) } ) } names(x) <- 'slope' names(aspect) <- 'aspect' x <- stack(x, aspect) } if (filename != "") { x <- writeRaster(x, filename, ...) } return(x) } raster/R/netCDFtoStack.R0000644000176200001440000000307514507510157014544 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 / revised June 2010 # Version 1.0 # Licence GPL v3 .stackCDF <- function(filename, varname='', bands='') { stopifnot(requireNamespace("ncdf4")) nc <- ncdf4::nc_open(filename, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) zvar <- .varName(nc, varname) dims <- nc$var[[zvar]]$ndims dim3 <- 3 if (dims== 1) { stop('variable only has a single dimension; I cannot make a RasterLayer from this') } else if (dims > 3) { dim3 <- dims warning(zvar, ' has ', dims, ' dimensions, I am using the last one') } else if (dims == 2) { return( stack ( raster(filename, varname=zvar ) ) ) } if (is.null(bands)) { bands <- ''} if (bands[1] == '') { bands = 1 : nc$var[[zvar]]$dim[[dim3]]$len } r <- raster(filename, varname=zvar, band=bands[1]) st <- stack( r ) st@title <- names(r) if (length(bands) > 1) { ## to enable suppress_dimvals ##st@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals[bands] ) dim3_vals <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dim3]]$name), silent = TRUE) if (inherits(dim3_vals, "try-error")) { dim3_vals <- seq_len(nc$var[[zvar]]$dim[[dim3]]$len) } st@z <- list(dim3_vals[bands]) names(st@z) <- nc$var[[zvar]]$dim[[dim3]]$units if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) { try( st <- .doTime(st, nc, zvar, dim3) ) } nms <- as.character(st@z[[1]]) st@layers <- lapply(bands, function(x){ r@data@band <- x; r@data@names <- nms[x]; return(r)} ) } return( st ) } #s = .stackCDF(f, varname='uwnd') raster/R/cellStats.R0000644000176200001440000002336214507510157014047 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 / April 2012 # Version 1.0 # Licence GPL v3 .csTextFun <- function(fun) { if (!inherits(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 (inherits(stat, 'character')) { if (stat == "mean" ) { return( colMeans(x, na.rm=na.rm) ) } else if (stat == "sum" ) { return( colSums(x, na.rm=na.rm) ) } else if (stat == "min" ) { v <- .colMin(x, na.rm=na.rm) names(v) <- names(x) return(v) } else if (stat == "max" ) { v <- .colMax(x, na.rm=na.rm) names(v) <- names(x) return(v) } else if (stat == 'countNA') { warning ("'countNA' is deprecated. Use 'freq(x, value=NA)' instead") return( colSums(is.na(x)) ) } else if (stat == 'sd') { st <- apply(x, 2, stats::sd, na.rm=na.rm) if (! asSample) { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } st <- sqrt(st^2 * ((n-1)/n)) } return(st) } else if (stat == 'rms') { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } if (asSample) { n <- n-1 } # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n)) return( sqrt( apply(x, 2, function(x) sum(x^2))/n ) ) } else if (stat == 'skew') { if (na.rm) { n <- colSums(! is.na(x)) } else { n <- nrow(x) } if (asSample) { sdx <- apply(x, 2, stats::sd, na.rm=na.rm) } else { sdx <- apply(x, 2, function(x) sqrt(sum((x-mean(x, na.rm=na.rm))^2, na.rm=na.rm)/n)) } return( colSums(t(t(x) - colMeans(x, na.rm=na.rm))^3, na.rm=na.rm) / (n * sdx^3) ) } } # else return(apply(x, 2, stat, na.rm=na.rm, ...)) } if (!inherits(stat, 'character')) { stop('cannot use this function for large files') } st <- NULL counts <- FALSE if (stat == 'sum') { fun <- sum st <- 0 } else if (stat == 'min') { st <- Inf } else if (stat == 'max') { st <- -Inf } else if (stat == 'range') { fun <- range } else if (stat == 'countNA') { warning ("'countNA' is depracted. Use freq(x, 'value=NA') instead") st <- 0 counts <- TRUE } else if (stat == 'skew') { zmean <- cellStats(x, 'mean') cnt <- 0 d3 <- 0 sumsq <- 0 counts <- TRUE } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') { st <- 0 sumsq <- 0 cnt <- 0 counts <- TRUE } else { stop("invalid 'stat'. Should be 'sum', 'min', 'max', 'sd', 'mean', 'rms', or 'skew'") } tr <- blockSize(x) pb <- pbCreate(tr$n, label='cellStats', ...) for (i in 1:tr$n) { d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (makeMat) { d <- matrix(d, ncol=1) } if (counts) { if (na.rm & stat != 'countNA') { nas <- colSums( is.na(d) ) if (min(nas) == nrow(d)) { next } cells <- nrow(d) - nas } else { if (stat == 'countNA') { nas <- colSums( is.na(d) ) } else { cells <- nrow(d) } } } if (stat=='mean') { st <- colSums(d, na.rm=na.rm) + st cnt <- cnt + cells } else if (stat=='sum') { st <- colSums(d, na.rm=na.rm) + st } else if (stat == 'sd') { st <- colSums(d, na.rm=na.rm) + st cnt <- cnt + cells sumsq <- colSums(d^2, na.rm=na.rm) + sumsq } else if (stat=='countNA') { st <- st + nas } else if (stat=='rms') { sumsq <- colSums(d^2, na.rm=TRUE) + sumsq cnt <- cnt + cells } else if (stat=='skew') { d <- t( t(d) - zmean ) sumsq <- colSums(d^2, na.rm=TRUE) + sumsq d3 <- colSums(d^3, na.rm=TRUE) + d3 cnt <- cnt + cells } else if (stat=='min') { tmp <- .colMin(d, na.rm=na.rm) st <- pmin(st, tmp, na.rm=na.rm) } else if (stat=='max') { tmp <- .colMax(d, na.rm=na.rm) st <- pmax(st, tmp, na.rm=na.rm) } else { # range st <- apply(rbind(d, st), 2, fun, na.rm=na.rm) } pbStep(pb, i) } if (stat == 'sd') { meansq <- (st/cnt)^2 st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1))) if (!asSample) { #st <- sqrt( st^2 * (cnt / (cnt-1))) st <- sqrt( st^2 * ((cnt-1) / cnt)) } } else if (stat == 'mean') { st <- st / cnt } else if (stat == 'rms') { if (asSample) { st <- sqrt(sumsq/(cnt-1)) } else { st <- sqrt(sumsq/cnt) } } else if (stat == 'skew') { if (asSample) { stsd <- sqrt(sumsq/(cnt-1))^3 } else { stsd <- sqrt(sumsq/cnt)^3 } st <- d3 / (cnt*stsd) } else if (stat %in% c('min', 'max')) { names(st) <- names(x) } pbClose(pb) return(st) } ) setMethod('cellStats', signature(x='RasterLayer'), function(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) { stopifnot(hasValues(x)) stat <- .csTextFun(stat) if (! inMemory(x) ) { if (canProcessInMemory(x)) { x <- readAll(x) } } if (inMemory(x) ) { x <- getValues(x) if (inherits(stat, 'character')) { if (stat == "mean" ) { return( mean(x, na.rm=na.rm) ) } else if (stat == "sum" ) { return( sum(as.double(x), na.rm=na.rm ) ) } else if (stat == 'countNA') { return( sum(is.na(x)) ) } else if (stat == "range" ) { return( range(x, na.rm=na.rm) ) } else if (stat == "min" ) { return( min(x, na.rm=na.rm) ) } else if (stat == "max" ) { return( max(x, na.rm=na.rm) ) } else if (stat == "sd" ) { st <- stats::sd(x, na.rm=na.rm) if (! asSample) { if (na.rm) { n <- length(stats::na.omit(x)) } else { n <- length(x) } #st <- sqrt(st^2 * (n/(n-1))) st <- sqrt(st^2 * ((n-1)/n)) } return(st) } else if (stat == 'rms') { if (na.rm) { n <- sum(! is.na(x)) } else { n <- length(x) } if (asSample) { n <- n-1 } # st <- apply(x, 2, function(x) sqrt(sum(x^2)/n)) return( sqrt( sum(x^2)/n ) ) } else if (stat == "skew" ) { if (na.rm) { x <- stats::na.omit(x) } if (asSample) { sdx <- stats::sd(x) } else { sdx <- sqrt(sum((x-mean(x))^2)/(length(x))) } return( sum( (x - mean(x))^3 ) / (length(x) * sdx^3) ) } } else { return( stat(x, na.rm=na.rm) ) } } if (!inherits(stat, 'character')) { stop('cannot use this function for large files') } st <- NULL counts <- FALSE if (stat == 'sum') { fun <- sum st <- 0 } else if (stat == 'min') { fun <- min } else if (stat == 'max') { fun <- max } else if (stat == 'range') { fun <- range } else if (stat == 'countNA') { st <- 0 counts <- TRUE } else if (stat == 'skew') { zmean <- cellStats(x, 'mean') cnt <- 0 sumsq <- 0 d3 <- 0 counts <- TRUE } else if (stat == 'mean' | stat == 'sd' | stat == 'rms') { st <- 0 sumsq <- 0 cnt <- 0 counts <- TRUE } else { stop("invalid 'stat'. Should be sum, min, max, sd, mean, or 'countNA'") } tr <- blockSize(x) pb <- pbCreate(tr$n, label='cellStats', ...) for (i in 1:tr$n) { d <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if (counts) { if (na.rm & stat != 'countNA') { nas <- sum(is.na(d) ) if (nas == length(d)) { # only NAs next } cells <- length(d) - nas } else { if (stat == 'countNA') { nas <- sum(is.na(d) ) } else { cells <- length(d) } } } if (stat=='mean') { st <- sum(d, na.rm=na.rm) + st cnt <- cnt + cells } else if (stat=='sum') { st <- sum(as.double(d), na.rm=na.rm) + st } else if (stat == 'sd') { st <- sum(d, na.rm=na.rm) + st cnt <- cnt + cells sumsq <- sum( d^2 , na.rm=na.rm) + sumsq } else if (stat=='countNA') { st <- st + nas } else if (stat=='skew') { d <- (d - zmean) sumsq <- sum(d^2, na.rm=na.rm) + sumsq d3 <- sum(d^3, na.rm=na.rm) + d3 cnt <- cnt + cells } else if (stat=='rms') { sumsq <- sum( d^2, na.rm=na.rm) + sumsq cnt <- cnt + cells } else { st <- fun(d, st, na.rm=na.rm) } pbStep(pb, i) } pbClose(pb) if (stat == 'sd') { meansq <- (st/cnt)^2 st <- sqrt(( (sumsq / cnt) - meansq ) * (cnt/(cnt-1))) if (!asSample) { #st <- sqrt( st^2 * (cnt / (cnt-1))) st <- sqrt( st^2 * ((cnt-1) / cnt)) } } else if (stat == 'mean') { st <- st / cnt } else if (stat == 'rms') { if (asSample) { st <- sqrt(sumsq/(cnt-1)) } else { st <- sqrt(sumsq/cnt) } } else if (stat == 'skew') { if (asSample) { stsd <- sqrt(sumsq/(cnt-1))^3 } else { stsd <- sqrt(sumsq/cnt)^3 } st <- d3 / (cnt*stsd) } return(st) } ) raster/R/zonal.R0000644000176200001440000002101414507510157013224 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009 # Version 0.9 # Licence GPL v3 setMethod('zonal', signature(x='RasterLayer', z='RasterLayer'), function(x, z, fun='mean', digits=0, na.rm=TRUE, ...) { # backward compatibility if (!is.null(list(...)$stat)) { stop('argument "stat" was replaced by "fun"') } compareRaster(c(x, z)) stopifnot(hasValues(z)) stopifnot(hasValues(x)) layernames <- names(x) if (canProcessInMemory(x, 3)) { inmem <- TRUE } else { inmem <- FALSE } if (inmem) { pb <- pbCreate(2, label='zonal', ...) if (isTRUE(try(fun == 'count', silent=TRUE))) { func <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } } else { func <- match.fun(fun) } x <- getValues(x) z <- round(getValues(z), digits=digits) pb <- pbStep(pb, 1) alltab <- tapply(x, z, FUN=func, na.rm=na.rm) if (is.array(alltab)) { # multiple numbers id <- as.numeric(dimnames(alltab)[[1]]) alltab <- matrix(unlist(alltab, use.names = FALSE), nrow=dim(alltab), byrow=TRUE) alltab <- cbind(id, alltab) } else { alltab <- cbind(as.numeric(names(alltab)), alltab) } pb <- pbStep(pb, 2) colnames(alltab)[1] <- 'zone' d <- dim(alltab)[2] if (d==2) { if (is.character(fun)) { colnames(alltab)[2] <- fun[1] } else { colnames(alltab)[2] <- 'value' } } else { colnames(alltab)[2:d] <- paste0('value_', 1:(d-1)) } } else { if (!inherits(fun, 'character')) { stop("RasterLayers cannot be processed in memory.\n You can use fun='sum', 'mean', 'sd', 'min', 'max', or 'count' but not a function") } if (! fun %in% c('sum', 'mean', 'sd', 'min', 'max', 'count')) { stop("fun can be 'sum', 'mean', 'sd', 'min', 'max', or 'count'") } sdtab <- FALSE counts <- FALSE if (fun == 'count') { func1 <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } func2 <- sum } else { func1 <- func2 <- match.fun(fun) } if ( fun == 'mean' | fun == 'sd') { func1 <- func2 <- sum counts <- TRUE if (fun == 'sd') { sdtab <- TRUE } } alltab <- array(dim=0) sqtab <- cnttab <- alltab tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='zonal', ...) #nc <- nlayers(x) #nc1 <- nc + 1 #nc2 <- 2:nc1 #nc2 <- 2 x <- readStart(x, ...) z <- readStart(z, ...) for (i in 1:tr$n) { d <- cbind(getValues(x, row=tr$row[i], nrows=tr$nrows[i])) Z <- round(getValues(z, row=tr$row[i], nrows=tr$nrows[i]), digits=digits) #cat(i, '\n') #utils::flush.console() a <- tapply(d, Z, FUN=func1, na.rm=na.rm) a <- cbind(as.numeric(names(a)), a) alltab <- rbind(alltab, a) if (counts) { if (na.rm) { a <- tapply(d, Z, FUN=function(x)length(stats::na.omit(x))) a <- cbind(as.numeric(names(a)), a) cnttab <- rbind(cnttab, a) if (sdtab) { a <- tapply( d^2, Z, FUN=function(x)sum(stats::na.omit(x))) a <- cbind(as.numeric(names(a)), a) sqtab <- rbind(sqtab, a) } } else { a <- tapply(d, Z, FUN=length) a <- cbind(as.numeric(names(a)), a) cnttab <- rbind(cnttab, a) if (sdtab) { a <- tapply(d^2, Z, FUN=sum) a <- cbind(as.numeric(names(a)), a) sqtab <- rbind(sqtab, a) } } } if (length(alltab) > 10000) { alltab <- tapply(alltab[,2], alltab[,1], FUN=func2, na.rm=na.rm) alltab <- cbind(as.numeric(names(alltab)), alltab) if (counts) { cnttab <- tapply(cnttab[,2], cnttab[,1], FUN=sum, na.rm=na.rm) cnttab <- cbind(as.numeric(names(cnttab)), cnttab) if (sdtab) { sqtab <- tapply(sqtab[,2], sqtab[,1], FUN=sum, na.rm=na.rm) sqtab <- cbind(as.numeric(names(sqtab)), sqtab) } } } pbStep(pb, i) } x <- readStop(x) z <- readStop(z) alltab <- tapply(alltab[,2], alltab[,1], FUN=func2, na.rm=na.rm) alltab <- cbind(as.numeric(names(alltab)), alltab) if (counts) { cnttab <- tapply(cnttab[,2], cnttab[,1], FUN=sum) cnttab <- cbind(as.numeric(names(cnttab)), cnttab) alltab[,2] <- alltab[,2] / cnttab[,2] if (sdtab) { sqtab <- tapply(sqtab[,2], sqtab[,1], FUN=sum, na.rm=na.rm) sqtab <- cbind(as.numeric(names(sqtab)), sqtab) alltab[,2] <- sqrt(( (sqtab[,2] / cnttab[,2]) - (alltab[,2])^2 ) * (cnttab[,2]/(cnttab[,2]-1))) } } colnames(alltab)[1] <- 'zone' if (is.character(fun)) { colnames(alltab)[2] <- fun } else { colnames(alltab)[2] <- 'value' } } #alltab <- as.matrix(alltab) pbClose(pb) return(alltab) } ) #zonal(r, z, 'sd') setMethod('zonal', signature(x='RasterStackBrick', z='RasterLayer'), function(x, z, fun='mean', digits=0, na.rm=TRUE, ...) { # backward compatibility if (!is.null(list(...)$stat)) { stop('argument "stat" was replaced by "fun"') } compareRaster(c(x, z)) stopifnot(hasValues(z)) stopifnot(hasValues(x)) layernames <- names(x) if (canProcessInMemory(x, 3)) { inmem <- TRUE } else { inmem <- FALSE } if (inmem) { pb <- pbCreate(2, label='zonal', ...) if (isTRUE(try(fun == 'count', silent=TRUE))) { func <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } } else { func <- match.fun(fun) } x <- getValues(x) x <- cbind(x, round(getValues(z), digits=digits)) pb <- pbStep(pb, 1) alltab <- aggregate(x[,1:(ncol(x)-1)], by=list(x[,ncol(x)]), FUN=func, na.rm=na.rm) fun <- 'value' pb <- pbStep(pb, 2) } else { if (!inherits(fun, 'character')) { stop("RasterLayers cannot be processed in memory.\n You can use fun='sum', 'mean', 'sd', 'min', 'max', or 'count' but not a function") } if (! fun %in% c('sum', 'mean', 'sd', 'min', 'max', 'count')) { stop("fun can be 'sum', 'mean', 'sd', 'min', 'max', or 'count'") } sdtab <- FALSE counts <- FALSE if (fun == 'count') { func1 <- function(x, na.rm) { if (na.rm) { length(stats::na.omit(x)) } else { length(x) } } func2 <- sum } else { func1 <- func2 <- match.fun(fun) } if ( fun == 'mean' | fun == 'sd') { func1 <- func2 <- sum counts <- TRUE if (fun == 'sd') { sdtab <- TRUE } } alltab <- array(dim=0) sqtab <- cnttab <- alltab tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='zonal', ...) nc <- nlayers(x) nc1 <- nc + 1 nc2 <- 2:nc1 # for a RasterStack it would be more efficient to loop over the layers x <- readStart(x, ...) z <- readStart(z, ...) for (i in 1:tr$n) { d <- cbind(getValues(x, row=tr$row[i], nrows=tr$nrows[i]), round(getValues(z, row=tr$row[i], nrows=tr$nrows[i]), digits=digits)) #cat(i, '\n') #utils::flush.console() alltab <- rbind(alltab, aggregate(d[,1:nc], by=list(d[,nc1]), FUN=func1, na.rm=na.rm)) if (counts) { if (na.rm) { cnttab <- rbind(cnttab, aggregate(d[,1:nc], by=list(d[,nc1]), FUN=function(x)length(stats::na.omit(x)))) if (sdtab) { sqtab <- rbind(sqtab, aggregate( (d[,1:nc])^2, by=list(d[,nc1]), FUN=function(x)sum(stats::na.omit(x)))) } } else { cnttab <- rbind(cnttab, aggregate(d[,1:nc], by=list(d[,nc1]), FUN=length)) if (sdtab) { sqtab <- rbind(sqtab, aggregate( (d[,1:nc])^2, by=list(d[,nc]), FUN=sum)) } } } if (length(alltab) > 10000) { alltab <- aggregate(alltab[,nc2], by=list(alltab[,1]), FUN=func2, na.rm=na.rm) if (counts) { cnttab <- aggregate(cnttab[,nc2], by=list(cnttab[,1]), FUN=sum, na.rm=na.rm) if (sdtab) { sqtab <- aggregate(sqtab[,nc2], by=list(sqtab[,1]), FUN=sum, na.rm=na.rm) } } } pbStep(pb, i) } x <- readStop(x) z <- readStop(z) alltab <- aggregate(alltab[,nc2], by=list(alltab[,1]), FUN=func2, na.rm=na.rm) if (counts) { cnttab <- aggregate(cnttab[,nc2], by=list(cnttab[,1]), FUN=sum) alltab[,nc2] <- alltab[,nc2] / cnttab[,nc2] if (sdtab) { sqtab <- aggregate(sqtab[,nc2], by=list(sqtab[,1]), FUN=sum, na.rm=na.rm) alltab[,nc2] <- sqrt(( (sqtab[,nc2] / cnttab[,nc2]) - (alltab[nc2])^2 ) * (cnttab[,nc2]/(cnttab[,nc2]-1))) } } } alltab <- as.matrix(alltab) colnames(alltab)[1] <- 'zone' if (ncol(alltab) > 2) { colnames(alltab)[2:ncol(alltab)] <- layernames } else { colnames(alltab)[2] <- fun[1] } pbClose(pb) return(alltab) } ) #zonal(r, z, 'sd') raster/R/terrain.R0000644000176200001440000000713514507510157013555 0ustar liggesusers# Author: Robert J. Hijmans # Date : February 2011 # Version 1.0 # Licence GPL v3 setMethod("terrain", signature(x="RasterLayer"), function(x, opt="slope", unit="radians", neighbors=8, filename="", ...) { # if (nlayers(x) > 1) { # warning("first layer of x is used") # x <- subset(x, 1) # } stopifnot(hasValues(x)) stopifnot(is.character(filename)) filename <- trim(filename) stopifnot(is.character(opt)) opt <- unique(trim(tolower(opt))) i <- which(! opt %in% c("tri", "tpi", "roughness","slope", "aspect", "flowdir")) if (length(i) > 0) { stop('invalid value in "opt", choose from:\n "tri", "tpi", "roughness", "slope", "aspect", "flowdir"') } stopifnot(length(opt) > 0 ) nopt <- rep(0, 8) if ("tri" %in% opt) { nopt[1] <- 1 } if ("tpi" %in% opt) { nopt[2] <- 1 } if ("roughness" %in% opt) { nopt[3] <- 1 } if ("slope" %in% opt) { if (neighbors == 4) { nopt[4] <- 1 } else { nopt[6] <- 1 } } if ("aspect" %in% opt) { if (neighbors == 4) { nopt[5] <- 1 } else { nopt[7] <- 1 } } if ("flowdir" %in% opt) { nopt[8] <- 1 } nopt <- as.integer(nopt) nl <- sum(nopt) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE, nl=nl) } names(out) <- c("tri", "tpi", "roughness","slope", "aspect", "slope", "aspect", "flowdir")[as.logical(nopt)] rs <- as.double(res(out)) un <- as.integer(1) lonlat <- FALSE if ("slope" %in% opt | "aspect" %in% opt | "flowdir" %in% opt) { stopifnot(is.character(unit)) unit <- trim(tolower(unit)) stopifnot(unit %in% c("degrees", "radians", "tangent")) if (unit=="degrees") { un <- as.integer(0) } else if (unit=="tangent") { un <- as.integer(2) } stopifnot(neighbors %in% c(4, 8)) stopifnot(! is.na(projection(x)) ) lonlat <- isLonLat(out) if (!lonlat & couldBeLonLat(out)) { warning("assuming crs is longitude/latitude") lonlat <- TRUE } if (lonlat) { rs[2] <- pointDistance(cbind(0,0), cbind(0, rs[2]), longlat=TRUE) } } lonlat <- as.integer(lonlat) if (canProcessInMemory(out)) { if (lonlat) { y <- yFromRow(x, 1:nrow(x)) } else { y <- 0 } v <- .terrain(as.double(values(x)), as.integer(dim(out)), rs, un, nopt, lonlat, y) out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename, ...) } } else { out <- writeStart(out, filename, ...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label="terrain", ...) nc <- ncol(out) buf <- 1:nc v <- getValues(x, row=1, nrows=tr$nrows[1]+1) y <- 0 if (lonlat) { y <- yFromRow(out, 1:(tr$nrows[1]+1)) } v <- .terrain(as.double(v), as.integer(c(tr$nrows[1]+1, nc)), rs, un, nopt, lonlat, y) out <- writeValues(out, matrix(v, ncol=nl), 1) pbStep(pb, 1) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+2) if (lonlat) { y <- yFromRow(out, (tr$row[i]-1) : (tr$row[i]+tr$nrows[i])) } v <- .terrain(as.double(v), as.integer(c(tr$nrows[i]+2, nc)), rs, un, nopt, lonlat, y) v <- matrix(v, ncol=nl)[-buf,] out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } i <- tr$n v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+1) if (lonlat) { y <- yFromRow(out, (tr$row[i]-1) : (tr$row[i]+tr$nrows[i]-1)) } v <- .terrain(as.double(v), as.integer(c(tr$nrows[i]+1, nc)), rs, un, nopt, lonlat, y) v <- matrix(v, ncol=nl)[-buf,] out <- writeValues(out, v, tr$row[i]) pbStep(pb, tr$n) out <- writeStop(out) pbClose(pb) } return(out) } ) # x <- terrain(utm, out="tri") raster/R/atan2.R0000644000176200001440000000141314507510157013107 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2011 # Version 1.0 # Licence GPL v3 setMethod("atan2", signature(y='Raster', x='Raster'), function(y, x) { compareRaster(x, y) ny <- nlayers(y) nx <- nlayers(x) nl <- max(ny, nx) if (nl > 1) { r <- brick(x, values=FALSE, nl=nl) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { r <- setValues(r, atan2(getValues(y), getValues(x))) } else { tr <- blockSize(x) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile()) for (i in 1:tr$n) { v <- atan2(getValues(y, row=tr$row[i], nrows=tr$nrows[i]), getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) raster/R/adjacent.R0000644000176200001440000001021414507510157013652 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2011 # Version 1.0 # Licence GPL v3 .adjacentUD <- function(x, cells, ngb, include) { # ngb should be a matrix with # one and only one cell with value 0 (the focal cell), # at least one cell with value 1 (the adjacent cells) # cells with other values are ignored (not considered adjacent) rs <- res(x) rn <- raster(ngb) center <- which(values(rn)==0) if (include) { ngb[center] <- 1 } rc <- rowFromCell(rn, center) cc <- colFromCell(rn, center) xngb <- yngb <- ngb xngb[] <- rep(1:ncol(ngb), each=nrow(ngb)) - cc yngb[] <- rep(nrow(ngb):1, ncol(ngb)) - (nrow(ngb)-rc+1) ngb[ngb != 1] <- NA xngb <- stats::na.omit(as.vector( xngb * rs[1] * ngb)) yngb <- stats::na.omit(as.vector( yngb * rs[2] * ngb)) xy <- xyFromCell(x, cells) X <- apply(xy[,1,drop=FALSE], 1, function(z) z + xngb ) Y <- apply(xy[,2,drop=FALSE], 1, function(z) z + yngb ) c(as.vector(X), as.vector(Y)) } setMethod("adjacent", signature(x="BasicRaster"), function(x, cells, directions=4, pairs=TRUE, target=NULL, sorted=FALSE, include=FALSE, id=FALSE, ...) { if (is.character(directions)) { directions <- tolower(directions) } x <- raster(x) r <- res(x) xy <- xyFromCell(x, cells) mat <- FALSE if (is.matrix(directions)) { stopifnot(length(which(directions==0)) == 1) stopifnot(length(which(directions==1)) > 0) d <- .adjacentUD(x, cells, directions, include) directions <- sum(directions==1, na.rm=TRUE) mat <- TRUE } else if (directions==4) { if (include) { d <- c(xy[,1], xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(xy[,1]-r[1], xy[,1]+r[1], xy[,1], xy[,1], xy[,2], xy[,2], xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions==8) { if (include) { d <- c(xy[,1], rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1], xy[,2], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(rep(xy[,1]-r[1], 3), rep(xy[,1]+r[1],3), xy[,1], xy[,1], rep(c(xy[,2]+r[2], xy[,2], xy[,2]-r[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions==16) { r2 <- r * 2 if (include) { d <- c(xy[,1], rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2), rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5), xy[,1], xy[,1], xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2), rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } else { d <- c(rep(xy[,1]-r2[1], 2), rep(xy[,1]+r2[1], 2), rep(xy[,1]-r[1], 5), rep(xy[,1]+r[1], 5), xy[,1], xy[,1], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2), rep(c(xy[,2]+r2[2], xy[,2]+r[2], xy[,2], xy[,2]-r[2], xy[,2]-r2[2]), 2), xy[,2]+r[2], xy[,2]-r[2]) } } else if (directions=='bishop') { if (include) { d <- c(xy[,1], rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), xy[,2], rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2)) } else { d <- c(rep(xy[,1]-r[1], 2), rep(xy[,1]+r[1],2), rep(c(xy[,2]+r[2], xy[,2]-r[2]), 2)) } directions <- 4 # to make pairs } else { stop('directions should be one of: 4, 8, 16, "bishop", or a matrix') } if (include) directions <- directions + 1 d <- matrix(d, ncol=2) if (.isGlobalLonLat(x)) { # normalize longitude to -180..180 d[,1] <- (d[,1] + 180) %% 360 - 180 } if (pairs) { if (mat) { cell <- rep(cells, each=directions) } else { cell <- rep(cells, directions) } if (id) { if (mat) { ID <- rep(1:length(cells), each=directions) } else { ID <- rep(1:length(cells), directions) } d <- stats::na.omit(cbind(ID, cell, cellFromXY(x, d))) attr(d, 'na.action') <- NULL colnames(d) <- c('id', 'from', 'to') if (! is.null(target)) { d <- d[d[,3] %in% target, ] } } else { d <- stats::na.omit(cbind(cell, cellFromXY(x, d))) attr(d, 'na.action') <- NULL colnames(d) <- c('from', 'to') if (! is.null(target)) { d <- d[d[,2] %in% target, ] } } if (sorted) { d <- d[order(d[,1], d[,2]),] } } else { d <- as.vector(unique(stats::na.omit(cellFromXY(x, d)))) if (! is.null(target)) { d <- intersect(d, target) } if (sorted) { d <- sort(d) } } d } ) raster/R/AAAClasses.R0000644000176200001440000001263614507510157014013 0ustar liggesusers# R classes for raster (grid) type spatial data # Robert J. Hijmans # November 2008 # Version 1.0 # Licence GPL v3 setClass("Extent", representation ( xmin = "numeric", xmax = "numeric", ymin = "numeric", ymax = "numeric" ), prototype ( xmin = 0, xmax = 1, ymin = 0, ymax = 1 ), validity = function(object) { c1 <- (object@xmin <= object@xmax) c2 <- (object@ymin <= object@ymax) # fix to not break dependencies if (is.na(c1)) c1 <- TRUE if (is.na(c2)) c2 <- TRUE if (!c1) { stop("invalid extent: xmin >= xmax") } if (!c2) { stop("invalid extent: ymin >= ymax") } return(c1 & c2) # fix to not break dependencies #v <- c(object@xmin, object@xmax, object@ymin, object@ymax) #c3 <- all(!is.infinite(v)) #if (!c3) { stop("invalid extent: infinite value") } #return(c1 & c2 & c3) } ) setClass(".Rotation", representation ( geotrans = "numeric", transfun = "function" ) ) setMethod("initialize", "BasicRaster", function(.Object, ..., crs=NA, srs="") { .Object <- callNextMethod(.Object, ...) if ((length(crs) > 0) && (!isTRUE(is.na(crs)))) { if (.hasSlot(.Object, "srs")) { .Object@srs <- .getSRS(crs) } #.Object@crs <- crs } else if (srs != "") { if (.hasSlot(.Object, "srs")) { .Object@srs <- .getSRS(srs) } #.Object@crs <- .makeCRS(srs) } .Object } ) setClass ("BasicRaster", representation ( title = "character", extent = "Extent", rotated = "logical", rotation = ".Rotation", ncols ="integer", nrows ="integer", crs = "CRS", srs = "character", history = "list", #meta = "list", z = "list" ), prototype ( crs = sp::CRS(doCheckCRSArgs=FALSE), srs = "", rotated = FALSE, ncols= as.integer(1), nrows= as.integer(1), history = list(), #meta = list(), z = list() ), validity = function(object) { methods::validObject(extent(object)) c1 <- (object@ncols > 0) if (!c1) { stop("ncols < 1") } c2 <- (object@nrows > 0) if (!c2) { stop("nrows < 1") } return(c1 & c2) } ) setClass ("Raster", contains = c("BasicRaster", "VIRTUAL") ) setClass(".RasterFile", representation ( name ="character", datanotation="character", byteorder ="character", nodatavalue ="numeric", # on disk, in ram it is NA NAchanged ="logical", nbands ="integer", bandorder ="character", offset="integer", toptobottom="logical", blockrows="integer", blockcols="integer", driver ="character", open = "logical" ), prototype ( name = "", datanotation="FLT4S", byteorder = .Platform$endian, nodatavalue = -Inf, NAchanged = FALSE, nbands = as.integer(1), bandorder = "BIL", offset = as.integer(0), toptobottom = TRUE, blockrows = as.integer(0), blockcols= as.integer(0), driver = "", open = FALSE ), validity = function(object) { c1 <- object@datanotation %in% c("LOG1S", "INT1S", "INT2S", "INT4S", "INT1U", "INT2U", "FLT4S", "FLT8S") return(c1) } ) setClass(".SingleLayerData", representation ( values="vector", offset="numeric", gain="numeric", inmemory="logical", fromdisk="logical", isfactor = "logical", attributes = "list", haveminmax = "logical", min = "vector", max = "vector", band = "integer", unit = "character", names = "vector" ), prototype ( values=vector(), offset=0, gain=1, inmemory=FALSE, fromdisk=FALSE, isfactor = FALSE, attributes = list(), haveminmax = FALSE, min = c(Inf), max = c(-Inf), band = as.integer(1), unit = "", names=c("") ), validity = function(object) { } ) setClass (".RasterLegend", representation ( type = "character", values = "vector", color = "vector", names = "vector", colortable = "vector" ), prototype ( ) ) setClass ("RasterLayer", contains = "Raster", representation ( file = ".RasterFile", data = ".SingleLayerData", legend = ".RasterLegend" ) ) setClass(".MultipleRasterData", representation ( values="matrix", offset="numeric", gain="numeric", inmemory="logical", fromdisk="logical", nlayers="integer", dropped = "vector", isfactor = "logical", attributes = "list", haveminmax = "logical", min = "vector", max = "vector", unit = "vector", names= "vector" ), prototype ( values=matrix(NA,0,0), offset=0, gain=1, #indices =vector(mode="numeric"), inmemory=FALSE, fromdisk=FALSE, nlayers=as.integer(0), dropped=NULL, isfactor = FALSE, attributes = list(), haveminmax = FALSE, min = c(Inf), max = c(-Inf), unit = c(""), names = c("") ), validity = function(object) { } ) setClass ("RasterBrick", contains = "Raster", representation ( file = ".RasterFile", data = ".MultipleRasterData", legend = ".RasterLegend" ) ) setClass ("RasterStack", contains = "Raster", representation ( filename ="character", layers ="list" ), prototype ( filename="", layers = list() ), validity = function(object) { if (length(object@layers) > 1) { cond <- compareRaster(object@layers, extent=TRUE, rowcol=TRUE, tolerance=0.05, stopiffalse=FALSE, showwarning=FALSE) } else { cond <- TRUE } return(cond) } ) setClassUnion("RasterStackBrick", c("RasterStack", "RasterBrick")) setClassUnion("SpatialVector", c("SpatialPoints", "SpatialLines", "SpatialPolygons")) setClass (".RasterList", contains = "list", representation (), prototype (), validity = function(object) { s <- sapply(object, function(x) inherits(x, "Raster")) return( sum(s) == length(s)) } ) raster/R/netCDFtoRasterCD.R0000644000176200001440000002446014507510157015147 0ustar liggesusers# Author: Robert J. Hijmans # Date: Aug 2009 # Version 1.0 # Licence GPL v3 # Aug 2012, adapted for use with ncdf4 library .doTime <- function(x, nc, zvar, dim3) { dodays <- TRUE dohours <- FALSE doseconds <- FALSE un <- nc$var[[zvar]]$dim[[dim3]]$units if (substr(un, 1, 10) == "days since") { startDate = as.Date(substr(un, 12, 22)) } else if (substr(un, 1, 11) == "hours since") { dohours <- TRUE dodays <- FALSE startTime <- substr(un, 13, 30) mult <- 3600 } else if (substr(un, 1, 13) == "seconds since") { doseconds <- TRUE dodays <- FALSE startTime = as.Date(substr(un, 15, 31)) mult <- 1 } else if (substr(un, 1, 12) == "seconds from") { doseconds <- TRUE dodays <- FALSE startTime = as.Date(substr(un, 14, 31)) mult <- 1 } else { return(x) } if (!dodays) { start <- strptime(startTime, "%Y-%m-%d %H:%M:%OS", tz = "UTC") if (is.na(start)) start <- strptime(startTime, "%Y-%m-%d", tz = "UTC") if (is.na(start)) return(x) startTime <- start time <- startTime + as.numeric(getZ(x)) * mult time <- as.character(time) if (!is.na(time[1])) { x@z <- list(time) names(x@z) <- as.character('Date/time') } } else if (dodays) { # cal = nc$var[[zvar]]$dim[[dim3]]$calendar ? cal <- ncdf4::ncatt_get(nc, "time", "calendar") if (! cal$hasatt ) { greg <- TRUE } else { cal <- cal$value if (cal =='gregorian' | cal =='proleptic_gregorian' | cal=='standard') { greg <- TRUE } else if (cal == 'noleap' | cal == '365 day' | cal == '365_day') { greg <- FALSE nday <- 365 } else if (cal == '360_day') { greg <- FALSE nday <- 360 } else { greg <- TRUE warning('assuming a standard calender:', cal) } } time <- getZ(x) if (greg) { time <- as.Date(time, origin=startDate) } else { startyear <- as.numeric( format(startDate, "%Y") ) startmonth <- as.numeric( format(startDate, "%m") ) startday <- as.numeric( format(startDate, "%d") ) year <- trunc( as.numeric(time)/nday ) doy <- (time - (year * nday)) origin <- paste(year+startyear, "-", startmonth, "-", startday, sep='') time <- as.Date(doy, origin=origin) } x@z <- list(time) names(x@z) <- 'Date' } return(x) } .dimNames <- function(nc) { n <- nc$dim nams <- vector(length=n) if (n > 0) { for (i in 1:n) { nams[i] <- nc$dim[[i]]$name } } return(nams) } .varName <- function(nc, varname='', warn=TRUE) { n <- nc$nvars dims <- vars <- vector(length=n) if (n > 0) { for (i in 1:n) { vars[i] <- nc$var[[i]]$name dims[i] <- nc$var[[i]]$ndims } vars <- vars[dims > 1] dims <- dims[dims > 1] } if (varname=='') { nv <- length(vars) if (nv == 0) { return('z') } if (nv == 1) { varname <- vars } else { varname <- vars[which.max(dims)] if (warn) { if (sum(dims == max(dims)) > 1) { vars <- vars[dims==max(dims)] warning('varname used is: ', varname, '\nIf that is not correct, you can set it to one of: ', paste(vars, collapse=", ") ) } } } } zvar <- which(varname == vars) if (length(zvar) == 0) { stop('varname: ', varname, ' does not exist in the file. Select one from:\n', paste(vars, collapse=", ") ) } return(varname) } .rasterObjectFromCDF <- function(filename, varname='', band=NA, type='RasterLayer', lvar, level=0, warn=TRUE, dims=1:3, crs="", stopIfNotEqualSpaced=TRUE, ...) { stopifnot(requireNamespace("ncdf4")) stopifnot(type %in% c('RasterLayer', "RasterBrick")) nc <- ncdf4::nc_open(filename, readunlim=FALSE, suppress_dimvals = TRUE) on.exit( ncdf4::nc_close(nc) ) conv <- ncdf4::ncatt_get(nc, 0, "Conventions") #grads <- FALSE #if (grepl("GrADS", conv$value) { # grads <- TRUE #} # else assuming > "CF-1.0" zvar <- .varName(nc, varname, warn=warn) # datatype <- .getRasterDTypeFromCDF( nc$var[[zvar]]$prec ) dim3 <- dims[3] ndims <- nc$var[[zvar]]$ndims if (ndims== 1) { return(.rasterObjectFromCDF_GMT(nc)) } else if (ndims == 4) { if (missing(lvar)) { nlevs3 <- nc$var[[zvar]]$dim[[3]]$len nlevs4 <- nc$var[[zvar]]$dim[[4]]$len if (nlevs3 > 1 & nlevs4 == 1) { lvar <- 4 } else { lvar <- 3 } } nlevs <- nc$var[[zvar]]$dim[[lvar]]$len if (level <=0 ) { level <- 1 # perhaps detect case where lvar should be 4? #https://stackoverflow.com/questions/56261199/extracting-all-levels-from-netcdf-file-in-r/ if (nlevs > 1) { warning('"level" set to 1 (there are ', nlevs, ' levels)') } } else { oldlevel <- level <- round(level) level <- max(1, min(level, nlevs)) if (oldlevel != level) { warning('level set to: ', level) } } if (lvar == 4) { dim3 <- 3 } else { dim3 <- 4 } } else if (ndims > 4) { warning(zvar, ' has more than 4 dimensions, I do not know what to do with these data') } ncols <- nc$var[[zvar]]$dim[[dims[1]]]$len nrows <- nc$var[[zvar]]$dim[[dims[2]]]$len ## to allow suppress_dimvals ## xx <- nc$var[[zvar]]$dim[[dims[1]]]$vals xx <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dims[1]]]$name), silent = TRUE) if (inherits(xx, "try-error")) { xx <- seq_len(nc$var[[zvar]]$dim[[dims[1]]]$len) } rs <- xx[-length(xx)] - xx[-1] if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) { if (is.na(stopIfNotEqualSpaced)) { warning('cells are not equally spaced; you should extract values as points') } else if (stopIfNotEqualSpaced) { stop('cells are not equally spaced; you should extract values as points') } } xrange <- c(min(xx), max(xx)) resx <- (xrange[2] - xrange[1]) / (ncols-1) rm(xx) ## to allow suppress_dimvals ## yy <- nc$var[[zvar]]$dim[[dims[2]]]$vals yy <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dims[2]]]$name), silent = TRUE) if (inherits(yy, "try-error")) { yy <- seq_len(nc$var[[zvar]]$dim[[dims[2]]]$len) } rs <- yy[-length(yy)] - yy[-1] if (! isTRUE ( all.equal( min(rs), max(rs), tolerance=0.025, scale= abs(min(rs))) ) ) { if (is.na(stopIfNotEqualSpaced)) { warning('cells are not equally spaced; you should extract values as points') } else if (stopIfNotEqualSpaced) { stop('cells are not equally spaced; you should extract values as points') } } yrange <- c(min(yy), max(yy)) resy <- (yrange[2] - yrange[1]) / (nrows-1) if (yy[1] > yy[length(yy)]) { toptobottom <- FALSE } else { toptobottom <- TRUE } rm(yy) xrange[1] <- xrange[1] - 0.5 * resx xrange[2] <- xrange[2] + 0.5 * resx yrange[1] <- yrange[1] - 0.5 * resy yrange[2] <- yrange[2] + 0.5 * resy long_name <- zvar unit <- '' natest <- ncdf4::ncatt_get(nc, zvar, "_FillValue") natest2 <- ncdf4::ncatt_get(nc, zvar, "missing_value") prj <- NA minv <- maxv <- NULL a <- ncdf4::ncatt_get(nc, zvar, "min") if (a$hasatt) { minv <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "max") if (a$hasatt) { maxv <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "long_name") if (a$hasatt) { long_name <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "units") if (a$hasatt) { unit <- a$value } a <- ncdf4::ncatt_get(nc, zvar, "grid_mapping") if ( a$hasatt ) { gridmap <- a$value try(atts <- ncdf4::ncatt_get(nc, gridmap), silent=TRUE) try(prj <- .getCRSfromGridMap4(atts), silent=TRUE) } if (is.na(prj)) { if ((tolower(substr(nc$var[[zvar]]$dim[[dims[1]]]$name, 1, 3)) == 'lon') & ( tolower(substr(nc$var[[zvar]]$dim[[dims[2]]]$name, 1, 3)) == 'lat' ) ) { if ( yrange[1] > -91 | yrange[2] < 91 ) { if ( xrange[1] > -181 | xrange[2] < 181 ) { prj <- '+proj=longlat +datum=WGS84' } else if ( xrange[1] > -1 | xrange[2] < 361 ) { prj <- '+proj=longlat +lon_wrap=180 +datum=WGS84' } } } } crs <- .getProj(prj, crs) if (type == 'RasterLayer') { r <- raster(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) names(r) <- long_name } else if (type == 'RasterBrick') { r <- brick(xmn=xrange[1], xmx=xrange[2], ymn=yrange[1], ymx=yrange[2], ncols=ncols, nrows=nrows, crs=crs) r@title <- long_name } else { stop("unknown object type") } r@file@name <- filename r@file@toptobottom <- toptobottom r@data@unit <- unit attr(r@data, "zvar") <- zvar attr(r@data, "dim3") <- dim3 attr(r@data, "level") <- level r@file@driver <- "netcdf" if (natest$hasatt) { r@file@nodatavalue <- as.numeric(natest$value) } else if (natest2$hasatt) { r@file@nodatavalue <- as.numeric(natest2$value) } r@data@fromdisk <- TRUE if (ndims == 2) { nbands <- 1 } else { nbands <- nc$var[[zvar]]$dim[[dim3]]$len r@file@nbands <- nbands ## to allow suppress_dimvals # r@z <- list( nc$var[[zvar]]$dim[[dim3]]$vals ) dim3_vals <- try(ncdf4::ncvar_get(nc, nc$var[[zvar]]$dim[[dim3]]$name), silent = TRUE) if (inherits(dim3_vals, "try-error")) { dim3_vals <- seq_len(nc$var[[zvar]]$dim[[dim3]]$len) } r@z <- list(dim3_vals) if ( nc$var[[zvar]]$dim[[dim3]]$name == 'time' ) { try( r <- .doTime(r, nc, zvar, dim3) ) } else { vname <- nc$var[[zvar]]$dim[[dim3]]$name vunit <- nc$var[[zvar]]$dim[[dim3]]$units names(r@z) <- paste0(vname, " (", vunit, ")") } } if (length(ndims)== 2 & type != 'RasterLayer') { warning('cannot make a RasterBrick from data that has only two dimensions (no time step), returning a RasterLayer instead') } if (type == 'RasterLayer') { if (is.null(band) | is.na(band)) { if (ndims > 2) { stop(zvar, ' has multiple layers, provide a "band" value between 1 and ', nc$var[[zvar]]$dim[[dim3]]$len) } } else { if (length(band) > 1) { stop('A RasterLayer can only have a single band. You can use a RasterBrick instead') } if (is.na(band)) { r@data@band <- as.integer(1) } else { band <- as.integer(band) if ( band > nbands(r) ) { stop(paste("The band number is too high. It should be between 1 and", nbands)) } if ( band < 1) { stop(paste("band should be 1 or higher")) } r@data@band <- band } r@z <- list( getZ(r)[r@data@band] ) if (!(is.null(minv) | is.null(maxv))) { r@data@min <- minv[band] r@data@max <- maxv[band] r@data@haveminmax <- TRUE } } } else { r@data@nlayers <- r@file@nbands try( names(r) <- as.character(r@z[[1]]), silent=TRUE ) if (!(is.null(minv) | is.null(maxv))) { r@data@min <- minv r@data@max <- maxv r@data@haveminmax <- TRUE } else { r@data@min <- rep(Inf, r@file@nbands) r@data@max <- rep(-Inf, r@file@nbands) } } return(r) } raster/R/indexReplace.R0000644000176200001440000001072514507510157014513 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setReplaceMethod("[", c("RasterLayer", "RasterLayer", "missing"), function(x, i, j, value) { i <- crop(i, x) if (inherits(value, 'RasterLayer')) { value <- getValues(value) } if (! hasValues(i) ) { i <- cellsFromExtent(x, i) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { i <- as.logical( getValues(i) ) } else { j <- as.logical( getValues(i) ) i <- cellsFromExtent(x, i)[j] x[i] <- value return(x) } .replace(x, i, value=value, recycle=1) } ) setReplaceMethod("[", c("RasterLayer","missing","missing"), function(x, i, j, value) { if (length(value) == ncell(x)) { x <- try( setValues(x, value)) } else if (length(value) == 1) { x <- try( setValues(x, rep(value, times=ncell(x))) ) } else { v <- try( vector(length=ncell(x)) ) if (! inherits(x, "try-error")) { v[] <- value x <- try( setValues(x, v) ) } } if (inherits(x, "try-error")) { stop('cannot replace values on this raster (it is too large') } return(x) } ) .replace <- function(x, i, value, recycle=1) { if ( is.logical(i) ) { i <- which(i) } else { i <- stats::na.omit(i) } if (any(i < 1)) { if (!all(i < 1)) {stop("you cannot mix negative and positive subscript")} j <- i i <- 1:ncell(x) i <- i[j] } nl <- nlayers(x) # recycling if (nl > 1 & recycle > 0) { rec2 <- ceiling(nl / recycle) if (rec2 > 1) { add <- ncell(x)*recycle * (0:(rec2-1)) i <- as.vector(t((matrix(rep(i, rec2), nrow=rec2, byrow=TRUE)) + add)) } } j <- i > 0 & i <= (ncell(x)*nl) if (!all(j)) { i <- i[j] if (length(value) > 1) { value <- value[j] } } if ( inMemory(x) ) { if (inherits(x, 'RasterStack')) { x <- brick( x, values=TRUE ) # this may go to disk, hence we check again below } } if ( inMemory(x) & hasValues(x) ) { x@data@values[i] <- value x <- setMinMax(x) x <- .clearFile(x) return(x) } else if (canProcessInMemory(x)) { if (inherits(x, 'RasterStack')) { x <- brick( x, values=TRUE ) if (!inMemory(x)) { x <- readAll(x) } x <- .clearFile(x) x@data@values[i] <- value x <- setMinMax(x) } else if ( fromDisk(x) ) { x <- readAll(x) x <- .clearFile(x) x@data@values[i] <- value x <- setMinMax(x) } else { vals <- rep(NA, times=ncell(x)*nl) vals[i] <- value x <- setValues(x, vals) } return(x) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='replace') hv <- hasValues(x) if (nl==1) { if (! length(value) %in% c(1, length(i))) { stop('cannot replace values in large Raster objects if their length is not 1 or the number of cells to be replaced') } r <- raster(x) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) for (k in 1:tr$n) { # cells <- cellFromRowCol(x, tr$row[k], 1):cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x)) cell1 <- cellFromRowCol(x, tr$row[k], 1) cell2 <- cell1 + tr$nrows[k] * ncol(x) - 1 if (hv) { v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k]) } else { v <- rep(NA, 1+cell2-cell1) } j <- which(i >= cell1 & i <= cell2) if (length(j) > 0) { localcells <- i[j] - (cell1-1) if (length(value) == length(i)) { v[localcells] <- value[j] } else { v[localcells] <- value } } r <- writeValues(r, v, tr$row[k]) pbStep(pb, k) } r <- writeStop(r) pbClose(pb) return(r) } else { if (! length(value) %in% c(1, length(i))) { stop('length of replacement values does not match the length of the index') } r <- brick(x, values=FALSE) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) # add <- (0:(nl-1)) * ncell(x) # remove the added cells again.... nc <- ncol(x) ii <- (i-1) %% ncell(x) + 1 for (k in 1:tr$n) { startcell <- cellFromRowCol(x, tr$row[k], 1) endcell <- cellFromRowCol(x, tr$row[k]+tr$nrows[k]-1, ncol(x)) if (hv) { v <- getValues(x, row=tr$row[k], nrows=tr$nrows[k]) } else { v <- matrix(NA, nrow=tr$nrows[k] * nc, ncol=nl) } j <- i[ii >= startcell & ii <= endcell] - startcell + 1 if (length(j) > 0) { jj <- (j %/% ncell(x)) * tr$nrow[k] * ncol(x) + (j %% ncell(x)) if (length(value) == length(i)) { v[jj] <- value[jj] } else { v[jj] <- value } } r <- writeValues(r, v, tr$row[k]) pbStep(pb, k) } r <- writeStop(r) pbClose(pb) return(r) } } } raster/R/sf.R0000644000176200001440000000121214507510157012507 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2017 # Version 1.0 # Licence GPL v3 .sf2sp <- function(from) { #if (!requireNamespace("sf")) { # stop("package sf is not available") #} # to do #if (from == "GEOMETRYCOLLECTION") { # x <- list() # for (i in 1:3 ) { } # return(x) #} p <- as(from, "Spatial") if (isTRUE(ncol(p) == 0)) { # for the degenerate Spatial*DataFrame that has zero variables if (inherits(p, "SpatialPolygons")) { p <- as(p, "SpatialPolygons") } else if (inherits(p, "SpatialLines")) { p <- as(p, "SpatialLines") } else if (inherits(p, "SpatialPoints")) { p <- as(p, "SpatialPoints") } } p } raster/R/fourCellsFromXY.R0000644000176200001440000000103114507510157015141 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2009, August 2012 # Licence GPL v3 # updated November 2011 # version 1.0 fourCellsFromXY <- function(object, xy, duplicates=TRUE) { # if duplicates is TRUE, the same cell number can be returned # twice (if point in the middle of division between two cells) or # four times (if point in center of cell) r <- raster(object) # use small object stopifnot(is.matrix(xy)) return( .doFourCellsFromXY(r@ncols, r@nrows, xmin(r), xmax(r), ymin(r), ymax(r), xy, duplicates, .isGlobalLonLat(r))) } raster/R/summary-methods.R0000644000176200001440000000404514507510157015244 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .addArgs <- function(...) { lst <- list(...) if (length(lst) > 0 ) { i <- sapply(lst, function(x) class(x) %in% c('logical', 'integer', 'numeric')) add <- unlist(lst[i], use.names = FALSE) } else { add <- NULL } return(add) } setMethod("Summary", signature(x='Raster'), function(x, ..., na.rm=FALSE){ fun <- as.character(sys.call()[[1L]]) dots <- list(...) if (length(dots) > 0) { d <- sapply(dots, function(i) inherits(i, 'Raster')) if (any(d)) { x <- .makeRasterList(x, dots[d]) if (length(x) > 1) { x <- stack(x) } else { x <- x[[1]] } } add <- .addArgs(unlist(dots[!d])) } else { add <- NULL } if (nlayers(x)==1 & length(add)==0) { warning('Nothing to summarize if you provide a single RasterLayer; see cellStats') return(x) } if (fun[1] == 'sum') { return(.sum( x, add, na.rm=na.rm)) } else if (fun[1] == 'min') { return(.min( x, add, na.rm=na.rm )) } else if (fun[1] == 'max') { return(.max( x, add, na.rm=na.rm)) } else if (fun[1] == 'range') { return(.range( x, add, na.rm=na.rm)) } out <- raster(x) if (canProcessInMemory(x)) { if (!is.null(add)) { add <- fun(add, na.rm=na.rm) x <- cbind(getValues(x), add) } else { x <- getValues(x) } x <- apply(x, 1, FUN=fun, na.rm=na.rm) out <- setValues(out, x) return(out) } tr <- blockSize(x) out <- writeStart(out, filename="") x <- readStart(x) pb <- pbCreate(tr$n) if (!is.null(add)) { add <- fun(add, na.rm=na.rm) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- apply(cbind(v, add), 1, FUN=fun, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- apply(v, 1, FUN=fun, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } pbClose(pb) x <- readStop(x) writeStop(out) } ) raster/R/mask.R0000644000176200001440000004370214507510157013044 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 1.0 # Licence GPL v3 setMethod('mask', signature(x='Raster', mask='sf'), function(x, mask, ...) { mask <- .sf2sp(mask) mask(x, mask, ...) } ) setMethod('mask', signature(x='Raster', mask='Spatial'), function(x, mask, filename="", inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...){ if (inherits(mask, 'SpatialPolygons')) { m <- .fasterize(mask, x, values=rep(1,length(mask))) } else { m <- rasterize(mask, x, 1, silent=TRUE) } mask(x, m, filename=filename, inverse=inverse, maskvalue=NA, updatevalue=updatevalue, ...) } ) setMethod('mask', signature(x='RasterLayer', mask='RasterLayer'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] compareRaster(x, mask) out <- .copyWithProperties(x) if ( canProcessInMemory(x, 3)) { x <- getValues(x) mask <- getValues(mask) if (is.na(maskvalue)) { if (updateNA) { if (inverse) { x[!is.na(mask)] <- updatevalue } else { x[is.na(mask)] <- updatevalue } } else { if (inverse) { x[!is.na(mask) & !is.na(x)] <- updatevalue } else { x[is.na(mask) & !is.na(x)] <- updatevalue } } } else { if (updateNA) { if (inverse) { x[mask != maskvalue] <- updatevalue } else { x[mask == maskvalue] <- updatevalue } } else { if (inverse) { x[mask != maskvalue & !is.na(x)] <- updatevalue } else { x[mask == maskvalue & !is.na(x)] <- updatevalue } } } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } else { if (filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (is.na(updatevalue)) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (updateNA) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m==maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterStackBrick', mask='RasterLayer'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ compareRaster(x, mask) maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] out <- .copyWithProperties(x) if (canProcessInMemory(x, nlayers(x)+4)) { x <- getValues(x) if (is.na(maskvalue)) { if (updateNA) { if (inverse) { x[!is.na(getValues(mask))] <- updatevalue } else { x[is.na(getValues(mask))] <- updatevalue } } else { if (inverse) { x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue } else { x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue } } } else { if (updateNA) { if (inverse) { x[getValues(mask) != maskvalue] <- updatevalue } else { x[getValues(mask) == maskvalue] <- updatevalue } } else { if (inverse) { x[getValues(mask) != maskvalue & !is.na(x)] <- updatevalue } else { x[getValues(mask) == maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (is.na(updatevalue)) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- NA out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (updateNA) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterLayer', mask='RasterStackBrick'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ compareRaster(x, mask) out <- brick(mask, values=FALSE) maskvalue <- maskvalue[1] updatevalue <- updatevalue[1] if (canProcessInMemory(mask, nlayers(x)*2+2)) { x <- getValues(x) x <- matrix(rep(x, nlayers(out)), ncol=nlayers(out)) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { x[!is.na(getValues(mask))] <- updatevalue } else { x[is.na(getValues(mask))] <- updatevalue } } else { if (inverse) { x[getValues(mask)!=maskvalue] <- updatevalue } else { x[getValues(mask)==maskvalue] <- updatevalue } } } else { if (is.na(maskvalue)) { if (inverse) { x[!is.na(getValues(mask)) & !is.na(x)] <- updatevalue } else { x[is.na(getValues(mask)) & !is.na(x)] <- updatevalue } } else { if (inverse) { x[getValues(mask)!=maskvalue & !is.na(x)] <- updatevalue } else { x[getValues(mask)==maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[!is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[is.na(m) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m != maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- matrix(rep(v, nlayers(out)), ncol=nlayers(out)) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[m == maskvalue & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } pbClose(pb) out <- writeStop(out) return(out) } } ) setMethod('mask', signature(x='RasterStackBrick', mask='RasterStackBrick'), function(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...){ nlx <- nlayers(x) nlk <- nlayers(mask) if ( nlx != nlk ) { if (nlx == 1) { x <- raster(x, 1) return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...)) } if (nlk == 1) { mask <- raster(mask, 1) return(mask(x, mask, filename=filename, inverse=inverse, maskvalue=maskvalue, updatevalue=updatevalue, ...)) } if (! ((nlx > nlk) & (nlx %% nlk == 0)) ) { stop('number of layers of x and mask must be the same,\nor one of the two should be 1, or the number of layers of x\nshould be divisible by the number of layers of mask') } } updatevalue <- updatevalue[1] maskvalue <- maskvalue[1] compareRaster(x, mask) out <- brick(x, values=FALSE) ln <- names(x) names(out) <- ln if (canProcessInMemory(x, nlx*2)) { x <- getValues(x) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { x[!is.na(as.vector(getValues(mask)))] <- updatevalue } else { x[is.na(as.vector(getValues(mask)))] <- updatevalue } } else { if (inverse) { x[as.vector(getValues(mask)) != maskvalue] <- updatevalue } else { x[as.vector(getValues(mask)) == maskvalue] <- updatevalue } } } else { if (is.na(maskvalue)) { if (inverse) { x[!is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue } else { x[is.na(as.vector(getValues(mask))) & !is.na(x)] <- updatevalue } } else { if (inverse) { x[as.vector(getValues(mask)) != maskvalue & !is.na(x)] <- updatevalue } else { x[as.vector(getValues(mask)) == maskvalue & !is.na(x)] <- updatevalue } } } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename, ...) names(out) <- ln } return(out) } else { if ( filename=='') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='mask', ...) if (updateNA) { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(!is.na(m))] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(is.na(m))] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m != maskvalue)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m == maskvalue)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { if (is.na(maskvalue)) { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(!is.na(m)) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(is.na(m)) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { if (inverse) { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m != maskvalue) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) m <- getValues( mask, row=tr$row[i], nrows=tr$nrows[i] ) v[as.vector(m == maskvalue) & !is.na(v)] <- updatevalue out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } pbClose(pb) out <- writeStop(out) names(out) <- ln return(out) } } ) raster/R/flowpath.R0000644000176200001440000000403614507510157013732 0ustar liggesusers# drain.R # This script calculates the drainage of a point on a DEM - in R! # written by A. Shortridge, 10/2013 # changes by Robert Hijmans flowPath <- function(x, p, ...) { r <- raster(x) if (length(p) > 1) { p <- cellFromXY(r, p[1:2]) } cell <- p row <- rowFromCell(r, cell) col <- colFromCell(r, cell) nr <- nrow(r) nc <- ncol(r) path <- NULL while (!is.na(x[cell])) { path <- c(path, cell) fd <- x[cell] row <- if(fd %in% c(32, 64, 128)) row - 1 else if(fd %in% c(8, 4, 2)) row + 1 else row col <- if(fd %in% c(32, 16, 8)) col - 1 else if(fd %in% c(128, 1, 2)) col + 1 else col cell <- cellFromRowCol(r, row, col) # Don't drain off the raster or drain NA cells on x! if (is.na(x[cell])) break # avoid cell i draining to j and j draining to i traps if (cell %in% path) break } return(path) } .flowPath1 <- function(x, p) { # This function creates a raster with 1s representing a path from # the start cell to the end of the flowpath. x is a flow raster # created with the terrain() function in raster. Returns a raster # where 1 represents a part of this path and 0 is off-path. out <- raster(x) if (length(p) > 1) { p <- cellFromXY(out, p[1:2]) } row <- rowFromCell(out, p) col <- colFromCell(out, p) out[row, col] <- 1 while (!is.na(x[row, col])) { # not in a pit out[row, col] <- 1 fdval <- x[row, col] col <- if(fdval %in% c(32, 16, 8)) col - 1 else if(fdval %in% c(128, 1, 2)) col + 1 else col row <- if(fdval %in% c(32, 64, 128)) row - 1 else if(fdval %in% c(8, 4, 2)) row + 1 else row # Don't drain off the raster! if (row < 1 || row > dim(x)[1] || col < 1 || col > dim(x)[2]) break # Don't drain NA cells on x! if (is.na(x[row, col])) break # avoid cell i draining to j and j draining to i traps if (!is.na(out[row, col])) break } return(out) } raster/R/hdrVRT.R0000644000176200001440000000505014507510157013254 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2010 # Version 1.0 # Licence GPL v3 .writeHdrVRT <- function(x) { fn <- fname <- x@file@name if (tolower(extension(fn)) == '.vrt') { stop('cannot (over)write a vrt header for a vrt file') } if (tolower(extension(fn)) == '.grd') { extension(fn) <- '.gri' } extension(fname) <- 'vrt' pixsize <- dataSize(x@file@datanotation) nbands <- nlayers(x) bandorder <- x@file@bandorder if (bandorder == 'BIL') { pixoff <- pixsize lineoff <- pixsize * x@ncols * nbands imgoff <- ((1:nbands)-1) * x@ncols * pixsize } else if (bandorder == 'BSQ') { pixoff <- pixsize lineoff <- pixsize * x@ncols imgoff <- ((1:nbands)-1) * ncell(x) * pixsize } else if (bandorder == 'BIP') { pixoff <- pixsize * nbands lineoff <- pixsize * x@ncols * nbands imgoff <- (1:nbands)-1 } datatype <- .getGdalDType(x@file@datanotation) if (x@file@byteorder == "little") { byteorder <- "LSB" } else { byteorder <- "MSB" } if (! x@file@toptobottom) { rotation <- 180 } else { rotation <- 0 } e <- x@extent r <- res(x) prj <- proj4string(x) f <- file(fname, "w") cat('\n' , sep = "", file = f) if (rotated(r)) { cat('', paste(x@rotation@geotrans, collapse=', '), '\n', sep = "", file = f) } else { cat('', e@xmin, ', ', r[1], ', ', rotation, ', ', e@ymax, ', ', 0.0, ', ', -1*r[2], '\n', sep = "", file = f) } if (! is.na(prj) ) { cat('', prj ,'\n', sep = "", file = f) } for (i in 1:nlayers(x)) { cat('\t\n', sep = "" , file = f) cat('\t\t', names(x), '\n', sep = "", file = f) cat('\t\t', basename(fn), '\n', sep = "", file = f) cat('\t\t', imgoff[i], '\n', sep = "", file = f) cat('\t\t', pixoff, '\n', sep = "", file = f) cat('\t\t', lineoff, '\n', sep = "", file = f) cat('\t\t', byteorder, '\n', sep = "", file = f) cat('\t\t', x@file@nodatavalue, '\n', sep = "", file = f) cat('\t\t', x@data@offset, '\n', sep = "", file = f) cat('\t\t', x@data@gain, '\n', sep = "", file = f) cat('\t\n', sep = "", file = f) } cat('\n', sep = "", file = f) close(f) return( invisible(TRUE) ) } raster/R/init.R0000644000176200001440000000607214507510157013053 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod("init", signature(x="Raster"), function(x, fun='cell', filename="", ...) { vv <- list(...)$v v <- NULL if (!is.null(vv)) { if (vv %in% c('x', 'y', 'row', 'col', 'cell', 'chess')) { v <- vv } } else if (is.character(fun) ) { fun <- tolower(fun[1]) if (fun %in% c('x', 'y', 'row', 'col', 'cell', 'chess')) { v <- fun } else { stop("argument 'fun' is a character variable, but not one of 'x', 'y', 'row', 'col', 'cell', or 'chess'") } } else if (is.numeric(fun)) { value <- fun fun <- function(...) value } out <- raster(x) filename <- trim(filename) inmem=TRUE if (!canProcessInMemory(out, 2)) { inmem=FALSE if (filename == '') { filename <- rasterTmpFile() } } if (!is.null(v)) { if ( inmem ) { if (v == 'cell') { out <- setValues(out, 1:ncell(out)) } else if (v == 'row') { out <- setValues(out, rep(1:nrow(out), each=ncol(out))) } else if (v == 'y') { out <- setValues(out, rep(yFromRow(out, 1:nrow(out)), each=ncol(out))) } else if (v == 'col') { out <- setValues(out, rep(1:ncol(out), times=nrow(out))) } else if (v == 'x') { out <- setValues(out, rep(xFromCol(out, 1:ncol(out)), times=nrow(out))) } else if (v == 'chess') { if ((ncol(out) %% 2) == 1) { out <- setValues(out, c(rep(c(0,1), floor(ncell(out)/2)), 0)) } else { rs <- c(rep(c(0,1), ncol(out) / 2), rep(c(1,0), ncol(out) / 2)) rs <- rep(rs, floor(nrow(out) / 2)) if ((nrow(out) %% 2) == 1) { rs <- c(rs, rep(c(0,1), ncol(out) / 2)) } out <- setValues(out, rs) } } } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='init', ...) for (i in 1:tr$n) { if (v == 'cell') { out <- writeValues(out, cellFromRowCol(out, tr$row[i],1):cellFromRowCol(out, tr$row[i]+tr$nrows[i]-1, ncol(out)), tr$row[i]) } else if (v == 'row') { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) out <- writeValues(out, rep(r, each=ncol(out)), tr$row[i]) } else if (v == 'col') { out <- writeValues(out, rep(1:ncol(out), tr$nrows[i]), tr$row[i]) } else if (v == 'x') { out <- writeValues(out, rep(xFromCol(out, 1:ncol(out)), tr$nrows[i]), tr$row[i]) } else if (v == 'y') { r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) out <- writeValues(out, rep(yFromRow(out, r), each=ncol(out)), tr$row[i]) } else if (v == 'chess') { stop('not implemented for large files yet') } pbStep(pb, i) } pbClose(pb) out <- writeStop(out) } } else { if ( inmem ) { n <- ncell(out) out <- setValues(out, fun(n)) } else { out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='init', ...) for (i in 1:tr$n) { n <- ncol(out) * tr$nrows[i] out <- writeValues(out, fun(n), tr$row[i]) pbStep(pb, r) } pbClose(pb) out <- writeStop(out) } } if (inmem & filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } ) raster/R/rasterFromSAGA.R0000644000176200001440000000544114507510157014667 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .rasterFromSAGAFile <- function(filename, crs="", ...) { valuesfile <- .setFileExtensionValues(filename, "SAGA") if (!file.exists(valuesfile )){ stop( paste(valuesfile, "does not exist")) } filename <- .setFileExtensionHeader(filename, "SAGA") ini <- readIniFile(filename) ini[,2] = toupper(ini[,2]) byteorder <- .Platform$endian ncellvals <- -9 nodataval <- -Inf layernames <- '' toptobottom <- FALSE dfoffset <- as.integer(0) zfactor <- 1 for (i in 1:length(ini[,1])) { if (ini[i,2] == "POSITION_XMIN") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "POSITION_YMIN") { yn <- as.numeric(ini[i,3])} else if (ini[i,2] == "CELLCOUNT_Y") { nr <- as.integer(ini[i,3])} else if (ini[i,2] == "CELLCOUNT_X") { nc <- as.integer(ini[i,3])} else if (ini[i,2] == "CELLSIZE") { cellsize <- as.numeric(ini[i,3])} else if (ini[i,2] == "NODATA_VALUE") { nodataval <- as.numeric(ini[i,3])} else if (ini[i,2] == "DATAFORMAT") { inidatatype <- ini[i,3]} else if (ini[i,2] == "BYTEORDER_BIG") { byteorder <- as.logical(ini[i,3])} # else if (ini[i,2] == "NCELLVALS") {ncellvals <- ini[i,3]} else if (ini[i,2] == "NAME") { layernames <- ini[i,3]} else if (ini[i,2] == "Z_FACTOR") { zfactor <- as.numeric(ini[i,3])} else if (ini[i,2] == "TOPTOBOTTOM") { toptobottom <- as.logical(ini[i,3])} else if (ini[i,2] == "DATAFILE_OFFSET") { dfoffset <- as.integer(ini[i,3])} } xx <- xn + nc * cellsize - (0.5 * cellsize) xn <- xn - (0.5 * cellsize) yx <- yn + nr * cellsize - (0.5 * cellsize) yn <- yn - (0.5 * cellsize) x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=crs) x@file@offset <- dfoffset x@file@toptobottom <- toptobottom if (nchar(layernames) > 1) { lnams <- unlist(strsplit(layernames, ':')) } else { lnams <- gsub(" ", "_", extension(basename(filename), "")) } names(x) <- lnams x@file@name <- filename x@data@haveminmax <- FALSE x@file@nodatavalue <- nodataval if (inidatatype == 'BIT') { stop('cannot process BIT data') } else if (inidatatype == 'BYTE') { dataType(x) <- 'INT1S' } else if (inidatatype == 'BYTE_UNSIGNED') { dataType(x) <- 'INT1U' } else if (inidatatype == 'SHORTINT') { dataType(x) <- 'INT2S' } else if (inidatatype == 'SHORTINT_UNSIGNED') { dataType(x) <- 'INT2U' } else if (inidatatype == 'INTEGER') { dataType(x) <- 'INT4S' } else if (inidatatype == 'INTEGER_UNSIGNED') { dataType(x) <- 'INT4U' } else if (inidatatype == 'FLOAT') { dataType(x) <- 'FLT4S' } else if (inidatatype == 'DOUBLE') { dataType(x) <- 'FLT8S' } if (byteorder) { x@file@byteorder <- 'big' } else { x@file@byteorder <- 'little' } x@data@fromdisk <- TRUE x@data@gain <- zfactor x@file@driver <- 'SAGA' return(x) } raster/R/boundaries.R0000644000176200001440000000606414507510157014244 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 # name overlap with igraph setMethod('boundaries', signature(x='RasterLayer'), function(x, type='inner', classes=FALSE, directions=8, asNA=FALSE, filename="", ...) { stopifnot( nlayers(x) == 1 ) stopifnot( hasValues(x) ) filename <- trim(filename) out <- raster(x) gll <- as.integer( .isGlobalLonLat(out) ) type <- tolower(type) if (! type %in% c('inner', 'outer')) { stop("type must be 'inner', or 'outer'") } if (type=='inner') { type <- FALSE } else { type <- TRUE } classes <- as.logical(classes) directions <- as.integer(directions) stopifnot(directions %in% c(4,8)) # asZero <- as.integer(as.logical(asZero)) datatype <- list(...)$datatype if (is.null(datatype)) { datatype <- 'INT2S' } if (canProcessInMemory(out, 4)) { x <- as.matrix(x) if (gll) { x <- cbind(x[, ncol(x)], x, x[, 1]) } else { x <- cbind(x[, 1], x, x[, ncol(x)]) } x <- rbind(x[1,], x, x[nrow(x),]) paddim <- as.integer(dim(x)) x <- .edge(round(t(x)), paddim, classes[1], type[1], directions[1]) if (asNA) { x[x==0] <- as.integer(NA) } x <- matrix(x, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) x <- x[2:(nrow(x)-1), 2:(ncol(x)-1)] x <- setValues(out, as.vector(t(x))) if (filename != '') { x <- writeRaster(x, filename, datatype=datatype, ...) } return(x) } else { out <- writeStart(out, filename, datatype=datatype, ...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label='boundaries', ...) nc <- ncol(out)+2 v <- getValues(x, row=1, nrows=tr$nrows[1]+1) v <- matrix(v, ncol=tr$nrows[1]+1) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- round(cbind(v[,1], v)) v <- .edge(v, as.integer(c(tr$nrows[1]+2, nc)), classes, type, directions) if (asNA) { v[v==0] <- as.integer(NA) } v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, 1) pbStep(pb, 1) if (tr$n > 2) { for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+2) v <- matrix(v, ncol=tr$nrows[1]+2) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- .edge(round(v), as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions) v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } i <- tr$n v <- getValues(x, row=tr$row[i]-1, nrows=tr$nrows[i]+1) v <- matrix(v, ncol=tr$nrows[i]+1) if (gll) { v <- rbind(v[nrow(v),], v, v[1,]) } else { v <- rbind(v[1,], v, v[nrow(v),]) } v <- round(cbind(v, v[,ncol(v)])) v <- .edge(v, as.integer(c(tr$nrows[i]+2, nc)), classes, type, directions) v <- matrix(v, ncol=nc, byrow=TRUE) v <- as.integer(t(v[2:(nrow(v)-1), 2:(ncol(v)-1)])) out <- writeValues(out, v, tr$row[i]) pbStep(pb, tr$n) out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/as.character.R0000644000176200001440000000146114507510157014443 0ustar liggesusers setMethod("as.character", signature(x="Extent"), function(x, ...) { e <- extent(x) paste0("extent(", paste(as.vector(e), collapse=", "), ")") } ) setMethod("as.character", signature(x="Raster"), function(x, ...) { e <- extent(x) crs <- proj4string(x) crs <- ifelse(is.na(crs), ", crs=''", paste0(", crs='", crs, "'")) if (nlayers(x) < 2) { paste0("raster(", "ncols=",ncol(x), ", nrows=",nrow(x), ", xmn=",e[1], ", xmx=",e[2], ", ymn=",e[3], ", ymx=",e[4], crs, ")" ) } else { paste0("brick(", "ncol=", ncol(x), ", nrow=", nrow(x), ", nl=", nlayers(x), ", xmn=",e[1], ", xmx=",e[2], ", ymn=",e[3], ", ymx=",e[4], crs, ")" ) } } ) #eval(parse(text=as.character(raster()))) #eval(parse(text=as.character(stack()))) raster/R/origin.R0000644000176200001440000000176514507510157013403 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod('origin', signature(x='BasicRaster'), function(x, ...) { e <- x@extent r <- res(x) x <- e@xmin - r[1]*(round(e@xmin / r[1])) y <- e@ymax - r[2]*(round(e@ymax / r[2])) if (isTRUE(all.equal((r[1] + x), abs(x)))) { x <- abs(x) } if (isTRUE(all.equal((r[2] + y), abs(y)))) { y <- abs(y) } return(c(x, y)) } ) setMethod("origin<-", signature('BasicRaster'), function(x, value) { value <- rep(value, length.out=2) dif <- value - origin(x) res <- res(x) dif[1] <- dif[1] %% res[1] dif[2] <- dif[2] %% res[2] for (i in 1:2) { if (dif[i] < 0) { if ((dif[i] + res[i]) < abs(dif[i])) { dif[i] <- dif[i] + res[i] } } else { if (abs(dif[i] - res[i]) < dif[i]) { dif[i] <- dif[i] - res[i] } } } e <- extent(x) e@xmin <- e@xmin + dif[1] e@xmax <- e@xmax + dif[1] e@ymin <- e@ymin + dif[2] e@ymax <- e@ymax + dif[2] x@extent <- e return(x) } ) raster/R/Geary.R0000644000176200001440000000316214507510157013154 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2011 # Version 1.0 # Licence GPL v3 .getFilter <- function(w, warn=TRUE) { if (!is.matrix(w)) { w <- .checkngb(w) w <- matrix(1, nrow=w[1], ncol=(w[2])) w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0 } else { if (w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] != 0) { if (warn) { warning('central cell of weights matrix (filter) was set to zero') } w[ceiling(dim(w)[1]/2), ceiling(dim(w)[2]/2)] <- 0 } stopifnot(all(w >= 0)) } if (min(dim(w) %% 2)==0) { stop('dimensions of weights matrix (filter) must be uneven') } w } Geary <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3)) { w <- .getFilter(w, warn=FALSE) i <- trunc(length(w)/2)+1 n <- ncell(x) - cellStats(x, 'countNA') fun <- function(x,...) sum(w*(x-x[i])^2, ...) w2 <- w w2[] <- 1 Eij <- cellStats(focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE), sum) if (sum(! unique(w) %in% 0:1) > 0) { xx <- calc(x, fun=function(x) ifelse(is.na(x), NA ,1)) W <- focal(xx, w=w, na.rm=TRUE, pad=TRUE ) } else { w[w==0] <- NA W <- focal(x, w=w, fun=function(x, ...){ sum(!is.na(x)) }, pad=TRUE ) } z <- 2 * cellStats(W, sum) * cellStats((x - cellStats(x, mean))^2, sum) (n-1)*Eij/z } GearyLocal <- function(x, w=matrix(c(1,1,1,1,0,1,1,1,1),3,3)) { w <- .getFilter(w) i <- trunc(length(w)/2)+1 fun <- function(x,...) sum(w*(x-x[i])^2, ...) w2 <- w w2[] <- 1 Eij <- focal(x, w=w2, fun=fun, na.rm=TRUE, pad=TRUE) s2 <- cellStats(x, 'sd')^2 if (ncell(x) < 1000000) { n <- ncell(x) - cellStats(x, 'countNA' ) } else { n <- ncell(x) } #s2 <- (s2 * (n-1)) / n Eij / s2 } raster/R/focalWeight.R0000644000176200001440000000440614507510157014343 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2013 # Version 1.0 # Licence GPL v3 .circular.weight <- function(rs, d, fillNA=FALSE) { nx <- 1 + 2 * floor(d/rs[1]) ny <- 1 + 2 * floor(d/rs[2]) w <- matrix(ncol=nx, nrow=ny) w[ceiling(ny/2), ceiling(nx/2)] <- 1 if ((nx != 1) || (ny != 1)) { x <- raster(w, xmn=0, xmx=nx*rs[1], ymn=0, ymx=ny*rs[2], crs="+proj=utm +zone=1 +datum=WGS84") d <- as.matrix(distance(x)) <= d w <- d / sum(d) } if (fillNA) { w[w <= 0] <- NA } w } .Gauss.weight <- function(rs, sigma) { if (length(sigma) == 1) { d <- 3 * sigma } else { d <- sigma[2] sigma <- sigma[1] } nx <- 1 + 2 * floor(d/rs[1]) ny <- 1 + 2 * floor(d/rs[2]) m <- matrix(ncol=nx, nrow=ny) xr <- (nx * rs[1]) / 2 yr <- (ny * rs[2]) / 2 r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs="+proj=utm +zone=1 +datum=WGS84") p <- xyFromCell(r, 1:ncell(r))^2 # according to http://en.wikipedia.org/wiki/Gaussian_filter m <- 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2)) m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE) # sum of weights should add up to 1 m / sum(m) } .rectangle.weight <- function(rs, d) { d <- rep(d, length.out=2) nx <- 1 + 2 * floor(d[1]/rs[1]) ny <- 1 + 2 * floor(d[2]/rs[2]) m <- matrix(1, ncol=nx, nrow=ny) m / sum(m) } focalWeight <- function(x, d, type=c('circle', 'Gauss', 'rectangle'), fillNA=FALSE) { type <- match.arg(type) x <- res(x) if (type == 'circle') { .circular.weight(x, d[1], fillNA) } else if (type == 'Gauss') { if (!length(d) %in% 1:2) { stop("If type=Gauss, d should be a vector of length 1 or 2") } .Gauss.weight(x, d) } else { .rectangle.weight(x, d) } } ..simple.circular.weight <- function(radius) { # based on a function provided by Thomas Cornulier x <- -radius:radius n <- length(x) d <- sqrt(rep(x, n)^2 + rep(x, each=n)^2) <= radius matrix(d + 0, n, n) / sum(d) } ..simple.Gauss.weight <- function(n, sigma) { # need to adjust for non-square cells to distance.... m <- matrix(ncol=n, nrow=n) col <- rep(1:n, n) row <- rep(1:n, each=n) x <- col - ceiling(n/2) y <- row - ceiling(n/2) # according to http://en.wikipedia.org/wiki/Gaussian_filter m[cbind(row, col)] <- 1/(2*pi*sigma^2) * exp(-(x^2+y^2)/(2*sigma^2)) # sum of weights should add up to 1 m / sum(m) } raster/R/hdrRaster.R0000644000176200001440000000776114507510157014054 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .writeHdrRaster <- function(x, type='raster') { rastergrd <- .setFileExtensionHeader(filename(x), type) thefile <- file(rastergrd, "w") # open an txt file connection cat("[general]", "\n", file = thefile, sep='') cat("creator=R package 'raster'", "\n", file = thefile, sep='') cat("created=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n", file = thefile, sep='') cat("[data]", "\n", file = thefile, sep='') cat("datatype=", x@file@datanotation, "\n", file = thefile, sep='') cat("byteorder=", x@file@byteorder, "\n", file = thefile, sep='') nl <- nlayers(x) cat("nbands=", nl, "\n", file = thefile, sep='') cat("bandorder=", x@file@bandorder, "\n", file = thefile, sep='') # currently only for single layer files! if (nl == 1) { fact <- is.factor(x)[1] cat("categorical=", paste(fact, collapse=':'), "\n", file = thefile, sep='') if (any(fact)) { r <- x@data@attributes[[1]] cat("ratnames=", paste(colnames(r), collapse=':'), "\n", file = thefile, sep='') cat("rattypes=", paste(sapply(r, class), collapse=':'), "\n", file = thefile, sep='') v <- trim(as.character(as.matrix(r))) v <- gsub(":", "~^colon^~", v) cat("ratvalues=", paste(v, collapse=':'), "\n", file = thefile, sep='') } if (length(x@legend@colortable) > 1) { cat("colortable=", paste(x@legend@colortable, collapse=':'), "\n", file = thefile, sep='') } } # cat("levels=", x@data@levels, "\n", file = thefile, sep='') cat("minvalue=", paste(minValue(x, -1, warn=FALSE), collapse=':'), "\n", file = thefile, sep='') cat("maxvalue=", paste(maxValue(x, -1, warn=FALSE), collapse=':'), "\n", file = thefile, sep='') cat("nodatavalue=", .nodatavalue(x), "\n", file = thefile, sep='') # cat("Sparse=", x@sparse, "\n", file = thefile, sep='') # cat("nCellvals=", x@data@ncellvals, "\n", file = thefile, sep='') cat("[legend]", "\n", file = thefile, sep='') cat("legendtype=", x@legend@type, "\n", file = thefile, sep='') cat("values=", paste(x@legend@values, collapse=':'), "\n", file = thefile, sep='') cat("color=", paste(x@legend@color, collapse=':'), "\n", file = thefile, sep='') cat("[description]", "\n", file = thefile, sep='') ln <- gsub(":", ".", names(x)) cat("layername=", paste(ln, collapse=':'), "\n", file = thefile, sep='') z <- getZ(x) if (! is.null(z)) { zname <- names(x@z)[1] if (is.null(zname)) { zname <- 'z-value' } zclass <- class(z) # suggested by Michael Sumner if (inherits(z, "POSIXct")) { z <- format(z, "%Y-%m-%d %H:%M:%S", tz="UTC") } else { z <- as.character(z) } cat("zvalues=", paste(c(zname, z), collapse=':'), "\n", file = thefile, sep='') cat("zclass=", zclass, "\n", file = thefile, sep='') } a <- NULL try( a <- unlist(x@history), silent=TRUE ) if (!is.null(a)) { cat("history=", a, "\n", file = thefile, sep='') } a <- NULL try( a <- rapply(x@history, function(x) paste(as.character(x), collapse='#,#')), silent=TRUE ) if (!is.null(a)) { a <- gsub('\n', '#NL#', a) type <- rapply(x@history, class) type_value <- apply(cbind(type, a), 1, function(x) paste(x, collapse=':')) name_type_value <- apply(cbind(names(a), type_value), 1, function(x) paste(x, collapse='=')) name_type_value <- paste(name_type_value, '\n', sep='') cat("[metadata]", "\n", file = thefile, sep='') cat(name_type_value, file = thefile, sep='') } 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='') prj <- proj4string(x) prj[is.na(prj)] <- "" cat("projection=", prj, "\n", file = thefile, sep='') cat("wkt=", gsub("\\n", "", wkt(x)), "\n", file = thefile, sep='') close(thefile) return(TRUE) } raster/R/writeAllAscii.R0000644000176200001440000000205014507510157014634 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .writeAscii <- function(x, filename, datatype='FLT4S', prj=FALSE, ...) { v <- getValues(x) if (!is.finite( x@file@nodatavalue) ) { x@file@nodatavalue <- min(-9999, min(v, na.rm=TRUE)-1) } x <- .startAsciiWriting(x, filename, ...) datatype <- substr(datatype, 1, 3) if (datatype == 'INT') { on.exit(options(scipen=options('scipen'))) options(scipen=10) v <- round(v) } v[is.na(v)] <- x@file@nodatavalue if (datatype=='FLT') { # hack to make sure that ArcGIS does not # assume values are integers if the first # values have no decimal point v <- as.character(v) v[1] <- formatC(as.numeric(v[1]), 15, format='f') } v <- matrix(v, ncol=ncol(x), byrow=TRUE) utils::write.table(v, x@file@name, append = TRUE, quote = FALSE, sep = " ", eol = "\n", dec = ".", row.names = FALSE, col.names = FALSE) if (prj) { crs <- .getCRS(x) if (!is.na(crs)) { writeLines(wkt(x), extension(filename, 'prj') ) } } return( .stopAsciiWriting(x) ) } raster/R/writeRaster.R0000644000176200001440000001404114507510157014416 0ustar liggesusers# Author: Robert J. Hijmans # Date: September 2009 # Version 1.0 # Licence GPL v3 setMethod('writeRaster', signature(x='RasterLayer', filename='character'), function(x, filename, format, ...) { if (!hasValues(x)) { warning('all cell values are NA') } filename <- trim(filename) if (filename == '') { stop('provide a filename') } filename <- .fullFilename(filename, expand=TRUE) if (!file.exists(dirname(filename))) { stop("Attempting to write a file to a path that does not exist:\n ", dirname(filename)) } filetype <- .filetype(format=format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype == 'KML') { KML(x, filename, ...) return(invisible(x)) } verylarge <- ncell(x) > 1000000000 # to simplify we could treat all cases as !inMemory if ((!inMemory(x)) | verylarge ) { if ( toupper(x@file@name) == toupper(filename) ) { stop('filenames of source and target should be different') } tr <- blockSize(x) pb <- pbCreate(tr$n, ...) # use x to keep layer name r <- writeStart(x, filename=filename, format=filetype, sources=filename(x), ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } if (isTRUE(any(is.factor(x)))) { levels(r) <- levels(x) } #r <- setZ(r, getZ(x)) r <- writeStop(r) pbClose(pb) return(invisible(r)) } if (.isNativeDriver(filetype)) { out <- raster(x) names(out) <- names(x) try( out@history <- x@history, silent=TRUE) levels(out) <- levels(x) out@legend@colortable <- colortable(x) dots <- list(...) if (is.integer(x[1]) & is.null(dots$dataype)) { out <- .startRasterWriting(out, filename, format=filetype, dataytpe="INT4S", ...) } else { out <- .startRasterWriting(out, filename, format=filetype, ...) } out <- writeValues(out, x@data@values, 1) return( .stopRasterWriting(out) ) } else if (filetype=='ascii') { x <- .writeAscii(x, filename=filename,...) # } else if (filetype=='big.matrix') { # x <- .writeBigMatrix(x, filename=filename,...) } else if (filetype=='CDF') { x <- .startWriteCDF(x, filename=filename, ...) x <- .writeValuesCDF(x, x@data@values) return( .stopWriteCDF(x) ) } else { x <- .writeGDALall(x, filename=filename, format=filetype, sources=filename(x), ...) } 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') } if (inherits(x, "RasterStack")) { srcs <- sapply(x@layers, raster::filename) } else { srcs <- filename(x) } 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 <- sapply(filename, function(f) .getExtension(f, filetype)) } else { if (filename == '') { stop('provide a filename') } filename <- .fullFilename(filename, expand=TRUE) filetype <- .filetype(format, filename=filename) filename <- .getExtension(filename, filetype) ext <- extension(filename) filename <- extension(filename, '') if (suffix[1] == 'numbers') { filename <- paste(filename, '_', 1:nl, ext, sep='') } else if (suffix[1] == 'names') { filename <- paste(filename, '_', names(x), ext, sep='') } else if (length(suffix) == nl) { filename <- paste(filename, '_', suffix, ext, sep='') } else { stop('invalid "suffix" argument') } } if (filetype == 'KML') { layers <- lapply(1:nl, function(i) KML(x[[i]], filename=filename[i], ...)) return(invisible(x)) } if (inherits(x, 'RasterBrick')) { x <- stack(x) } layers <- lapply(1:nl, function(i) writeRaster(x[[i]], filename=filename[i], format=filetype, ...)) return(invisible(stack(layers))) } if (filename == '') { stop('provide a filename') } filename <- .fullFilename(filename, expand=TRUE) filetype <- .filetype(format, filename=filename) filename <- .getExtension(filename, filetype) if (filetype == "ascii") { stop('this file format does not support multi-layer files') } if (filetype == 'KML') { KML(x, filename, ...) return(invisible(x)) } verylarge <- (ncell(x) * nlayers(x)) > 1000000000 if (.isNativeDriver(filetype)) { if (! filetype %in% c("raster", "BIL", "BSQ", "BIP") ) { stop('this file format does not support multi-band files') } out <- brick(x, values=FALSE) names(out) <- names(x) z <- getZ(x) if (!is.null(z)) { out <- setZ(out, z) } out <- writeStart(out, filename, format=filetype, ...) if (inMemory(x) & (!verylarge)) { out <- writeValues(out, values(x), 1) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { out <- writeValues(out, getValues(x, tr$row[i], tr$nrows[i]), tr$row[i]) pbStep(pb, i) } pbClose(pb) } out <- .stopRasterWriting(out) return( invisible(out) ) } # else if ( inMemory(x) & (!verylarge)) { if (filetype=='CDF') { b <- brick(x, values=FALSE) b@z <- x@z b <- .startWriteCDF(b, filename=filename, ...) b <- .writeValuesBrickCDF(b, values(x)) x <- .stopWriteCDF(b) } else { x <- .writeGDALall(x, filename=filename, format=filetype, sources=srcs, ...) } return(invisible(x)) } else { if ( toupper(filename(x)) == toupper(filename) ) { stop('filenames of source and destination should be different') } b <- brick(x, values=FALSE) if (filetype=='CDF') { b@z <- x@z } tr <- blockSize(b) pb <- pbCreate(tr$n, ...) x <- readStart(x, ...) b <- writeStart(b, filename=filename, format=filetype, sources=srcs, ...) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) x <- readStop(x) pbClose(pb) return(invisible(b)) } } ) raster/R/nlayers.R0000644000176200001440000000135214507510157013561 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("nlayers")) { setGeneric("nlayers", function(x) standardGeneric("nlayers")) } setMethod('nlayers', signature(x='BasicRaster'), function(x){ return(0) } ) setMethod('nlayers', signature(x='Raster'), function(x){ return(1) } ) setMethod('nlayers', signature(x='RasterStack'), function(x){ as.integer( sum(unlist( sapply(x@layers, nlayers) ) ) ) } ) setMethod('nlayers', signature(x='RasterBrick'), function(x){ return(x@data@nlayers) } ) setMethod('nlayers', signature(x='Spatial'), function(x){ if (! is.null( attr(x, 'data') ) ) { return( dim(x@data)[2] ) } else { return( 0 ) } } ) raster/R/median.R0000644000176200001440000000330414507510157013340 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # revised: October 2011 # Version 1.0 # Licence GPL v3 setMethod(".median", signature(x='Raster'), function(x, na.rm=FALSE, ...){ dots <- list(...) if (length(dots) > 0) { x <- stack(.makeRasterList(x, ...)) add <- unlist(.addArgs(...)) } else { add <- NULL } out <- raster(x) d <- dim(x) nc <- ncell(out) if (is.null(add)) { if (nlayers(x) == 1) { return(.deepCopyRasterLayer(x)) } if (canProcessInMemory(x)) { x <- getValues(x) x <- setValues(out, apply(x, 1, median, na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='median') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- apply(v, 1, median, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } else { d3 <- d[3] + length(add) if (canProcessInMemory(x)) { if (length(add) == 1) { x <- cbind(getValues(x), add) } else { x <- getValues(x) x <- t(apply(x, 1, function(i) c(i, add))) } x <- setValues(out, apply(x, 1, median, na.rm=na.rm)) return(x) } tr <- blockSize(x) pb <- pbCreate(tr$n, label='median') out <- writeStart(out, filename="") x <- readStart(x, ...) for (i in 1:tr$n) { v <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) v <- t(apply(v, 1, function(i) c(i, add))) v <- apply(v, 1, median, na.rm=na.rm) out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } pbClose(pb) x <- readStop(x) return( writeStop(out) ) } } ) raster/R/transpose.R0000644000176200001440000000336314507510157014126 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2010 # Version 1.0 # Licence GPL v3 setMethod('t', signature(x='RasterLayer'), function(x) { r <- raster(x) e <- eold <- extent(r) e@xmin <- eold@ymin e@xmax <- eold@ymax e@ymin <- eold@xmin e@ymax <- eold@xmax extent(r) <- e dim(r) <- c(ncol(x), nrow(x)) if (! hasValues(x)) { return(r) } if (canProcessInMemory(x)) { return(setValues(r, t(as.matrix(x)))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValuesBlock(x, row=1, nrows=r@ncols, col=tr$row[i], ncols=tr$nrows[i]) v <- as.vector(matrix(v, ncol=tr$nrows[i], byrow=TRUE)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod('t', signature(x='RasterStackBrick'), function(x) { b <- brick(x, values=FALSE) e <- eold <- extent(b) e@xmin <- eold@ymin e@xmax <- eold@ymax e@ymin <- eold@xmin e@ymax <- eold@xmax extent(b) <- e dim(b) <- c(ncol(b), nrow(b), nlayers(b)) if (! hasValues(x)) { return(b) } if (canProcessInMemory(x)) { x <- as.array(x, transpose=TRUE) return( brick(x, xmn=xmin(b), xmx=xmax(b), ymn=ymin(b), ymx=ymax(b), crs=projection(b)) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n) b <- writeStart(b, filename=rasterTmpFile(), overwrite=TRUE ) for (i in 1:tr$n) { v <- getValuesBlock(x, row=1, nrows=b@ncols, col=tr$row[i], ncols=tr$nrows[i]) for (j in 1:ncol(v)) { v[,j] <- as.vector(matrix(v[,j], ncol=tr$nrows[i], byrow=TRUE)) } b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) pbClose(pb) return(b) } } ) raster/R/which.max.R0000644000176200001440000000421414507510157013772 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2013 # Version 1.0 # Licence GPL v3 setMethod("which.max", "RasterLayer", function(x) { m <- maxValue(x, warn=FALSE) if (is.na(m)) { return(NA) } if (canProcessInMemory(x)) { v <- values(x) return(which( v >= m)) } x <- x >= m - 0.00000001 pts <- rasterToPoints(x, function(y) y == 1) cellFromXY(x, pts[,1:2,drop=FALSE]) } ) setMethod("which.min", "RasterLayer", function(x) { m <- minValue(x, warn=FALSE) if (is.na(m)) { return(NA) } if (canProcessInMemory(x)) { v <- values(x) return(which( v <= m)) } xx <- x <= m + 0.000001 pts <- rasterToPoints(xx, function(y) y == 1) cellFromXY(xx, pts[,1:2,drop=FALSE]) } ) setMethod("which.min", "RasterStackBrick", function(x) { r <- raster(x) nl <- nlayers(x) if (canProcessInMemory(x)) { x <- values(x) i <- rowSums(is.na(x)) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, which.min) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) j <- rowSums(is.na(v)) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, which.min) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) setMethod("which.max", "RasterStackBrick", function(x) { r <- raster(x) nl <- nlayers(x) if (canProcessInMemory(x)) { x <- values(x) i <- rowSums(is.na(x)) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, which.max) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) j <- rowSums(is.na(v)) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, which.max) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) raster/R/multiCore.R0000644000176200001440000000436014507510157014051 0ustar liggesusers# Author: Matteo Mattiuzzi and Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 .recvOneData <- eval(parse(text="parallel:::recvOneData")) beginCluster <- function(n, type='SOCK', nice, exclude=NULL) { if (! requireNamespace("parallel") ) { stop('you need to install the "parallel" package') } if (exists('raster_Cluster_raster_Cluster', envir=.GlobalEnv)) { endCluster() } if (missing(n)) { n <- parallel::detectCores() message(n, ' cores detected, using ', n-1) n <- n-1 } # if (missing(type)) { # type <- getClusterOption("type") # message('cluster type:', type) # } cl <- parallel::makeCluster(n, type) cl <- .addPackages(cl, exclude=exclude) options(rasterClusterObject = cl) options(rasterClusterCores = length(cl)) options(rasterCluster = TRUE) options(rasterClusterExclude = exclude) if (!missing(nice)){ if (.Platform$OS.type == 'unix') { cmd <- paste("renice",nice,"-p") foo <- function() system(paste(cmd, Sys.getpid())) parallel::clusterCall(cl,foo) } else { warning("argument 'nice' only supported on UNIX like operating systems") } } } endCluster <- function() { options(rasterCluster = FALSE) cl <- options('rasterClusterObject')[[1]] if (! is.null(cl)) { parallel::stopCluster( cl ) options(rasterClusterObject = NULL) } } .doCluster <- function() { if ( isTRUE( getOption('rasterCluster')) ) { return(TRUE) } return(FALSE) } getCluster <- function() { cl <- getOption('rasterClusterObject') if (is.null(cl)) { stop('no cluster available, first use "beginCluster"') } cl <- .addPackages(cl, exclude=c('raster', 'sp', getOption('rasterClusterExclude'))) options( rasterClusterObject = cl ) options( rasterCluster = FALSE ) return(cl) } returnCluster <- function() { cl <- getOption('rasterClusterObject') if (is.null(cl)) { stop('no cluster available') } options( rasterCluster = TRUE ) } .addPackages <- function(cl, exclude=NULL) { pkgs <- .packages() i <- which( pkgs %in% c(exclude, "stats", "graphics", "grDevices", "utils", "datasets", "methods", "base") ) pkgs <- rev( pkgs[-i] ) for ( pk in pkgs ) { parallel::clusterCall(cl, library, pk, character.only=TRUE ) } return(cl) } raster/R/stretch.R0000644000176200001440000000565414507510157013571 0ustar liggesusers# author Josh Gray # http://spatiallyexplicit.wordpress.com/2011/06/07/crop-circles/ # minor modifications by Robert Hijmans # Note: these functions only work (correctly) for single layer objects .linStretchVec <- function (x) { v <- stats::quantile(x, c(0.02, 0.98), na.rm = TRUE) temp <- (255 * (x - v[1]))/(v[2] - v[1]) temp[temp < 0] <- 0 temp[temp > 255] <- 255 return(temp) } .linStretch <- function (x) { v <- stats::quantile(x, c(0.02, 0.98), na.rm = TRUE) temp <- calc(x, fun = function(x) (255 * (x - v[1]))/(v[2] - v[1])) temp[temp < 0] <- 0 temp[temp > 255] <- 255 return(temp) } # Histogram equalization stretch .eqStretch <- function(x){ ecdfun <- stats::ecdf(getValues(x)) return( calc(x, fun=function(x) ecdfun(x)*255) ) } .eqStretchVec <- function(x){ ecdfun <- stats::ecdf(x) ecdfun(x)*255 } setMethod("stretch", signature(x="Raster"), function(x, minv=0, maxv=255, minq=0, maxq=1, smin=NA, smax=NA, samplesize=1000000, filename="", ...) { if ((length(minq) > 1) | (length(maxq) > 1)) { minq <- minq[1] maxq <- maxq[1] } stopifnot(maxq > minq) if ((length(minv) > 1) | (length(maxv) > 1)) { warning("only the first element of minv and maxv is used") maxv <- maxv[1] minv <- minv[1] } stopifnot(maxv > minv) if (!any(is.na(smin)) & !(any(is.na(smax)))) { stopifnot(all(smin < smax)) q <- cbind(smin, smax) } else { minq <- max(0,minq) maxq <- min(1,maxq) stopifnot(minq < maxq) if ((minq==0 & maxq==1) & .haveMinMax(x)) { q <- cbind(minValue(x), maxValue(x)) } else { if (samplesize[1] < ncell(x)) { stopifnot(samplesize[1] > 1) y <- sampleRegular(x, samplesize, asRaster=TRUE) q <- quantile(y, c(minq, maxq), na.rm=TRUE) } else { q <- quantile(x, c(minq, maxq), na.rm=TRUE) } } } if (nlayers(x) == 1) { out <- raster(x) mult <- maxv / (q[2]-q[1]) if (canProcessInMemory(out)) { x <- getValues(x) x <- mult * (x-q[1]) x[x < minv] <- minv x[x > maxv] <- maxv out <- setValues(out, x) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='stretch', ...) out <- writeStart(out, filename, ...) for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- mult*(v-q[1]) v[v < minv] <- minv v[v > maxv] <- maxv out <- writeValues(out, v, tr$row[i]) } out <- writeStop(out) } } else { out <- brick(x, values=FALSE) mult <- maxv / (q[,2]-q[,1]) if (canProcessInMemory(out)) { x <- getValues(x) x <- t(mult*(t(x)-q[,1])) x[x < minv] <- minv x[x > maxv] <- maxv out <- setValues(out, x) } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='stretch', ...) out <- writeStart(out, filename, ...) for (i in 1:tr$n) { v <- getValues(x, tr$row[i], tr$nrows[i]) v <- t(mult*(t(v)-q[,1])) v[v < minv] <- minv v[v > maxv] <- maxv out <- writeValues(out, v, tr$row[i]) } out <- writeStop(out) } } return(out) } ) raster/R/geom.R0000644000176200001440000000543714507510157013043 0ustar liggesusers setMethod("geom", signature(x="SpatialPolygons"), function(x, sepNA=FALSE, ...) { nobs <- length(x@polygons) objlist <- list() cnt <- 0 if (sepNA) { sep <- rep(NA,5) for (i in 1:nobs) { nsubobs <- length(x@polygons[[i]]@Polygons) ps <- list() last <- 0 for (j in 1:nsubobs) { if (!x@polygons[[i]]@Polygons[[j]]@hole) { last <- last + 1 hole <- 0 } else { hole <- max(1, last) } ps[[j]] <- rbind(cbind(j, j+cnt, hole, x@polygons[[i]]@Polygons[[j]]@coords),sep) } objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobs } } else { for (i in 1:nobs) { nsubobs <- length(x@polygons[[i]]@Polygons) ps <- list() last <- 0 for (j in 1:nsubobs) { if (!x@polygons[[i]]@Polygons[[j]]@hole) { last <- last + 1 hole <- 0 } else { hole <- max(1, last) } ps[[j]] <- cbind(j, j+cnt, hole, x@polygons[[i]]@Polygons[[j]]@coords) } objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobs } } obs <- do.call(rbind, objlist) colnames(obs) <- c("object", "part", "cump", "hole", "x", "y") rownames(obs) <- NULL if (sepNA) { obs[is.na(obs[,2]), ] <- NA } return( obs ) } ) setMethod("geom", signature(x="SpatialLines"), function(x, sepNA=FALSE, ...) { nobs <- length(x@lines) objlist <- list() cnt <- 0 if (sepNA) { sep <- rep(NA, 4) for (i in 1:nobs) { nsubobj <- length(x@lines[[i]]@Lines) ps <- lapply(1:nsubobj, function(j) rbind(cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords), sep) ) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobj } } else { for (i in 1:nobs) { nsubobj <- length(x@lines[[i]]@Lines) ps <- lapply(1:nsubobj, function(j) cbind(j, j+cnt, x@lines[[i]]@Lines[[j]]@coords)) objlist[[i]] <- cbind(i, do.call(rbind, ps)) cnt <- cnt+nsubobj } } obs <- do.call(rbind, objlist) colnames(obs) <- c("object", "part", "cump", "x", "y") rownames(obs) <- NULL if (sepNA) { obs[is.na(obs[,2]), ] <- NA } return (obs) } ) setMethod("geom", signature(x="SpatialPoints"), function(x, ...) { xy <- sp::coordinates(x)[,1:2,drop=FALSE] xy <- cbind(1:nrow(xy), xy) colnames(xy) <- c("object", "x", "y") return(xy) } ) setMethod("geom", signature(x="data.frame"), function(x, d, gt, crs, ...) { if (gt == "polygons") { sp <- as(x, "SpatialPolygons") if (NROW(d) > 0) { sp <- sp::SpatialPolygonsDataFrame(sp, d) } } else if (gt == "lines") { sp <- as(x, "SpatialLines") if (NROW(d) > 0) { sp <- sp::SpatialLinesDataFrame(sp, d) } } else { sp <- sp::SpatialPoints(x[,c("x", "y")]) if (NROW(d) > 0) { sp <- sp::SpatialPointsDataFrame(sp, d) } } crs(sp)<- crs sp } ) raster/R/setMinMax.R0000644000176200001440000000500014507510157014003 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('setMinMax', signature(x='RasterLayer'), function(x, ...) { #w <- getOption('warn') #on.exit(options('warn' = w)) #options('warn'=-1) if ( inMemory(x) ) { suppressWarnings(x@data@min <- min(x@data@values, na.rm=TRUE)) suppressWarnings(x@data@max <- max(x@data@values, na.rm=TRUE)) } else { if (! fromDisk(x)) { stop('no values associated with this RasterLayer') } x@data@min <- Inf x@data@max <- -Inf tr <- blockSize(x) pb <- pbCreate(tr$n) x <- readStart(x) for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) x@data@min <- suppressWarnings(min(x@data@min, min(v, na.rm=TRUE))) x@data@max <- suppressWarnings(max(x@data@max, max(v, na.rm=TRUE))) } x <- readStop(x) } # if (datatype == 'logical') { # x@data@min <- as.logical(x@data@min) # x@data@max <- as.logical(x@data@max) # } x@data@haveminmax <- TRUE return(x) } ) setMethod('setMinMax', signature(x='RasterBrick'), function(x, ...) { inMem <- inMemory(x) if ( ! inMem ) { if (! fromDisk(x) ) { stop('no values associated with this RasterBrick') } } else if (canProcessInMemory(x, (2 + nlayers(x)))) { inMem <- TRUE } w <- getOption('warn') on.exit(options('warn' = w)) options('warn'=-1) if ( inMem ) { rge <- apply( getValues(x), 2, FUN=function(x){ c(min(x, na.rm=TRUE), max(x, na.rm=TRUE)) } ) x@data@min <- as.vector(rge[1,]) x@data@max <- as.vector(rge[2,]) } else { minv <- rep(Inf, nlayers(x)) maxv <- rep(-Inf, nlayers(x)) minmax <- rbind(minv, maxv) tr <- blockSize(x) x <- readStart(x) for (i in 1:tr$n) { rsd <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) minmax[1,] <- apply(rbind(rsd, minmax[1,]), 2, min, na.rm=TRUE) minmax[2,] <- apply(rbind(rsd, minmax[2,]), 2, max, na.rm=TRUE) } x@data@min <- minmax[1,] x@data@max <- minmax[2,] x <- readStop(x) } # if (datatype == 'logical') { # x@data@min <- as.logical(x@data@min) # x@data@max <- as.logical(x@data@max) # } x@data@haveminmax <- TRUE return(x) } ) setMethod('setMinMax', signature(x='RasterStack'), function(x, ...) { for (i in 1:nlayers(x)) { x@layers[[i]] <- setMinMax(x@layers[[i]]) } return(x) } ) .haveMinMax <- function(x) { if (inherits(x, "RasterLayer") || inherits(x, "RasterBrick")) { return(x@data@haveminmax) } else if (inherits(x, "RasterStack")) { return(all(sapply(x@layers, function(y) y@data@haveminmax))) } else { return(FALSE) } } raster/R/buffer.R0000644000176200001440000001054514507510157013361 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 .pointBuffer <- function(xy, d, lonlat=TRUE, a=6378137, f=1/298.257223563, crs="", ... ) { n <- list(...)$quadsegs if (is.null(n)) { n <- 360 } else { n <- n * 4 } if (length(d)==1) { d <- rep(d, nrow(xy)) } else if (length(d) != nrow(xy)) { # recycling dd <- vector(length=nrow(xy)) dd[] <- d d <- dd } n <- max(5, round(n)) brng <- 1:n * 360/n pols <- list() if (lonlat) { a = 6378137.0 f = 1/298.257223563 for (i in 1:nrow(xy)) { p <- cbind(xy[i,1], xy[i,2], brng, d[i]) #r <- .Call("geodesic", as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f), PACKAGE='raster') #pols[[i]] <- matrix(r, ncol=3, byrow=TRUE)[, 1:2] r <- .Call("_raster_dest_point", p, TRUE, a, f, PACKAGE='raster') pols[[i]] <- r[,1:2] } } else { brng <- brng * pi/180 for (i in 1:nrow(xy)) { x <- xy[i,1] + d[i] * cos(brng) y <- xy[i,2] + d[i] * sin(brng) pols[[i]] <- cbind(x, y) } } sp <- do.call(spPolygons, pols) crs(sp) <- crs sp } setMethod('buffer', signature(x='Spatial'), function(x, width=1, dissolve=TRUE, ...) { # warning("this method will be removed. You can use 'terra::buffer' instead") if (is.na(projection(x))) { if (.couldBeLonLat(x)) { crs(x) <- "+proj=lonlat" } else { crs(x) <- "+proj=utm +zone=1" } } x <- vect(x) b <- buffer(x, width) if (dissolve) { b <- aggregate(b) } return(as(b, "Spatial")) # if (inherits(x, 'SpatialPoints')) { # if (.couldBeLonLat(x)) { # if (!isLonLat(x)) { # warning('crs unknown, assuming lonlat') # } # lonlat=TRUE # } else { # lonlat = FALSE # } # pb <- .pointBuffer(xy=sp::coordinates(x)[,1:2,drop=FALSE], d=width, lonlat=lonlat, crs=crs(x), ...) # if (dissolve) { # pb <- aggregate(pb) # } else if (.hasSlot(x, 'data')) { # pb <- sp::SpatialPolygonsDataFrame(pb, x@data, match.ID=FALSE) # } # return(pb) # } # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # prj <- x@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # x <- rgeos::gBuffer(x, byid=!dissolve, width=width, ...) # x@proj4string <- prj # x } ) setMethod('buffer', signature(x='RasterLayer'), function(x, width=0, filename='', doEdge=FALSE, ...) { stopifnot(width > 0) if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (inherits(pts, "try-error")) { d <- .distanceRows(x, filename=filename, ...) d <- reclassify(d, rbind(c(-1,width, 1), c(width, Inf, NA))) return(d) } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells for which to compute a distance') } out <- raster(x) filename <- trim(filename) if (couldBeLonLat(x)) { longlat=TRUE } else { longlat=FALSE } if (canProcessInMemory(out, 6)) { pb <- pbCreate(4, label='buffer', ...) v <- values(x) i <- is.na(v) if (!any(i)) { stop('raster has no NA values to compute distance to') } pbStep(pb) xy <- xyFromCell(out, which(i)) vals <- .Call('_raster_distanceToNearestPoint', xy, pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') pbStep(pb) v[!i] <- 1 v[i] <- NA^(vals > width) out <- setValues(out, v) pbStep(pb) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } pbStep(pb) pbClose(pb) return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='buffer', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- 0 if (length(j) > 0) { vals[j] <- .Call('_raster_distanceToNearestPoint', xy[j,,drop=FALSE], pts, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') } vals[vals > width] <- NA vals[!is.na(vals)] <- 1 out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) raster/R/hdrBIL.R0000644000176200001440000000430614507510157013212 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrBIL <- function(x, layout='BIL') { hdrfile <- x@file@name extension(hdrfile) <- '.hdr' thefile <- file(hdrfile, "w") # open an txt file connectionis cat("NROWS ", x@nrows, "\n", file = thefile) cat("NCOLS ", x@ncols, "\n", file = thefile) cat("NBANDS ", nlayers(x), "\n", file = thefile) cat("NBITS ", dataSize(x@file@datanotation) * 8, "\n", file = thefile) btorder <- ifelse(x@file@byteorder == "little", "I", "M") cat("BYTEORDER ", btorder, "\n", file = thefile) # PIXELTYPE should work for Gdal, and perhpas ArcGIS, see: # http://lists.osgeo.org/pipermail/gdal-dev/2006-October/010416.html dtype <- .shortDataType(x@file@datanotation) if (dtype == 'INT' | dtype == 'LOG' ) { pixtype <- ifelse(dataSigned(x@file@datanotation), "SIGNEDINT", "UNSIGNEDINT") } else { pixtype <- "FLOAT" } cat("PIXELTYPE ", pixtype, "\n", file = thefile) cat("LAYOUT ", layout, "\n", file = thefile) cat("SKIPBYTES 0\n", file = thefile) cat("ULXMAP ", as.character(xmin(x) + 0.5 * xres(x)), "\n", file = thefile) cat("ULYMAP ", as.character(ymax(x) - 0.5 * yres(x)), "\n", file = thefile) cat("XDIM ", xres(x), "\n", file = thefile) cat("YDIM ", yres(x), "\n", file = thefile) browbytes <- round(ncol(x) * dataSize(x@file@datanotation) ) cat("BANDROWBYTES ", browbytes, "\n", file = thefile) cat("TOTALROWBYTES ", browbytes * nbands(x), "\n", file = thefile) cat("BANDGAPBYTES 0\n", file = thefile) cat("NODATA ", .nodatavalue(x), "\n", file = thefile) cat("\n\n", file = thefile) cat("The below is additional metadata, not part of the BIL/HDR format\n", file = thefile) cat("----------------------------------------------------------------\n", file = thefile) cat("CREATOR=R package:x\n", file = thefile) cat("CREATED=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), "\n", file = thefile) cat("Projection=", proj4string(x), "\n", file = thefile) cat("MinValue=", minValue(x), "\n", file = thefile) cat("MaxValue=", maxValue(x), "\n", file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/writeValues.R0000644000176200001440000001261214507510157014417 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 1.0 # Licence GPL v3 setMethod("writeValues", signature(x="RasterLayer", v="vector"), function(x, v, start, ...) { v[is.infinite(v)] <- NA datanotation <- x@file@datanotation if (substr(datanotation,1,1) != "F") { v <- round(v) size <- substr(datanotation,4,4) if (substr(datanotation, 1, 3) == "LOG") { v[v != 1] <- 0 } else if (substr(datanotation, 5, 5) == "U") { v[v < 0] <- NA if (size == "1") { v[v > 255] <- NA } else if (size == "2") { v[v > 65535] <- NA } else { v[v > 4294967295] <- NA } } else { if (size == "1") { v[v < -128] <- NA v[v > 127] <- NA } else if (size == "2") { v[v < -32768] <- NA v[v > 32767] <- NA } else { v[v < -2147483648] <- NA v[v > 2147483647] <- NA } } } rsd <- stats::na.omit(v) # min and max values if (length(rsd) > 0) { x@data@min <- min(x@data@min, rsd) x@data@max <- max(x@data@max, rsd) } driver <- x@file@driver if ( driver == "gdal" ) { r <- attr(x@file, "transient") writeValues(r, v, start, length(v) / ncol(x)) # off <- c(start-1, 0) # v[is.na(v)] <- x@file@nodatavalue # v <- matrix(v, nrow=x@ncols) # gd <- rgdal::putRasterData(x@file@transient, v, band=1, offset=off) } else if ( driver %in% .nativeDrivers() ) { if (x@file@dtype == "FLT" ) { # v may be integers, while the filetype is FLT v <- as.numeric( v ) if (driver != "raster") { v[is.na(v)] <- x@file@nodatavalue } } else { v[is.na(v)] <- as.integer(x@file@nodatavalue) v <- as.integer(v) } start <- (start-1) * x@ncols * x@file@dsize seek(x@file@con, start, rw="w") # print(v) writeBin(v, x@file@con, size=x@file@dsize ) } else if ( driver == "netcdf") { x <- .writeValuesCDF(x, v, start) # } else if ( driver == "big.matrix") { # # b <- attr(x@file, "big.matrix") # nrows <- length(v) / ncol(x) # # b[rowColFromCell(x, start:(start+length(v)-1))] <- v # b[start:(start+nrows-1), ] <- matrix(v, nrow=nrows, byrow=TRUE) } else if ( driver == "ascii") { opsci = options("scipen") if (x@file@dtype == "INT") { options(scipen=10) v <- round(v) } v[is.na(v)] <- x@file@nodatavalue if (x@file@dtype == "FLT") { # hack to make sure that ArcGIS does not # assume values are integers if the first # values have no decimal point v <- as.character(v) v[1] <- formatC(as.numeric(v[1]), 15, format="f") } v <- matrix(v, ncol=ncol(x), byrow=TRUE) utils::write.table(v, x@file@name, append = TRUE, quote = FALSE, sep = " ", eol = "\n", dec = ".", row.names = FALSE, col.names = FALSE) options(scipen=opsci) } else { stop("was writeStart used?") } return(x) } ) setMethod("writeValues", signature(x="RasterBrick", v="matrix"), function(x, v, start, ...) { v[is.infinite(v)] <- NA if (is.logical(v)) { v[] <- as.integer(v) } w <- getOption("warn") options("warn"=-1) rng <- apply(v, 2, range, na.rm=TRUE) x@data@min <- pmin(x@data@min, rng[1,]) x@data@max <- pmax(x@data@max, rng[2,]) options("warn"= w) driver <- x@file@driver if ( driver %in% .nativeDrivers() ) { #if (!is.matrix(v)) v <- matrix(v, ncol=1) if (x@file@dtype == "INT") { v[is.na(v)] <- x@file@nodatavalue dm <- dim(v) v <- as.integer(round(v)) dim(v) <- dm } else if ( x@file@dtype =="LOG" ) { v[v != 1] <- 0 v[is.na(v)] <- x@file@nodatavalue dm <- dim(v) v <- as.integer(round(v)) dim(v) <- dm } else { # if (!is.numeric(v)) { v[] <- as.numeric( v ) } if (x@file@bandorder=="BIL") { start <- (start-1) * x@ncols * x@file@dsize * nlayers(x) seek(x@file@con, start, rw="w") loop <- nrow(v) / x@ncols start <- 1 for (i in 1:loop) { end <- start + x@ncols - 1 writeBin(as.vector(v[start:end,]), x@file@con, size=x@file@dsize ) start <- end + 1 } } else if (x@file@bandorder=="BIP") { start <- (start-1) * x@ncols * x@file@dsize * nlayers(x) seek(x@file@con, start, rw="w") writeBin(as.vector(t(v)), x@file@con, size=x@file@dsize ) } else if (x@file@bandorder=="BSQ") { start <- (start-1) * x@ncols * x@file@dsize nc <- ncell(x) * x@file@dsize for (i in 1:ncol(v)) { pos <- start + nc * (i-1) seek(x@file@con, pos, rw="w") writeBin(v[,i], x@file@con, size=x@file@dsize ) } } else { stop("unknown band order") } } else if ( driver == "netcdf") { x <- .writeValuesBrickCDF(x, v, start) } else if ( driver == "big.matrix") { b <- attr(x@file, "big.matrix") startcell <- cellFromRowCol(x, start, 1) endcell <- startcell+nrow(v)-1 b[startcell:endcell, ] <- v } else { # rgdal #off <- c(start-1, 0) #if (x@file@datanotation == "INT1U") { # v[v < 0] <- NA #} #v[is.na(v)] <- x@file@nodatavalue #for (i in 1:nlayers(x)) { # vv <- matrix(v[,i], nrow=ncol(x)) # gd <- rgdal::putRasterData(x@file@transient, vv, band=i, offset=off) #} r <- attr(x@file, "transient") writeValues(r, as.vector(v), start=start, nrows=nrow(v)/ncol(x)) } return(x) } ) .getTransientRows <- function(x, r, n=1) { stop() # reg = c(n, ncol(x)) # off = c(r-1,0) # as.vector((rgdal::getRasterData(x@file@transient, region.dim=reg, offset=off))) } raster/R/arith.R0000644000176200001440000002160014507510157013211 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setMethod("Arith", signature(e1='Raster', e2='missing'), function(e1, e2){ methods::callGeneric(0, e1) } ) setMethod("Arith", signature(e1='Raster', e2='Raster'), function(e1, e2){ if (!hasValues(e1)) { stop('first Raster object has no values') } if (!hasValues(e2)) { stop('second Raster object has no values') } nl1 <- nlayers(e1) nl2 <- nlayers(e2) nl <- max(nl1, nl2) proj1 <-.getCRS(e1) proj2 <-.getCRS(e2) if ( ! compareRaster(e1, e2, crs=FALSE, stopiffalse=FALSE) ) { if ( compareRaster(e1, e2, extent=FALSE, rowcol=FALSE, crs=TRUE, res=TRUE, orig=TRUE, stopiffalse=TRUE) ) { ie <- intersect(extent(e1), extent(e2)) if (is.null(ie)) { stop() } warning('Raster objects have different extents. Result for their intersection is returned') e1 <- crop(e1, ie) e2 <- crop(e2, ie) } else { stop() # stops anyway because compareRaster returned FALSE } } if (nl > 1) { r <- brick(e1, values=FALSE, nl=nl) } else { r <- raster(e1) } if (canProcessInMemory(r, 4 * nlayers(e2))) { if (nl1 == nl2 ) { return( setValues(r, values=methods::callGeneric( getValues(e1), getValues(e2))) ) } else { return( setValues(r, matrix(methods::callGeneric( as.vector(getValues(e1)), as.vector(getValues(e2))), ncol=nl)) ) } } else { tr <- blockSize(e1) pb <- pbCreate(tr$n, label='arith') e1 <- readStart(e1) e2 <- readStart(e2) r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) if (nl1 == nl2 ) { for (i in 1:tr$n) { v1 <- getValues(e1, row=tr$row[i], nrows=tr$nrows[i]) v2 <- getValues(e2, row=tr$row[i], nrows=tr$nrows[i]) v <- methods::callGeneric( v1, v2 ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v1 <- as.vector(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])) v2 <- as.vector(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) v <- matrix(methods::callGeneric( v1, v2 ), ncol=nl) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e1 <- readStop(e1) e2 <- readStop(e2) pbClose(pb) return(r) } } ) setMethod("Arith", signature(e1='RasterLayer', e2='numeric'), function(e1, e2){ if (!hasValues(e1)) { stop('RasterLayer has no values') } r <- raster(e1) names(r) <- names(e1) if (canProcessInMemory(e1, 4)) { if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } return ( setValues(r, methods::callGeneric(as.numeric(getValues(e1)), e2) ) ) } else { tr <- blockSize(e1) pb <- pbCreate(tr$n, label='arith') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) e1 <- readStart(e1) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2 ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e1 <- readStop(e1) pbClose(pb) return(r) } } ) setMethod("Arith", signature(e1='numeric', e2='RasterLayer'), function(e1, e2){ stopifnot(hasValues(e2)) r <- raster(e2) names(r) <- names(e2) if (canProcessInMemory(e2, 4)) { if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } return ( setValues(r, methods::callGeneric(e1, getValues(e2)) ) ) } else { tr <- blockSize(e2) pb <- pbCreate(tr$n, label='arith') r <- writeStart(r, filename=rasterTmpFile(), overwrite=TRUE ) e2 <- readStart(e2) if (length(e1) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- methods::callGeneric(e, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) e2 <- readStop(e2) pbClose(pb) return(r) } } ) setMethod("Arith", signature(e1='RasterLayer', e2='logical'), function(e1, e2){ e2 <- as.integer(e2) methods::callGeneric(e1, e2) } ) setMethod("Arith", signature(e1='logical', e2='RasterLayer'), function(e1, e2){ e1 <- as.integer(e1) methods::callGeneric(e1, e2) } ) setMethod("Arith", signature(e1='RasterStackBrick', e2='numeric'), function(e1, e2) { if (length(e2) > 1) { nl <- nlayers(e1) if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } b <- brick(e1, values=FALSE) names(b) <- names(e1) if (canProcessInMemory(e1, 4)) { return( setValues(b, t(methods::callGeneric( t(getValues(e1)), e2))) ) } tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile(), bandorder='BIL') e1 <- readStart(e1) for (i in 1:tr$n) { v <- t (methods::callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2) ) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e1 <- readStop(e1) pbClose(pb) return(b) } # else: b <- brick(e1, values=FALSE) names(b) <- names(e1) if (canProcessInMemory(e1, 4)) { return ( setValues(b, methods::callGeneric(getValues(e1), e2) ) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile()) e1 <- readStart(e1) for (i in 1:tr$n) { v <- methods::callGeneric( getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e1 <- readStop(e1) pbClose(pb) return(b) } } ) setMethod("Arith", signature(e1='numeric', e2='RasterStackBrick'), function(e1, e2) { if (length(e1) > 1) { nl <- nlayers(e2) if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } b <- brick(e2, values=FALSE) names(b) <- names(e2) if (canProcessInMemory(e2, 4)) { return( setValues(b, t(methods::callGeneric( e1, t(getValues(e2))))) ) } tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') e2 <- readStart(e2) b <- writeStart(b, filename=rasterTmpFile()) for (i in 1:tr$n) { v <- t (methods::callGeneric( e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) ) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e2 <- readStop(e2) pbClose(pb) return(b) } # else: b <- brick(e2, values=FALSE) names(b) <- names(e2) if (canProcessInMemory(e2, 4)) { return ( setValues(b, methods::callGeneric(e1, getValues(e2)) ) ) } else { tr <- blockSize(b) pb <- pbCreate(tr$n, label='arith') b <- writeStart(b, filename=rasterTmpFile()) e2 <- readStart(e2) for (i in 1:tr$n) { v <- methods::callGeneric( e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) b <- writeValues(b, v, tr$row[i]) pbStep(pb, i) } b <- writeStop(b) e2 <- readStop(e2) pbClose(pb) return(b) } } ) setMethod("Arith", signature(e1='RasterStackBrick', e2='logical'), # for Arith with NA function(e1, e2){ e2 <- as.integer(e2) methods::callGeneric(e1, e2) } ) setMethod("Arith", signature(e1='logical', e2='RasterStackBrick'), function(e1, e2){ e1 <- as.integer(e1) methods::callGeneric(e1, e2) } ) .getE2 <- function(e2) { n <- length(e2) if (n == 1) { e2 <- rep(e2, 4) } else if (n == 2) { e2 <- rep(e2, each=2) } else if (n != 4) { stop('use 1, 2, or 4 numbers in arithmetic operations with an Extent') } e2 } .multiply_Extent <- function(e1, e2) { e2 <- abs(e2) if (length(e2) == 4) { return(extent(as.vector(e1) * e2)) } e2 <- rep_len(e2, length.out=2) rx <- e1@xmax - e1@xmin ry <- e1@ymax - e1@ymin dx <- (rx * e2[1] - rx) / 2 dy <- (ry * e2[2] - ry) / 2 e1@xmax <- e1@xmax + dx e1@xmin <- e1@xmin - dx e1@ymax <- e1@ymax + dy e1@ymin <- e1@ymin - dy return(e1) } .add_Extent <- function(e1, e2, g) { if (length(e2) == 4) { return(extent(as.vector(e1) + e2)) } e2 <- rep_len(e2, length.out=2) dx <- e2[1] / 2 dy <- e2[2] / 2 e1@xmax <- e1@xmax + dx e1@xmin <- e1@xmin - dx e1@ymax <- e1@ymax + dy e1@ymin <- e1@ymin - dy return(e1) } setMethod("Arith", signature(e1='Extent', e2='numeric'), function(e1, e2){ g <- as.vector(.Generic) if (g %in% c("/", "*")) { if (g == '/') { e2 <- 1 / e2 } return( .multiply_Extent(e1, e2) ) } else if (g %in% c("+", "-")) { if (g == '-') { e2 <- -1 * e2 } return( .add_Extent(e1, e2) ) } extent(methods::callGeneric(as.vector(e1), .getE2(e2))) } ) setMethod("Arith", signature(e1='numeric', e2='Extent'), function(e1, e2){ methods::callGeneric(e2,e1) } ) raster/R/interpolate.R0000644000176200001440000001153514507510157014436 0ustar liggesusers # to do: should allow index to be a vector setMethod('interpolate', signature(object='Raster'), function(object, model, filename="", fun=predict, xyOnly=TRUE, xyNames=c('x','y'), ext=NULL, const=NULL, index=1, na.rm=TRUE, debug.level=1, ...) { predrast <- raster(object) filename <- trim(filename) ln <- NULL if (!is.null(ext)) { predrast <- crop(predrast, extent(ext)) firstrow <- rowFromY(object, yFromRow(predrast, 1)) firstcol <- colFromX(object, xFromCol(predrast, 1)) } else { firstrow <- 1 firstcol <- 1 } ncols <- ncol(predrast) lyrnames <- names(object) haveFactor <- FALSE dataclasses <- try( attr(model$terms, "dataClasses")[-1], silent=TRUE) if (!is.null(dataclasses)) { varnames <- names(dataclasses) if (! inherits(dataclasses, "try-error")) { if ( length( unique(lyrnames[(lyrnames %in% varnames)] )) != length(lyrnames[(lyrnames %in% varnames)] )) { stop('duplicate names in Raster* object: ', lyrnames) } f <- names( which(dataclasses == 'factor') ) if (length(f) > 0) { haveFactor <- TRUE } } } if (!canProcessInMemory(predrast) && filename == '') { filename <- rasterTmpFile() } if (! xyOnly) { if (inherits(object, 'RasterStack')) { if (nlayers(object)==0) { warning('"object" has no data, xyOnly set to TRUE') xyOnly <- TRUE } } else { if ( ! fromDisk(object) ) { if (! inMemory(object) ) { warning('"object" has no data, xyOnly set to TRUE') xyOnly <- TRUE } } } } if (xyOnly) { na.rm <- FALSE } if (inherits(model, "gstat")) { gstatmod <- TRUE if (!is.null(model$locations) && inherits(model$locations, "formula")) { # should be ~x + y ; need to check if it is ~lon + lat; or worse ~y+x sp <- FALSE } else { sp <- TRUE } } else { gstatmod <- FALSE } tr <- blockSize(predrast, n=nlayers(object)+3) ablock <- 1:(ncol(predrast) * tr$nrows[1]) napred <- rep(NA, ncol(predrast)*tr$nrows[1]) pb <- pbCreate(tr$n, label='interpolate', ... ) if (filename == '') { v <- matrix(NA, ncol=nrow(predrast), nrow=ncol(predrast)) } else { predrast <- writeStart(predrast, filename=filename, ... ) } for (i in 1:tr$n) { if (i==tr$n) { ablock <- 1:(ncol(predrast) * tr$nrows[i]) napred <- rep(NA, ncol(predrast) * tr$nrows[i]) } rr <- firstrow + tr$row[i] - 1 if (xyOnly) { p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) p <- stats::na.omit(p) blockvals <- data.frame(x=p[,1], y=p[,2]) } else { blockvals <- data.frame(getValuesBlock(object, row=rr, nrows=tr$nrows[i], firstcol, ncols)) colnames(blockvals) <- lyrnames # necessary if there is only one layer p <- xyFromCell(predrast, ablock + (tr$row[i]-1) * ncol(predrast)) blockvals <- cbind(data.frame( x=p[,1], y=p[,2]), blockvals) } if (!is.null(const)) { blockvals <- cbind(blockvals, const) } if (haveFactor) { for (j in 1:length(f)) { blockvals[,f[j]] <- as.factor(blockvals[,f[j]]) } } colnames(blockvals)[1:2] <- xyNames[1:2] if (gstatmod) { if (sp) { row.names(p) <- 1:nrow(p) blockvals <- sp::SpatialPointsDataFrame(coords=p, data = blockvals, proj4string=.getCRS((predrast))) } if (i == 1) { predv <- predict(model, blockvals, debug.level=debug.level, ...) ln <- names(predv)[index] } else { predv <- predict(model, blockvals, debug.level=0, ...) } if (sp) { predv <- predv@data[,index] } else { predv <- predv[,index+2] } } else { if (na.rm) { blockvals <- stats::na.omit(blockvals) } if (nrow(blockvals) == 0 ) { predv <- napred } else { predv <- fun(model, blockvals, ...) } if (inherits(predv, 'list')) { predv <- unlist(predv, use.names = FALSE) if (length(predv) != nrow(blockvals)) { predv <- matrix(predv, nrow=nrow(blockvals)) } } if (isTRUE(dim(predv)[2] > 1)) { predv = predv[,index] } if (na.rm) { naind <- as.vector(attr(blockvals, "na.action")) if (!is.null(naind)) { p <- napred p[-naind] <- predv predv <- p rm(p) } } # to change factor to numeric; should keep track of this to return a factor type RasterLayer predv <- as.numeric(predv) } if (filename == '') { predv = matrix(predv, nrow=ncol(predrast)) cols = tr$row[i]:(tr$row[i]+dim(predv)[2]-1) v[,cols] <- predv } else { predrast <- writeValues(predrast, predv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (gstatmod) { names(predrast) <- ln } if (filename == '') { predrast <- setValues(predrast, as.numeric(v)) # or as.vector } else { predrast <- writeStop(predrast) } return(predrast) } ) raster/R/nsidcICE.R0000644000176200001440000000402714507510157013527 0ustar liggesusers.rasterFromNSIDCFile <- function(x) { ## check name structure ## "nt_19781119_f07_v01_s.bin" bx <- basename(x) ## test that we can get a date from this ## (as POSIXct so that Z-comparisons are more natural) dts <- as.POSIXct(basename(x), format = "nt_%Y%m%d", tz = "UTC") ## test that we see _f and _v fyes <- tolower(substr(bx, 13L, 13L)) %in% c("f", "n") vyes <- tolower(substr(bx, 17L, 17L)) %in% c("v", "n") ## finally, it's north or south hemi <- tolower(substr(bx, 21L, 21L)) hyes <- hemi %in% c("s", "n") if(!(!is.na(dts) & fyes & vyes & hyes)) return(NULL) ## NSIDC projection and grid size ## https://nsidc.org/data/polar_stereo/ps_grids.html ## http://spatialreference.org/ref/?search=nsidc ## Hughes 1980 ellipsoid, True Scale Lat is +/-70 if (hemi == "s") { prj <- "+proj=stere +lat_0=-90 +lat_ts=-70 +lon_0=0 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs" dims <- c(316L, 332L) ext <- c(-3950000, 3950000, -3950000, 4350000) } else { ## northern hemisphere prj <- "+proj=stere +lat_0=90 +lat_ts=70 +lon_0=-45 +k=1 +x_0=0 +y_0=0 +a=6378273 +b=6356889.449 +units=m +no_defs" dims <- c(304, 448) ext <- c(-3837500, 3762500, -5362500, 5837500) } on.exit(close(con)) con <- file(x, open = "rb") ## chuck the header try1 <- try(trash <- readBin(con, "integer", size = 1, n = 300)) ## TODO: warnings that we thought it was NSIDC, but it did not work? if (inherits(try1, "try-error")) return(NULL) dat <- try(readBin(con, "integer", size = 1, n = prod(dims), endian = "little", signed = FALSE)) if (inherits(dat, "try-error")) return(NULL) r100 <- dat > 250 r0 <- dat < 1 ## if (rescale) { dat <- dat/2.5 ## rescale back to 100 ## } ## if (setNA) { dat[r100] <- NA ## dat[r0] <- NA ## } r <- raster(t(matrix(dat, dims[1])), xmn=ext[1], xmx=ext[2], ymn=ext[3], ymx=ext[4], crs=prj) setZ(r, dts, name = "time") } raster/R/addLayer.R0000644000176200001440000000224014507510157013626 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 if (!isGeneric("addLayer")) { setGeneric("addLayer", function(x, ...) standardGeneric("addLayer")) } setMethod('addLayer', signature(x='Raster'), function(x, ...) { rasters <- .makeRasterList(...) if (! inherits(x, 'RasterStack')) { x <- stack(x) } if (length(rasters)==0) { return(x) } if (nlayers(x) > 0) { compareRaster(c(x, rasters)) } else if (length(rasters) > 1) { compareRaster(rasters) } vals <- sapply(rasters, hasValues) if (sum(vals) == 0 & nlayers(x) == 0) { vals[1] <- TRUE } if (sum(vals) != length(vals)) { warning('Cannot add a RasterLayer with no associated data in memory or on disk to a RasterStack') } rasters <- rasters[vals] if (nlayers(x) == 0) { r <- rasters[[1]] x@nrows <- r@nrows x@ncols <- r@ncols x@extent <- r@extent crs(x) <- .getCRS(r) if (rotated(r)) { x@rotated = r@rotated x@rotation = r@rotation } nl <- 1 x@layers[[nl]] <- r rasters <- rasters[-1] if (length(rasters)==0) { return(x) } } x@layers <- c(x@layers, rasters) names(x) <- sapply(x@layers, names) return(x) } ) raster/R/brick.R0000644000176200001440000001531114507510157013176 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('brick', signature(x='missing'), function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, nl=1, crs) { e <- extent(xmn, xmx, ymn, ymx) if (missing(crs)) { if (e@xmin > -400 & e@xmax < 400 & e@ymin > -90.1 & e@ymax < 90.1) { crs ="+proj=longlat +datum=WGS84" } else { crs="" } } b <- brick(e, nrows=nrows, ncols=ncols, crs=crs, nl=nl) return(b) } ) setMethod('brick', signature(x='character'), function(x, ...) { .rasterObjectFromFile(x, objecttype='RasterBrick', ...) } ) setMethod('brick', signature(x='RasterLayer'), function(x, ..., values=TRUE, nl=1, filename='') { nl <- max(round(nl), 0) if (!hasValues(x)) { values <- FALSE } if (!values) { if (.hasSlot(x, "srs")) { prj <- x@srs } else { prj <- x@crs } b <- brick(x@extent, nrows=nrow(x), ncols=ncol(x), crs=prj, nl=nl) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } return(b) } filename <- trim(filename) dots <- list(...) fformat <- dots$format if (is.null(fformat)) { fformat <- .filetype(filename=filename) } datatype <- dots$datatype if (is.null(datatype)) { datatype <- .datatype() } overwrite <- dots$overwrite if (is.null(overwrite)) { overwrite <- .overwrite() } progress <- dots$progress if (is.null(progress)) { progress <- .progress() } x <- stack(x, ...) brick(x, values=values, filename=filename, format=fformat, datatype=datatype, overwrite=overwrite, progress=progress) } ) setMethod('brick', signature(x='RasterStack'), function(x, values=TRUE, nl, filename='', ...){ e <- x@extent if (.hasSlot(x, "srs")) { prj <- x@srs } else { prj <- x@crs } b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=prj) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } if (missing(nl)) { nl <- nlayers(x) if (nl < 1) { values <- FALSE } } else { nl <- max(round(nl), 0) values <- FALSE } b@data@nlayers <- as.integer(nl) filename <- trim(filename) if (values) { b@data@names <- names(x)[1:nl] if (canProcessInMemory(b, nl*2)) { b <- setValues( b, getValues(x)[,1:nl]) if (any(is.factor(x))) { b@data@isfactor <- is.factor(x) b@data@attributes <- levels(x) } if (filename != '') { b <- writeRaster(b, filename, ...) } return(b) } else { b <- writeStart(b, filename=filename, ...) tr <- blockSize(b) pb <- pbCreate(tr$n, ...) x <- readStart(x) for (i in 1:tr$n) { vv <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, vv, tr$row[i]) pbStep(pb, i) } pbClose(pb) b <- writeStop(b) x <- readStop(x) return(b) } } else { b@data@min <- rep(Inf, b@data@nlayers) b@data@max <- rep(-Inf, b@data@nlayers) return(b) } } ) setMethod('brick', signature(x='RasterBrick'), function(x, nl, ...){ if (missing(nl)) { nl <- nlayers(x) } e <- x@extent if (.hasSlot(x, "srs")) { prj <- x@srs } else { prj <- x@crs } b <- brick(xmn=e@xmin, xmx=e@xmax, ymn=e@ymin, ymx=e@ymax, nrows=x@nrows, ncols=x@ncols, crs=prj) b@data@nlayers <- as.integer(nl) b@data@min <- rep(Inf, nl) b@data@max <- rep(-Inf, nl) if (rotated(x)) { b@rotated <- TRUE b@rotation <- x@rotation } return(b) } ) setMethod('brick', signature(x='Extent'), function(x, nrows=10, ncols=10, crs="", nl=1) { nr = as.integer(round(nrows)) nc = as.integer(round(ncols)) if (nc < 1) { stop("ncols should be > 0") } if (nr < 1) { stop("nrows should be > 0") } b <- methods::new("RasterBrick", extent=x, ncols=nc, nrows=nr) #prj <- sp::CRS(as.character(NA), doCheckCRSArgs=FALSE) #try(prj <- .getCRS(crs)) #projection(b) <- prj projection(b) <- crs nl <- max(round(nl), 0) b@data@nlayers <- as.integer(nl) b@data@isfactor <- rep(FALSE, nl) return(b) } ) setMethod('brick', signature(x='SpatialGrid'), function(x){ b <- brick() extent(b) <- extent(x) crs(b) <- x@proj4string dim(b) <- c(x@grid@cells.dim[2], x@grid@cells.dim[1]) if (inherits(x, 'SpatialGridDataFrame')) { x <- x@data b@data@isfactor <- rep(FALSE, ncol(x)) isfact <- sapply(x, function(i) is.factor(i) | is.character(i)) b@data@isfactor <- isfact if (any(isfact)) { for (i in which(isfact)) { rat <- data.frame(table(x[[i]])) rat <- data.frame(1:nrow(rat), rat[,2], rat[,1]) colnames(rat) <- c("ID", "COUNT", colnames(x)[i]) b@data@attributes[[i]] <- rat x[,i] <- as.integer(x[,i]) } } b <- setValues(b, as.matrix(x)) b@data@names <- colnames(x) } return(b) } ) setMethod('brick', signature(x='SpatialPixels'), function(x) { if (inherits( x, 'SpatialPixelsDataFrame')) { x <- as(x, 'SpatialGridDataFrame') } else { x <- as(x, 'SpatialGrid') } return(brick(x)) } ) setMethod('brick', signature(x='array'), function(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", transpose=FALSE) { dm <- dim(x) if (is.matrix(x)) { stop('cannot coerce a matrix to a RasterBrick') } if (length(dm) != 3) { stop('array has wrong number of dimensions (needs to be 3)') } b <- brick(xmn=xmn, xmx=xmx, ymn=ymn, ymx=ymx, crs=crs, nl=dm[3]) names(b) <- dimnames(x)[[3]] if (transpose) { dim(b) <- c(dm[2], dm[1], dm[3]) } else { dim(b) <- dm # aperm etc suggested by Justin McGrath # https://r-forge.r-project.org/forum/message.php?msg_id=4312 x = aperm(x, perm=c(2,1,3)) } attributes(x) <- list() dim(x) <- c(dm[1] * dm[2], dm[3]) setValues(b, x) } ) # setMethod('brick', signature(x='big.matrix'), # function(x, template, filename='', ...) { # stopifnot(inherits(template, 'BasicRaster')) # stopifnot(nrow(x) == ncell(template)) # r <- brick(template) # filename <- trim(filename) # names(r) <- colnames(x) # if (canProcessInMemory(r)) { # r <- setValues(r, x[]) # if (filename != '') { # r <- writeRaster(r, filename, ...) # } # } else { # tr <- blockSize(r) # pb <- pbCreate(tr$n, ...) # r <- writeStart(r, filename, ...) # for (i in 1:tr$n) { # r <- writeValues(r, x[tr$row[i]:(tr$row[i]+tr$nrows[i]-1), ], tr$row[i] ) # pbStep(pb) # } # r <- writeStop(r) # pbClose(pb) # } # return(r) # } # ) setMethod('brick', signature(x='kasc'), function(x) { as(x, 'RasterBrick') } ) setMethod('brick', signature(x='grf'), function(x) { as(x, 'RasterBrick') } ) setMethod('brick', signature(x='list'), function(x) { x <- stack(x) brick(x) } ) setMethod('brick', signature(x='SpatRaster'), function(x) { as(x, "Raster") } ) raster/R/extentUnion.R0000644000176200001440000000012314507510157014417 0ustar liggesusers# Authors: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 raster/R/whiches.max.R0000644000176200001440000000465014507510157014326 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2016 # Version 1.0 # Licence GPL v3 # 'whiches' functions based on code by Data Munger: # https://stackoverflow.com/questions/36117678/r-raster-how-to-record-ties-using-which-max/36120244#36120244 .whiches <- function(i, fun=min, na.rm=TRUE) { w <- getOption('warn') on.exit(options('warn'= w)) options('warn'=-1) m <- which(i == fun(i, na.rm=na.rm)) sum(m * 10^(rev(seq_along(m)) - 1)) } setMethod("whiches.min", "RasterStackBrick", function(x) { whichesMin <- function(i) { m <- which(i == min(i, na.rm=TRUE)) sum(m * 10^(rev(seq_along(m)) - 1)) } r <- raster(x) nl <- nlayers(x) if (nl > 9) { stop('you can use only use this function for an object with less than 10 layers') } if (canProcessInMemory(x)) { x <- values(x) d <- dim(x) i <- .rowSums(is.na(x), d[1], d[2]) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, whichesMin) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) d <- dim(v) j <- .rowSums(is.na(v), d[1], d[2]) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, whichesMin) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) setMethod("whiches.max", "RasterStackBrick", function(x) { whichesMax <- function(i) { m <- which(i == max(i, na.rm=TRUE)) sum(m * 10^(rev(seq_along(m)) - 1)) } r <- raster(x) nl <- nlayers(x) if (nl > 9) { stop('you can use only use this function for an object with less than 10 layers') } if (canProcessInMemory(x)) { x <- values(x) d <- dim(x) i <- .rowSums(is.na(x), d[1], d[2]) < nl y <- rep(NA, nrow(x)) if (sum(i) > 0) { y[i] <- apply(x[i,], 1, whichesMax) } return( setValues(r, y) ) } else { tr <- blockSize(x) x <- readStart(x) out <- raster(x) out <- writeStart(out, '') for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) d <- dim(v) j <- .rowSums(is.na(v), d[1], d[2]) < nl y <- rep(NA, nrow(v)) if (sum(j) > 0) { y[j] <- apply(v[j,], 1, whichesMax) } out <- writeValues(out, y, tr$row[i]) } out <- writeStop(out) x <- readStop(x) return(out) } } ) raster/R/plot2rasters.R0000644000176200001440000000753314507510157014557 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod("plot", signature(x='Raster', y='Raster'), function(x, y, maxpixels=100000, cex, xlab, ylab, nc, nr, maxnl=16, main, add=FALSE, gridded=FALSE, ncol=25, nrow=25, ...) { compareRaster(c(x, y), extent=TRUE, rowcol=TRUE, crs=FALSE, stopiffalse=TRUE) nlx <- nlayers(x) nly <- nlayers(y) maxnl <- max(1, round(maxnl)) nl <- max(nlx, nly) if (nl > maxnl) { nl <- maxnl if (nlx > maxnl) { x <- x[[1:maxnl]] nlx <- maxnl } if (nly > maxnl) { y <- y[[1:maxnl]] nly <- maxnl } } if (missing(main)) { main <- '' } if (missing(xlab)) { ln1 <- names(x) } else { ln1 <- xlab if (length(ln1) == 1) { ln1 <- rep(ln1, nlx) } } if (missing(ylab)) { ln2 <- names(y) } else { ln2 <- ylab if (length(ln1) == 1) { ln2 <- rep(ln2, nly) } } cells <- ncell(x) # gdal selects a slightly different set of cells than raster does for other formats. # using gdal directly to subsample is faster. if (gridded) { if ((ncell(x) * (nlx + nly)) < .maxmemory()) { maxpixels <- ncell(x) } } dx <- .driver(x, warn=FALSE) dy <- .driver(y, warn=FALSE) if ( all(dx =='gdal') & all(dy == 'gdal')) { x <- sampleRegular(x, size=maxpixels, useGDAL=TRUE) y <- sampleRegular(y, size=maxpixels, useGDAL=TRUE) } else { x <- sampleRegular(x, size=maxpixels) y <- sampleRegular(y, size=maxpixels) } if (NROW(x) < cells) { warning(paste('plot used a sample of ', round(100*NROW(x)/cells, 1), '% of the cells. You can use "maxpixels" to increase the sample)', sep="")) } if (missing(cex)) { if (NROW(x) < 100) { cex <- 1 } else if (NROW(x) < 1000) { cex <- 0.5 } else { cex <- 0.2 } } if (nlx != nly) { # recycling d <- cbind(as.vector(x), as.vector(y)) x <- matrix(d[,1], ncol=nl) y <- matrix(d[,2], ncol=nl) lab <- vector(length=nl) lab[] <- ln1 ln1 <- lab lab[] <- ln2 ln2 <- lab } if (nl > 1) { if (missing(nc)) { nc <- ceiling(sqrt(nl)) } else { nc <- max(1, min(nl, round(nc))) } if (missing(nr)) { nr <- ceiling(nl / nc) } else { nr <- max(1, min(nl, round(nr))) nc <- ceiling(nl / nr) } old.par <- graphics::par(no.readonly = TRUE) on.exit(graphics::par(old.par)) graphics::par(mfrow=c(nr, nc), mar=c(4, 4, 2, 2)) if (! gridded) { if (add) { for (i in 1:nl) { points(x[,i], y[,i], cex=cex, ...) } } else { for (i in 1:nl) { plot(x[,i], y[,i], cex=cex, xlab=ln1[i], ylab=ln2[i], main=main[i], ...) } } } else { for (i in 1:nl) { .plotdens(x[,i], y[,i], nc=ncol, nr=nrow, main=main[i], xlab=ln1[i], ylab=ln2[i], add=add, ...) } } } else { if (! gridded) { if (add) { points(x, y, cex=cex, ...) } else { plot(x, y, cex=cex, xlab=ln1[1], ylab=ln2[1], main=main[1], ...) } } else { .plotdens(x, y, nc=ncol, nr=nrow, main=main[1], xlab=ln1[1], ylab=ln2[1], ...) } } } ) .plotdens <- function(x, y, nc, nr, asp=NULL, xlim=NULL, ylim=NULL, ...) { xy <- stats::na.omit(cbind(x,y)) if (nrow(xy) == 0) { stop('only NA values (in this sample?)') } r <- apply(xy, 2, range) rx <- r[,1] if (rx[1] == rx[2]) { rx[1] <- rx[1] - 0.5 rx[2] <- rx[2] + 0.5 } ry <- r[,2] if (ry[1] == ry[2]) { ry[1] <- ry[1] - 0.5 ry[2] <- ry[2] + 0.5 } out <- raster(xmn=rx[1], xmx=rx[2], ymn=ry[1], ymx=ry[2], ncol=nc, nrow=nr) out <- rasterize(xy, out, fun=function(x, ...) length(x), background=0) if (!is.null(xlim) | !is.null(ylim)) { if (is.null(xlim)) xlim <- c(xmin(x), xmax(x)) if (is.null(ylim)) ylim <- c(ymin(x), ymax(x)) e <- extent(xlim, ylim) out <- extend(crop(out, e), e, value=0) } .plotraster2(out, maxpixels=nc*nr, asp=asp, ...) } raster/R/crop.R0000644000176200001440000000466014507510157013054 0ustar liggesusers# Authors: Robert J. Hijmans and Jacob van Etten # Date : October 2008 # Version 0.9 # Licence GPL v3 .copyWithProperties <- function(x) { if (inherits(x, 'RasterBrick')) { out <- brick(x, values=FALSE) out@legend <- x@legend } else if (inherits(x, 'RasterStack')) { out <- brick(x, values=FALSE) } else { out <- raster(x) out@legend <- x@legend } names(out) <- names(x) out <- setZ(out, getZ(x)) fx <- is.factor(x) if (isTRUE(any(fx))) { out@data@isfactor <- fx out@data@attributes <- levels(x) } out } setMethod('crop', signature(x='Raster', y='ANY'), function(x, y, filename='', snap='near', datatype=NULL, ...) { filename <- trim(filename) y <- try ( extent(y), silent=TRUE ) if (inherits(y, "try-error")) { stop('Cannot get an Extent object from argument y') } methods::validObject(y) out <- .copyWithProperties(x) leg <- out@legend e <- intersect(extent(x), extent(y)) if (is.null(e)) { stop('extents do not overlap') } e <- alignExtent(e, x, snap=snap) out <- setExtent(out, e, keepres=TRUE) if (! hasValues(x)) { return(out) } col1 <- colFromX(x, xmin(out)+0.5*xres(out)) col2 <- colFromX(x, xmax(out)-0.5*xres(out)) row1 <- rowFromY(x, ymax(out)-0.5*yres(out)) row2 <- rowFromY(x, ymin(out)+0.5*yres(out)) if (row1==1 & row2==nrow(x) & col1==1 & col2==ncol(x)) { if (filename == "") { return(x) } else { return(writeRaster(x, filename=filename, datatype=datatype, ...)) } } nc <- ncol(out) if (is.null(datatype)) { datatype <- unique(c(dataType(x), 'INT2S')) if (length(datatype) > 1) { datatype <- .commonDataType(datatype) } } dataType(out) <- datatype xx <- out xx@ncols <- x@ncols # getValuesBlock might read entire rows and then subset if (canProcessInMemory(xx, 4)) { nr <- row2 - row1 + 1 v <- getValuesBlock(x, row1, nrows=nr, col=col1, ncols=nc) out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename=filename, datatype=datatype, ...) } } else { tr <- blockSize(out) pb <- pbCreate(tr$n, label='crop', ...) out <- writeStart(out, filename=filename, datatype=datatype, ... ) x <- readStart(x, ...) for (i in 1:tr$n) { vv <- getValuesBlock(x, row=tr$row[i]+row1-1, nrows=tr$nrows[i], col1, nc) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } out <- writeStop(out) x <- readStop(x) pbClose(pb) } if (!inherits(out, 'RasterStack')) { out@legend <- leg } return(out) } ) raster/R/summary.R0000644000176200001440000000402114507510157013575 0ustar liggesusers# Author: Robert J. Hijmans # Date: June 2008 # Version 1.0 # Licence GPL v3 if (!isGeneric("summary")) { setGeneric("summary", function(object, ...) standardGeneric("summary")) } setMethod('summary', signature(object='RasterLayer'), function(object, maxsamp=100000, ...) { if ( inMemory(object) ) { sm <- as.matrix( stats::quantile( values(object), na.rm=TRUE) ) sm <- c(sm, sum(is.na( values(object) ))) } else if ( fromDisk(object) ) { if (ncell(object) > maxsamp) { v <- sampleRegular(object, maxsamp) nas <- round(sum(is.na(v)) * ncell(object) / maxsamp) warning(paste('summary is an estimate based on a sample of ', maxsamp, ' cells (', round(100*maxsamp/ncell(object), 2), '% of all cells)\n', sep='')) } else { v <- getValues(object) nas <- sum(is.na(v)) } sm <- stats::quantile(v, na.rm=TRUE) sm <- c(sm, nas) } else { sm <- NA } values <- matrix(sm, ncol=1, nrow=6) rownames(values) <- c('Min.', '1st Qu.', 'Median', '3rd Qu.', 'Max.', "NA's") colnames(values) <- names(object) return(values) } ) setMethod('summary', signature(object='RasterStackBrick'), function(object, maxsamp=100000, ...) { if ( inMemory(object) & inherits(object, "RasterBrick")) { sm <- apply(object@data@values, 2, quantile, na.rm=TRUE) nas <- apply(is.na(object@data@values), 2, sum) values <- rbind(sm, nas) } else if ( hasValues(object) ) { nc <- ncell(object) if (nc > maxsamp) { v <- sampleRegular(object, maxsamp) nas <- round(apply(is.na(v), 2, sum) * nc / maxsamp) warning(paste('summary is an estimate based on a sample of ', maxsamp, ' cells (', round(100*maxsamp/nc, 2), '% of all cells)\n', sep='')) } else { v <- getValues(object) nas <- apply(is.na(v), 2, sum) } sm <- apply(v, 2, quantile, na.rm=T) values <- rbind(sm, nas) } else { stop('no cell values associated with this RasterBrick') } rownames(values) <- c('Min.', '1st Qu.', 'Median', '3rd Qu.', 'Max.', "NA's") return(values) } ) raster/R/pointdistance.R0000644000176200001440000000741314507510157014754 0ustar liggesusers# Author: Robert J. Hijmans and Jacob van Etten # Date : June 2008 # Version 0.9 # Licence GPL v3 .pointsToMatrix <- function(p) { if (inherits(p, "sf")) { p <- as(p, "Spatial") } if (inherits(p, 'SpatialPoints')) { p <- sp::coordinates(p) } else if (is.data.frame(p)) { p <- as.matrix(p) } else if (is.vector(p)){ if (length(p) != 2) { stop('Wrong length for a vector, should be 2') } else { p <- matrix(p, ncol=2) } } if (is.matrix(p)) { if (ncol(p) != 2) { stop( 'A points matrix should have 2 columns') } cn <- colnames(p) if (length(cn) == 2) { if (toupper(cn[1]) == 'Y' | toupper(cn[2]) == 'X') { stop('Highly suspect column names (x and y reversed?)') } if (toupper(substr(cn[1],1,3) == 'LAT' | toupper(substr(cn[2],1,3)) == 'LON')) { stop('Highly suspect column names (longitude and latitude reversed?)') } } } else { stop('points should be vectors of length 2, matrices with 2 columns, or a SpatialPoints* object') } return(p) } .distm <- function (x, longlat) { if (longlat) { n <- nrow(x) dm <- matrix(ncol = n, nrow = n) dm[cbind(1:n, 1:n)] <- 0 if (n > 1) { for (i in 2:n) { j = 1:(i - 1) dm[i, j] = .geodist(x[i, 1], x[i, 2], x[j, 1], x[j, 2]) } } return(dm) } else { return(.planedist2(x, x)) } } .distm2 <- function (x, y, longlat) { if (longlat) { n <- nrow(x) m <- nrow(y) dm <- matrix(ncol=m, nrow=n) for (i in 1:n) { dm[i,] <- .geodist(x[i, 1], x[i, 2], y[, 1], y[, 2]) } return(dm) } else { return(.planedist2(x, y)) # fun <- .planedist } } .distm2new <- function (x, y, longlat, a=6378137, f=1/298.257223563) { if (longlat) { n <- nrow(x) m <- nrow(y) xx <- cbind(rep(x[,1], m), rep(x[,2], m)) yy <- cbind(rep(y[,1], each=n), rep(y[,2], each=n)) g <- .Call("_raster_point_distance", xx, yy, TRUE, a, f, PACKAGE='raster') return(matrix(g, n, m)) } else { return(.planedist2(x, y)) # fun <- .planedist } } pointDistance <- function (p1, p2, lonlat, allpairs=FALSE, ...) { longlat <- list(...)$longlat if (!is.null(longlat)) { lonlat <- longlat } if (missing(lonlat)) { if (isLonLat(p1)) { lonlat <- TRUE } else if (! is.na(projection(p1)) ) { lonlat <- FALSE } else { stop('you must provide a "lonlat" argument (TRUE/FALSE)') } } stopifnot(is.logical(lonlat)) p1 <- .pointsToMatrix(p1) if (missing(p2)) { return(.distm(p1, lonlat)) } p2 <- .pointsToMatrix(p2) if (nrow(p1) != nrow(p2)) { allpairs <- TRUE } if (allpairs) { if(nrow(p1) > 1 & nrow(p2) > 1) { return(.distm2(p1, p2, lonlat)) } } if (lonlat ) { # return( .haversine(p1[,1], p1[,2], p2[,1], p2[,2], r=6378137) ) return( .geodist(p1[,1], p1[,2], p2[,1], p2[,2]) ) } else { return( .planedist(p1[,1], p1[,2], p2[,1], p2[,2]) ) } } .planedist <- function(x1, y1, x2, y2) { sqrt(( x1 - x2)^2 + (y1 - y2)^2) } .planedist2 <- function(p1, p2) { # code by Bill Venables # https://stat.ethz.ch/pipermail/r-help/2008-February/153841.html z0 <- complex(, p1[,1], p1[,2]) z1 <- complex(, p2[,1], p2[,2]) outer(z0, z1, function(z0, z1) Mod(z0-z1)) } .geodist <- function(x1, y1, x2, y2, a=6378137, f=1/298.257223563) { # recycle p <- cbind(x1, y1, x2, y2) .Call("_raster_point_distance", p[,1:2, drop=FALSE], p[, 3:4,drop=FALSE], TRUE, a, f, PACKAGE='raster') # .Call("inversegeodesic", as.double(p[,1]), as.double(p[,2]), as.double(p[,3]), as.double(p[,4]), as.double(a), as.double(f), PACKAGE='raster') } .old_haversine <- function(x1, y1, x2, y2, r=6378137) { adj <- pi / 180 x1 <- x1 * adj y1 <- y1 * adj x2 <- x2 * adj y2 <- y2 * adj x <- sqrt((cos(y2) * sin(x1-x2))^2 + (cos(y1) * sin(y2) - sin(y1) * cos(y2) * cos(x1-x2))^2) y <- sin(y1) * sin(y2) + cos(y1) * cos(y2) * cos(x1-x2) return ( r * atan2(x, y) ) } raster/R/readRasterLayer.R0000644000176200001440000001401214507510157015172 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 1.0 # Licence GPL v3 .readRasterLayerValues <- function(object, startrow, nrows=1, startcol=1, ncols=ncol(object)-startcol+1) { # if (nrows < 1) { stop("nrows should be > 1") } # startrow <- min(max(1, round(startrow)), object@nrows) # endrow <- min(object@nrows, startrow+nrows-1) # nrows <- endrow - startrow + 1 # if (ncols < 1) { stop("ncols should be > 1") } # startcol <- min(max(1, round(startcol)), object@ncols) # endcol <- min(object@ncols, startcol+ncols-1) # ncols <- endcol - startcol + 1 driver <- object@file@driver if (.isNativeDriver(driver)) { getBSQData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band=1) { offset <- raster@file@offset + (band-1) * raster@ncols * raster@nrows + (r-1) * raster@ncols if (c==1 & ncols==raster@ncols) { seek(raster@file@con, offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nrows*ncols, dsize, dsign, endian=raster@file@byteorder) } else { result <- matrix(ncol=nrows, nrow=ncols) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols + (c-1) seek(raster@file@con, off * dsize) result[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } } return(as.vector(result)) } getBilData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band) { offset <- raster@file@offset + raster@file@nbands * raster@ncols * (r-1) + (c-1) result <- matrix(ncol=nrows, nrow=ncols) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols * raster@file@nbands + (band-1) * raster@ncols seek(raster@file@con, off * dsize) result[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } return(as.vector(result)) } getBipData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign, band) { offset <- raster@file@offset + raster@file@nbands * raster@ncols * (r-1) nc <- ncols * raster@file@nbands index <- rep(FALSE, raster@file@nbands) index[band] <- TRUE index <- rep(index, ncols) result <- matrix(ncol=nrows, nrow=ncols) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols * raster@file@nbands + (c-1) * raster@file@nbands seek(raster@file@con, off * dsize) res <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) result[,i] <- res[index] } return(as.vector(result)) } if (! object@file@toptobottom ) { endrow <- object@nrows - startrow + 1 startrow <- endrow - nrows + 1 } dtype <- substr(object@file@datanotation, 1, 3) if (dtype == "INT" | dtype == "LOG" ) { dtype <- "integer" } else { dtype <- "numeric" } dsize <- dataSize(object@file@datanotation) dsign <- dataSigned(object@file@datanotation) if (dsize > 2) { dsign <- TRUE } is.open <- object@file@open if (!is.open) { object <- readStart(object) } if (object@file@nbands > 1) { band <- object@data@band bo <- object@file@bandorder if (bo == 'BSQ') { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign, band=band) } else if (bo == 'BIL') { result <- getBilData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign, band=band) } else if (bo == 'BIP') { result <- getBipData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign, band=band) } } else { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } if (!is.open) { object <- readStop(object) } if (! object@file@toptobottom ) { result <- t(matrix(result, nrow=ncols, ncol=nrows)) result <- result[nrows:1,] result <- as.vector(t(result)) } if (object@file@datanotation == 'INT4U') { i <- !is.na(result) & result < 0 result[i] <- 2147483647 - result[i] } if (dtype == 'numeric') { result[result <= (0.999999 * object@file@nodatavalue)] <- NA result[is.nan(result)] <- NA } else { result[result == object@file@nodatavalue ] <- NA } if (dtype == 'logical') { result <- as.logical(result) } # ascii is internal to this package but not 'native' (not binary) } else if (driver == 'ascii') { result <- .readRowsAscii(object, startrow, nrows, startcol, ncols) } else if (driver == 'netcdf') { result <- .readRowsNetCDF(object, startrow, nrows, startcol, ncols) # } else if (driver == 'big.matrix') { # bm <- attr(object@file, 'big.matrix') # if (nbands(object) > 1) { # bn <- bandnr(object) # startcell <- cellFromRowCol(object, startrow, startcol) # endcell <- cellFromRowCol(object, (startrow+nrows-1), (startcol+ncols-1)) # result <- bm[startcell:endcell, bn] # # } else { # result <- as.vector(t(bm[startrow:(startrow+nrows-1), startcol:(startcol+ncols-1)])) # } ## terra adjusts # if (object@data@gain != 1 | object@data@offset != 0) { # result <- result * object@data@gain + object@data@offset # } #use GDAL } else { #offs <- c((startrow-1), (startcol-1)) #reg <- c(nrows, ncols) #if ( object@file@open ) { # result <- rgdal::getRasterData(object@file@con, offset=offs, region.dim=reg, band=object@data@band) #} else { # con <- rgdal::GDAL.open(object@file@name, silent=TRUE) # result <- rgdal::getRasterData(con, offset=offs, region.dim=reg, band=object@data@band) # rgdal::closeDataset(con) #} #result <- as.vector(result) # if NAvalue() has been used..... #if (object@file@nodatavalue < 0) { # result[result <= object@file@nodatavalue ] <- NA #} else { # result[result == object@file@nodatavalue ] <- NA #} object <- rast(object) readStart(object) result <- readValues(object, startrow, nrows, startcol, ncols, mat=FALSE, dataframe=FALSE) result[is.nan(result)] <- NA readStop(object) #if (object@data@gain != 1 | object@data@offset != 0) { # result <- result * object@data@gain + object@data@offset #} } return(result) } raster/R/rasterFromRasterFile.R0000644000176200001440000002640714507510157016221 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .getRat <- function(x, ratvalues, ratnames, rattypes) { rat <- data.frame(matrix(ratvalues, nrow=length(ratvalues) / length(ratnames)), stringsAsFactors=FALSE) colnames(rat) <- ratnames for (i in 1:ncol(rat)) { if (rattypes[i] == 'integer') { rat[, i] <- as.integer(rat[,i]) } else if (rattypes[i] == 'numeric') { rat[, i] <- as.numeric(rat[,i]) } else if (rattypes[i] == 'factor') { rat[, i] <- as.factor(rat[,i]) } } x@data@isfactor <- TRUE x@data@attributes <- list(rat) x } .getProj <- function(proj, crs) { if (is.na(proj)) { proj <- "" } if ( crs != "" ) { if (proj == "") { proj <- crs } else { warning('argument "crs" ignored because the file provides a crs') } } proj } .getmetadata <- function(x) { x <- x[x[,1] == 'metadata', , drop=FALSE] if (nrow(x) == 0) { return( list() ) } y <- sapply(x[,2], function(i) .strSplitOnFirstToken(i, '.')) colnames(y) <- NULL v1 <- y[1,] v2 <- y[2,] vv <- sapply(x[,3], function(i) .strSplitOnFirstToken(i, ':')) colnames(vv) <- NULL type <- vv[1,] v3 <- gsub('#NL#', '\n', vv[2,]) a <- list() for (i in 1:length(v1)) { value <- unlist(strsplit(v3[i], '#,#')) if (type[i] == 'Date') { try(value <- as.Date(value)) } else { try(value <- as(value, type[i])) } if (is.na(v2[i])) { a[[v1[i]]] <- value } else { b <- list(value) names(b) <- v2[i] a[[v1[i]]] <- c(a[[v1[i]]], b) } } a } .rasterFromRasterFile <- function(filename, band=1, type='RasterLayer', driver='raster', RAT=TRUE, crs="", ...) { valuesfile <- .setFileExtensionValues(filename, driver) if (!file.exists( valuesfile )){ stop( paste(valuesfile, "does not exist")) } filename <- .setFileExtensionHeader(filename, driver) ini <- readIniFile(filename) metadata <- .getmetadata(ini) ini <- ini[ini[,1] != 'metadata', , drop=FALSE] ini[,2] = toupper(ini[,2]) byteorder <- .Platform$endian nbands <- as.integer(1) band <- as.integer(band) bandorder <- "BIL" prj <- NA # update to add WKT2 wkt <- NA minval <- NA maxval <- NA nodataval <- -Inf layernames <- "" zvalues <- "" zclass <- NULL colortable <- NULL isCat <- FALSE ratnames <- rattypes <- ratvalues <- NULL catlevels <- matrix(NA) #match(c("MINX", "MAXX", "MINY", "MAXY", "XMIN", "XMAX", "YMIN", "YMAX", "ROWS", "COLUMNS", "NROWS", "NCOLS"), toupper(ini[,2])) grdversion <- ifelse(isTRUE((ini[ini[,1] =="version",3] == "2")), 2, 1) if (grdversion >= 2) { for (i in 1:nrow(ini)) { if (ini[i,2] == "MINX") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MINY") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXY") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMIN") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMAX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMIN") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMAX") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "NROW") { nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "NCOL") { nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "RANGE_MIN") { suppressWarnings( try ( minval <- as.numeric(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE)), silent = TRUE ) ) } else if (ini[i,2] == "RANGE_MAX") { suppressWarnings( try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE)), use.names=FALSE), silent = TRUE ) ) } else if (ini[i,2] == "VALUEUNIT") { try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE)), use.names=FALSE), silent = TRUE) } else if (ini[i,2] == "CATEGORICAL") { try ( isCat <- as.logical(unlist(strsplit(ini[i,3], ":|:", fixed=TRUE)), use.names=FALSE), silent = TRUE ) #else if (ini[i,2] == "RATROWS") { ratrows <- as.integer(ini[i,3]) } } else if (ini[i,2] == "RATNAMES") { ratnames <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE) } else if (ini[i,2] == "RATTYPES") { rattypes <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE) } else if (ini[i,2] == "RATVALUES") { ratvalues <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE) } else if (ini[i,2] == "LEVELS") { try ( catlevels <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE ), silent = TRUE) } else if (ini[i,2] == "COLORTABLE") { try ( colortable <- unlist(strsplit(ini[i,3], ":|:", fixed=TRUE), use.names=FALSE), silent = TRUE ) } else if (ini[i,2] == "NODATA") { if (ini[i,3] == "NA") { nodataval <- as.double(NA) } else { nodataval <- as.numeric(ini[i,3]) } } else if (ini[i,2] == "DATATYPE") { inidatatype <- ini[i,3] } else if (ini[i,2] == "BYTEORDER") { byteorder <- ini[i,3] } else if (ini[i,2] == "NLYR") { nbands <- as.integer(ini[i,3]) } else if (ini[i,2] == "BANDORDER") { bandorder <- ini[i,3] } else if (ini[i,2] == "CRS") { prj <- ini[i,3] # update to add WKT2 } else if (ini[i,2] == "WKT") { wkt <- ini[i,3] } else if (ini[i,2] == "NAMES") { layernames <- ini[i,3] } else if (ini[i,2] == "ZVALUES") { zvalues <- ini[i,3] } else if (ini[i,2] == "ZCLASS") { zclass <- ini[i,3] } } } else { for (i in 1:length(ini[,1])) { if (ini[i,2] == "MINX") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MINY") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "MAXY") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMIN") { xn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "XMAX") { xx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMIN") { yn <- as.numeric(ini[i,3]) } else if (ini[i,2] == "YMAX") { yx <- as.numeric(ini[i,3]) } else if (ini[i,2] == "ROWS") { nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "COLUMNS") { nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "NROWS") { nr <- as.integer(ini[i,3]) } else if (ini[i,2] == "NCOLS") { nc <- as.integer(ini[i,3]) } else if (ini[i,2] == "MINVALUE") { suppressWarnings( try ( minval <- as.numeric(unlist(strsplit(ini[i,3], ':'), use.names=FALSE)), silent = TRUE ) ) } else if (ini[i,2] == "MAXVALUE") { suppressWarnings( try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE ) ) } else if (ini[i,2] == "VALUEUNIT") { try ( maxval <- as.numeric(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE) } else if (ini[i,2] == "CATEGORICAL") { try ( isCat <- as.logical(unlist(strsplit(ini[i,3], ':')), use.names=FALSE), silent = TRUE ) #else if (ini[i,2] == "RATROWS") { ratrows <- as.integer(ini[i,3]) } } else if (ini[i,2] == "RATNAMES") { ratnames <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE) } else if (ini[i,2] == "RATTYPES") { rattypes <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE) } else if (ini[i,2] == "RATVALUES") { ratvalues <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE) ratvalues <- gsub('~^colon^~', ':', ratvalues) } else if (ini[i,2] == "LEVELS") { try ( catlevels <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE ), silent = TRUE) } else if (ini[i,2] == "COLORTABLE") { try ( colortable <- unlist(strsplit(ini[i,3], ':'), use.names=FALSE), silent = TRUE ) } else if (ini[i,2] == "NODATAVALUE") { if (ini[i,3] == 'NA') { nodataval <- as.double(NA) } else { nodataval <- as.numeric(ini[i,3]) } } else if (ini[i,2] == "DATATYPE") { inidatatype <- ini[i,3] } else if (ini[i,2] == "BYTEORDER") { byteorder <- ini[i,3] } else if (ini[i,2] == "NBANDS") { nbands <- as.integer(ini[i,3]) } else if (ini[i,2] == "BANDORDER") { bandorder <- ini[i,3] } else if (ini[i,2] == "PROJECTION") { prj <- ini[i,3] # update to add WKT2 } else if (ini[i,2] == "WKT") { wkt <- 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(wkt) && (wkt != "")) { prj <- wkt } if (!is.na(prj)) { if (prj == 'GEOGRAPHIC') { prj <- "+proj=longlat" } else if (prj == 'UNKNOWN' | prj == 'NA') { prj <- NA } } if (band < 1) { stop("band must be 1 or larger") #band <- 1 #warning('band set to 1') } else if (band > nbands) { stop(paste("band too high. Should be between 1 and", nbands)) #band <- nbands #warning('band set to ', nbands) } minval <- minval[1:nbands] maxval <- maxval[1:nbands] minval[is.na(minval)] <- Inf maxval[is.na(maxval)] <- -Inf if (type == 'RasterBrick') { x <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=prj) x@data@nlayers <- as.integer(nbands) x@data@min <- minval x@data@max <- maxval } else { x <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs=prj) x@data@band <- as.integer(band) x@data@min <- minval[band] x@data@max <- maxval[band] if (RAT) { if (isTRUE(isCat[band])) { # currently only for a single layer! try( x <- .getRat(x, ratvalues, ratnames, rattypes), silent=TRUE ) } } } x@file@nbands <- as.integer(nbands) if (bandorder %in% c("BSQ", "BIP", "BIL")) { x@file@bandorder <- bandorder } if (nchar(layernames) > 0) { lnames <- as.vector(unlist(strsplit(layernames, ':'))) if (length(lnames) != nbands) { lnames <- rep( gsub(" ", "_", extension(basename(filename), "")), nbands) } } else { lnames <- gsub(" ", "_", extension(basename(filename), "")) if (nbands < 0) { lnames <- paste(lnames , 1:nbands, sep='_') } } if (zvalues != '') { names(zvalues) <- NULL zvalues <- unlist(strsplit(zvalues, ':')) zname <- zvalues[1] zvalues <- zvalues[-1] if (!is.null(zclass)) { if (zclass == 'Date') { try( zvalues <- as.Date(zvalues), silent=TRUE ) # by Stefan Schlaffer } else if (length(grep("POSIXt",zclass)) > 0 & length(zvalues) == nbands*3) { zvalues <- sapply(seq(1,nbands*3,3), function(i) paste0(zvalues[c(i,i+1,i+2)], collapse=":")) try( zvalues <- as.POSIXct(strptime(zvalues, "%Y-%m-%d %H:%M:%S", tz="UTC")), silent=TRUE ) } else { try( zvalues <- as(zvalues, zclass), silent=TRUE ) } } if (type == 'RasterBrick') { zvalues <- list(zvalues) } else { zvalues <- list(zvalues[band]) } names(zvalues) <- zname x@z <- zvalues } if (type == 'RasterBrick') { names(x) <- lnames } else { names(x) <- lnames[band] } dataType(x) <- inidatatype x@data@haveminmax <- TRUE # should check? x@file@nodatavalue <- nodataval if ((byteorder == "little") | (byteorder == "big")) { x@file@byteorder <- byteorder } x@data@fromdisk <- TRUE x@file@driver <- driver # if( dataSize(x) * (ncell(x) * nbands(x) + x@file@offset) != file.info(valuesfile)$size ) { # if (driver == 'big.matrix') { # requireNamespace("bigmemory") # x@file@name <- valuesfile # dscfile <- extension(valuesfile, 'big.dsc') # attr(x@file, 'big.matrix') <- attach.big.matrix(dscfile) # } else { x@file@name <- filename if( (dataSize(x) * ncell(x) * nbands(x)) != file.info(valuesfile)$size ) { warning('size of values file does not match the number of cells (given the data type)') # } } if (!is.null(colortable)) { x@legend@colortable <- colortable } x@history <- metadata return(x) } raster/R/notused.R0000644000176200001440000000225314507510157013566 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 # Not used .writeRasterAssign <- function(x, filename, ...) { name <- deparse(substitute(x)) x <- writeRaster(x, filename, ...) assign(name, x, envir=parent.frame()) return(invisible()) } .writeSparse <- function(raster, filename, overwrite=FALSE) { # raster@file@driver <- 'raster' if (!overwrite & file.exists(filename)) { stop(filename, "exists. Use 'overwrite=TRUE' if you want to overwrite it") } raster@data@values[is.nan(raster@data@values)] <- NA dtype <- .shortDataType(raster@data@datanotation) if (dtype == "integer") { raster@data@values <- as.integer(raster@data@values) } if (inherits(raster@data@values, 'integer')) { dataType(raster) <- 'INT4S' } raster <- setMinMax(raster) binraster <- .setFileExtensionValues(raster@file@name, 'raster') raster <- readStart(raster) writeBin( as.vector(raster@data@indices), raster@file@con, size = as.integer(4)) writeBin( as.vector(raster@data@values), raster@file@con, size = dataSize(raster@file@datanotation) ) raster <- readStop(raster) # add the 'sparse' key word to the hdr file!!! hdr(raster) return(raster) } raster/R/contour.R0000644000176200001440000000413714507510157013601 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2009 # Version 0.9 # Licence GPL v3 setMethod("contour", signature(x='RasterLayer'), function(x, maxpixels=100000, ...) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) #, useGDAL=TRUE) contour(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...) } ) rasterToContour <- function(x, maxpixels=100000, ...) { x <- sampleRegular(x, size=maxpixels, asRaster=TRUE) #, useGDAL=TRUE) cL <- grDevices::contourLines(x=xFromCol(x,1:ncol(x)), y=yFromRow(x, nrow(x):1), z=t((getValues(x, format='matrix'))[nrow(x):1,]), ...) # The below was taken from ContourLines2SLDF(maptools), by Roger Bivand & Edzer Pebesma .contourLines2LineList <- function(cL) { n <- length(cL) res <- vector(mode="list", length=n) for (i in 1:n) { crds <- cbind(cL[[i]][[2]], cL[[i]][[3]]) res[[i]] <- sp::Line(coords=crds) } res } if (length(cL) < 1) stop("no contour lines") cLstack <- tapply(1:length(cL), sapply(cL, function(x) x[[1]]), function(x) x, simplify = FALSE) df <- data.frame(level = names(cLstack)) m <- length(cLstack) res <- vector(mode = "list", length = m) IDs <- paste("C", 1:m, sep = "_") row.names(df) <- IDs for (i in 1:m) { res[[i]] <- sp::Lines(.contourLines2LineList(cL[cLstack[[i]]]), ID = IDs[i]) } SL <- sp::SpatialLines(res, proj4string= .getCRS((x))) sp::SpatialLinesDataFrame(SL, data = df) } filledContour <- function(x, y=1, maxpixels=100000, ...) { if (nlayers(x) > 1) { y <- min(max(1, y), nlayers(x)) x <- raster(x, y) } x <- sampleRegular(x, maxpixels, asRaster=TRUE) #, useGDAL=TRUE) X <- xFromCol(x, 1:ncol(x)) Y <- yFromRow(x, nrow(x):1) Z <- t( matrix( getValues(x), ncol=x@ncols, byrow=TRUE)[nrow(x):1,] ) lonlat <- couldBeLonLat(x, warnings=FALSE) asp <- list(...)$asp if (is.null(asp)) { if (lonlat) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) } else { asp <- 1 } graphics::filled.contour(x=X,y=Y,z=Z,asp=asp,...) } else { graphics::filled.contour(x=X,y=Y,z=Z,...) } } raster/R/cellRowCol.R0000644000176200001440000000652614507510157014161 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod(rowFromCell, signature(object="BasicRaster", cell="numeric"), function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA trunc((cell-1)/ncol(object)) + 1 } ) #rowFromCell <- function(object, cell) { # object <- raster(object) # cell <- round(cell) # cell[cell < 1 | cell > ncell(object)] <- NA # trunc((cell-1)/ncol(object)) + 1 #} .rowFromCell <- function(object, cell) { trunc((cell-1)/ncol(object)) + 1 } cellFromRow <- function(object, rownr) { object <- raster(object) rownr <- round(rownr) #if (length(rownr)==1) { # return(cellFromRowCol(object, rownr, 1):cellFromRowCol(object, rownr, object@ncols)) #} cols <- rep(1:ncol(object), times=length(rownr)) rows <- rep(rownr, each=ncol(object)) cellFromRowCol(object, rows, cols) } cellFromCol <- function(object, colnr) { object <- raster(object) colnr <- round(colnr) rows <- rep(1:nrow(object), times=length(colnr)) cols <- rep(colnr, each=nrow(object)) return(cellFromRowCol(object, rows, cols)) } .OLD_cellFromRowColCombine <- function(object, rownr, colnr) { object <- raster(object) rc <- expand.grid(rownr, colnr) return( cellFromRowCol(object, rc[,1], rc[,2])) } setMethod(cellFromRowColCombine, signature(object="BasicRaster", row="numeric", col="numeric"), function(object, row, col) { # faster without this according to PR #131 # object <- raster(object) row[row < 1 | row > object@nrows] <- NA col[col < 1 | col > object@ncols] <- NA cols <- rep(col, times=length(row)) dim(cols) <- c(length(col), length(row)) cols <- t(cols) row <- (row-1) * object@ncols cols <- cols + row as.vector(t(cols)) } ) setMethod(colFromCell, signature(object="BasicRaster", cell="numeric"), function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA rownr <- trunc((cell-1)/object@ncols) + 1 as.integer(cell - ((rownr-1) * object@ncols)) } ) #colFromCell <- function(object, cell) { # object <- raster(object) # cell <- round(cell) # cell[cell < 1 | cell > ncell(object)] <- NA # rownr <- trunc((cell-1)/object@ncols) + 1 # as.integer(cell - ((rownr-1) * object@ncols)) #} .colFromCell <- function(object, cell) { nc <- object@ncols rownr <- trunc((cell-1)/nc) + 1 cell - ((rownr-1) * nc) } setMethod(rowColFromCell, signature(object="BasicRaster", cell="numeric"), function(object, cell) { object <- raster(object) cell <- round(cell) cell[cell < 1 | cell > ncell(object)] <- NA row <- as.integer(trunc((cell-1)/object@ncols) + 1) col <- as.integer(cell - ((row-1) * object@ncols)) return(cbind(row, col)) } ) #rowColFromCell <- function(object, cell) { # object <- raster(object) # cell <- round(cell) # cell[cell < 1 | cell > ncell(object)] <- NA # row <- as.integer(trunc((cell-1)/object@ncols) + 1) # col <- as.integer(cell - ((row-1) * object@ncols)) # return(cbind(row, col)) #} setMethod(cellFromRowCol, signature(object="BasicRaster", row="numeric", col="numeric"), function(object, row, col, ...) { rows <- object@nrows cols <- object@ncols .doCellFromRowCol(rows, cols, row, col) } ) #cellFromRowCol <- function(object, rownr, colnr) { # rows <- object@nrows # cols <- object@ncols # .doCellFromRowCol(rows, cols, rownr, colnr) #} raster/R/subset.R0000644000176200001440000000506114507510157013412 0ustar liggesusers# Authors: Robert J. Hijmans # Date : August 2009 # Version 1.0 # Licence GPL v3 setMethod('subset', signature(x='RasterStack'), function(x, subset, drop=TRUE, filename='', ...) { if (is.character(subset)) { i <- stats::na.omit(match(subset, names(x))) if (length(i)==0) { stop('invalid layer names') } else if (length(i) < length(subset)) { warning('invalid layer names omitted') } subset <- i } subset <- as.integer(subset) if (! all(subset %in% 1:nlayers(x))) { stop('not a valid subset') } if (length(x@z) > 0) { z <- lapply(x@z, function(x) x[subset]) } else { z <- list() } if (length(subset) == 1 & drop) { x <- x@layers[[subset]] } else { x@layers <- x@layers[subset] } x@z <- z if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } ) setMethod('subset', signature(x='Raster'), function(x, subset, drop=TRUE, filename='', ...) { if (is.character(subset)) { i <- stats::na.omit(match(subset, names(x))) if (length(i)==0) { stop('invalid layer names') } else if (length(i) < length(subset)) { warning('invalid layer names omitted') } subset <- i } subset <- as.integer(subset) nl <- nlayers(x) if (! all(subset %in% 1:nl)) { stop('not a valid subset') } # now _after_ checking for valid names and adding the possibility to # subset a RasterLayer multiple times. Fixed/suggested by Benjamin Leutner if (inherits(x, 'RasterLayer')) { if (length(subset) > 1) { x <- stack(lapply(subset, function(...) x)) } if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } nav <- NAvalue(x) e <- extent(x) if (length(x@z)>0) { z <- lapply(x@z, function(x) x[subset]) } else { z <- list() } if (fromDisk(x)) { nms <- names(x) if (drop & length(subset)==1) { x <- raster(x, subset) } else { x <- stack(x, layers=subset) } extent(x) <- e names(x) <- nms[subset] NAvalue(x) <- nav } else { if (drop & length(subset)==1) { if (hasValues(x)) { x <- raster(x, subset) } else { x <- raster(x) } x@z <- z extent(x) <- e NAvalue(x) <- nav return(x) } if (hasValues(x)) { x@data@values <- x@data@values[, subset, drop=FALSE] x@data@min <- x@data@min[subset] x@data@max <- x@data@max[subset] } x@data@names <- x@data@names[subset] x@z <- z x@data@nlayers <- as.integer(length(subset)) f <- is.factor(x) if (any(f)) { x@data@attributes <- x@data@attributes[subset] x@data@isfactor <- x@data@isfactor[subset] } } if (filename != '') { x <- writeRaster(x, filename, ...) } x } ) raster/R/setCV.R0000644000176200001440000000207714507510157013135 0ustar liggesusers .setCV <- function(x, v, col) { stopifnot(length(v) == (length(col)+1)) v <- as.numeric(v) x@legend@values <- v x@legend@color <- col x@legend@colortable <- vector() x } #val <- c(-1, -0.3, -0.2, 0, 0.1, 0.3, 0.4, 0.6, 0.8, 1, 10) #ct <- c(grDevices::col2rgb("white"),grDevices::col2rgb("blue"),grDevices::rgb(205,193,173, maxColorValue = 255), grDevices::rgb(150,150,150, maxColorValue = 255), grDevices::rgb(120,100,51, maxColorValue = 255), grDevices::rgb(120,200,100, maxColorValue = 255), grDevices::rgb(28,144,3, maxColorValue = 255), grDevices::rgb(6,55,0, maxColorValue = 255), grDevices::rgb(10,30,25, maxColorValue = 255), grDevices::rgb(6,27,7, maxColorValue = 255)) .setCT <- function(x, v, col, na='white') { v <- as.numeric(v) na <- which(is.na(v)) if (length(na)==0) { v <- c(NA, v) col <- c('white', col) } else { v <- c(v[na], v[-na]) col <- c(col[na], col[-na]) } notrgb <- which(substr(col, 1, 1) != '#') col[notrgb] <- grDevices::rgb(t(grDevices::col2rgb(col[notrgb])), maxColorValue=255) x@legend@values <- v x@legend@color <- col x } raster/R/as.array.R0000644000176200001440000000154514507510157013630 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 setMethod('as.array', signature(x='RasterLayer'), function(x, maxpixels, ...) { if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } x <- array(as.matrix(x), c(dim(x))) x } ) setMethod('as.array', signature(x='RasterStackBrick'), function(x, maxpixels, transpose=FALSE) { if (!hasValues(x)) { stop("'x' has no values") } if (! missing(maxpixels)) { x <- sampleRegular(x, maxpixels, asRaster=TRUE) } dm <- dim(x) x <- getValues(x) if (transpose) { ar <- array(NA, c(dm[2], dm[1], dm[3])) for (i in 1:dm[3]) { ar[,,i] <- matrix(x[,i], nrow=dm[2], byrow=FALSE) } } else { ar <- array(NA, dm) for (i in 1:dm[3]) { ar[,,i] <- matrix(x[,i], nrow=dm[1], byrow=TRUE) } } ar } ) raster/R/unique.R0000644000176200001440000000372514507510157013420 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 setMethod('unique', signature(x='RasterLayer', incomparables='missing'), function(x, incomparables=FALSE, na.last=NA, progress="", ...) { if (! inMemory(x) ) { if ( fromDisk(x) ) { if (canProcessInMemory(x, 2)) { x <- readAll(x) } } else { stop('RasterLayer has no values') } } if ( inMemory(x) ) { x <- unique(x@data@values, incomparables=incomparables, progress="", ...) return(sort(x, na.last=na.last)) } else { u1 <- vector() u2 <- vector() tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='unique', progress=progress, ...) for (i in 1:tr$n) { u1 <- unique( c(u1, getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i])), incomparables=incomparables, ... ) if (length(u1) > 10000 ) { u2 <- unique(c(u1, u2), incomparables=incomparables, ...) u1 <- vector() } pbStep(pb, i) } pbClose(pb) return(sort(unique(c(u1, u2), incomparables=incomparables, ...), na.last=na.last)) } } ) setMethod('unique', signature(x='RasterStackBrick', incomparables='missing'), function(x, incomparables=FALSE, na.last=NA, progress="", ...) { if (! inMemory(x) ) { if (canProcessInMemory(x, 2)) { x <- readAll(x) } } if ( inMemory(x) ) { x <- unique(getValues(x), incomparables=incomparables, ...) # if (is.list(x)) { # for (i in 1:length(x)) { # x[[i]] <- sort(x[[i]], na.last=na.last) # } # } else { # xx <- vector(length=ncol(x), mode='list') # for (i in 1:ncol(x)) { # xx[[i]] <- sort(x[,i], na.last=na.last) # } # x <- xx # } return(x) } else { nl <- nlayers(x) un <- list(length=nl, mode='list') tr <- blockSize(x, n=2) pb <- pbCreate(tr$n, label='unique', progress=progress) un <- NULL for (i in 1:tr$n) { v <- unique( getValues(x, row=tr$row[i], nrows=tr$nrows[i]) ) un <- unique(rbind(v, un), incomparables=incomparables, ...) pbStep(pb, i) } pbClose(pb) return(un) } } ) raster/R/mosaic.R0000644000176200001440000001027214507510157013360 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # redesigned for multiple row processing # October 2011 # version 1 setMethod('mosaic', signature(x='Raster', y='Raster'), function(x, y, ..., fun, tolerance=0.05, filename="") { x <- c(x, y, list(...)) isRast <- sapply(x, function(x) inherits(x, 'Raster')) dotargs <- x[ !isRast ] x <- x[ isRast ] if (is.null(dotargs$datatype)) { dotargs$datatype <- .commonDataType(sapply(x, dataType)) } filename <- trim(filename) dotargs$filename <- filename nl <- max(unique(sapply(x, nlayers))) compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance) bb <- .unionExtent(x) if (nl > 1) { out <- brick(x[[1]], values=FALSE, nl=nl) } else { out <- raster(x[[1]]) } out <- setExtent(out, bb, keepres=TRUE, snap=FALSE) fun <- .makeTextFun(fun) if (inherits(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) } ) raster/R/connection.R0000644000176200001440000000371214507510157014245 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('readStart', signature(x='Raster'), function(x, ...) { if ( fromDisk(x) ) { return (.openConnection(x, ...)) } else { return(x) } } ) setMethod('readStart', signature(x='RasterStack'), function(x, ..., maxopen=100) { fd <- sapply(x@layers, fromDisk) ld <- sum(fd) if (isTRUE( ld > 0 & ld <= maxopen)) { d <- which(fd) for (i in d) { x@layers[[i]] <- readStart(x@layers[[i]], con.check=103, ...) } } x } ) .openConnection <- function(x, silent=TRUE, con.check=Inf, ...) { fn <- trim(x@file@name) driver <- .driver(x) if (driver == "gdal") { # attr(x@file, "con") <- rgdal::GDAL.open(fn, silent=silent) # x@file@open <- TRUE } else if (.isNativeDriver(driver)) { # R has a max of 128 connections if (length(getAllConnections()) < con.check) { fn <- .setFileExtensionValues(fn, driver) attr(x@file, "con") <- file(fn, "rb") x@file@open <- TRUE } } else if (driver == 'netcdf') { attr(x@file, 'con') <- ncdf4::nc_open(x@file@name, suppress_dimvals = TRUE) x@file@open <- TRUE # } else if (driver == 'ascii') { # cannot be opened } x } setMethod('readStop', signature(x='Raster'), function(x) { if ( fromDisk(x) ) { return (.closeConnection(x)) } else { return(x) } } ) setMethod('readStop', signature(x='RasterStack'), function(x) { d <- which(sapply(x@layers, fromDisk)) if (length(d) > 0) { for (i in d) { x@layers[[i]] <- readStop(x@layers[[i]]) } } x } ) .closeConnection <- function(x) { driver <- .driver(x) if (driver == "gdal") { #try( rgdal::closeDataset(x@file@con), silent = TRUE ) } else if (.isNativeDriver(driver)) { try( close(x@file@con), silent = TRUE ) } else if (driver == 'netcdf') { try( ncdf4::nc_close(x@file@con), silent=TRUE) } #else if (driver == 'ascii') { } x@file@open <- FALSE attr(x@file, 'con') <- NULL x # attr(x@file, "con" <- "") } raster/R/aggregate_3d.R0000644000176200001440000001173714507510157014430 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 # October 2012: Major overhaul (including C interface) # November 2012: fixed bug with expand=F # June 2014: support for aggregation over z (layers) in addition to x and y setMethod('aggregate', signature(x='Raster'), function(x, fact, fun='mean', expand=TRUE, na.rm=TRUE, filename="", ...) { fact <- round(fact) lf <- length(fact) if (lf == 1) { fact <- c(fact, fact, 1) } else if (lf == 2) { fact <- c(fact, 1) } else if (lf > 3) { stop('fact should have length 1, 2, or 3') } if (any(fact < 1)) { stop('fact should be > 0') } if (! any(fact > 1)) { warning('all fact(s) were 1, nothing to aggregate') return(x) } xfact <- fact[1] yfact <- fact[2] zfact <- fact[3] ncx <- ncol(x) nrx <- nrow(x) nlx <- nlayers(x) if (xfact > ncx) { warning('aggregation factor is larger than the number of columns') xfact <- ncx if (!na.rm) xfact <- xfact + 1 } if (yfact > nrx) { warning('aggregation factor is larger than the number of rows') yfact <- nrx if (!na.rm) yfact <- yfact + 1 } if (zfact > nlx) { warning('aggregation factor is larger than the number of layers') zfact <- nlx if (!na.rm) zfact <- zfact + 1 } if (expand) { rsteps <- as.integer(ceiling(nrx/yfact)) csteps <- as.integer(ceiling(ncx/xfact)) lsteps <- as.integer(ceiling(nlx/zfact)) lastcol <- ncx lastrow <- nrx lastlyr <- lsteps * zfact lyrs <- 1:nlx } else { rsteps <- as.integer(floor(nrx/yfact)) csteps <- as.integer(floor(ncx/xfact)) lsteps <- as.integer(floor(nlx/zfact)) lastcol <- min(csteps * xfact, ncx) lastrow <- min(rsteps * yfact, nrx) lastlyr <- min(lsteps * zfact, nlx) lyrs <- 1:lastlyr } ymn <- ymax(x) - rsteps * yfact * yres(x) xmx <- xmin(x) + csteps * xfact * xres(x) if (lsteps > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } extent(out) <- extent(xmin(x), xmx, ymn, ymax(x)) dim(out) <- c(rsteps, csteps, lsteps) ncout <- ncol(out) nlout <- nlayers(out) if (zfact == 1) { names(out) <- names(x) } if (! hasValues(x) ) { return(out) } fun <- .makeTextFun(fun) if (inherits(fun, 'character')) { op <- as.integer(match(fun, c('sum', 'mean', 'min', 'max')) - 1) } else { op <- NA } # note that it is yfact, xfact, zfact dims <- as.integer(c(lastrow, lastcol, length(lyrs), yfact, xfact, zfact)) if (is.na(op)) { if ( canProcessInMemory(x)) { v <- getValuesBlock(x, 1, lastrow, 1, lastcol, lyrs, format='m') v <- .Call("_raster_aggregate_get", v, as.integer(dims), PACKAGE='raster') v <- apply(v, 1, fun, na.rm=na.rm) out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, n=nlayers(x)*xfact*yfact, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 #tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { dims[1] <- as.integer(tr$nrows[i]) vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol, lyrs, format='m') vals <- .Call("_raster_aggregate_get", vals, as.integer(dims), PACKAGE='raster') vals <- apply(vals, 1, fun, na.rm=na.rm) out <- writeValues(out, matrix(vals, ncol=nlout), tr$write[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } # else if (!is.na(op)) { if ( canProcessInMemory(x)) { x <- getValuesBlock(x, 1, lastrow, 1, lastcol, format='m') out <- setValues(out, .Call("_raster_aggregate_fun", x, dims, as.integer(na.rm), op, PACKAGE='raster')) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } else { xx <- brick(x, values=FALSE) if (!expand) { nrow(xx) <- (nrow(x) %/% yfact) * yfact } tr <- blockSize(xx, minrows=yfact) st <- round(tr$nrows[1] / yfact) * yfact tr$n <- ceiling(lastrow / st) tr$row <- c(1, cumsum(rep(st, tr$n-1))+1) tr$nrows <- rep(st, tr$n) tr$write <- cumsum(c(1, ceiling(tr$nrows[1:(tr$n-1)]/yfact))) tr$nrows[tr$n] <- nrow(xx) - tr$row[tr$n] + 1 #tr$outrows <- ceiling(tr$nrows/yfact) pb <- pbCreate(tr$n, label='aggregate', ...) x <- readStart(x, ...) out <- writeStart(out, filename=filename, ...) for (i in 1:tr$n) { dims[1] = tr$nrows[i] vals <- getValuesBlock(x, tr$row[i], tr$nrows[i], 1, lastcol, format='m') vals <- .Call("_raster_aggregate_fun", vals, dims, na.rm, op, PACKAGE='raster') out <- writeValues(out, vals, tr$write[i]) pbStep(pb, i) } pbClose(pb) out <- writeStop(out) x <- readStop(x) return(out) } } ) raster/R/AAgeneric_functions.R0000644000176200001440000003467114507510157016024 0ustar liggesusers #if (!isGeneric("colSums")) {setGeneric("colSums", function(x, ...) standardGeneric("colSums"))} #if (!isGeneric("rowSums")) {setGeneric("rowSums", function(x, ...) standardGeneric("rowSums"))} if (!isGeneric("update")) {setGeneric("update", function(object, ...) standardGeneric("update"))} if (!isGeneric("stack")) { setGeneric("stack", function(x, ...) standardGeneric("stack"))} if (!isGeneric("as.raster")) { setGeneric("as.raster", function(x, ...) standardGeneric("as.raster"))} if (!isGeneric("all.equal")) { setGeneric("all.equal", function(target, current, ...) standardGeneric("all.equal"))} if (!isGeneric("blockSize")) {setGeneric("blockSize", function(x, ...) standardGeneric("blockSize"))} if (!isGeneric("extent")) { setGeneric("extent", function(x, ...) standardGeneric("extent")) } if (!isGeneric("hillShade")) {setGeneric("hillShade", function(x, ...) standardGeneric("hillShade"))} if (!isGeneric("rectify")) {setGeneric("rectify", function(x, ...) standardGeneric("rectify"))} if (!isGeneric("whiches.max")) {setGeneric("whiches.max", function(x, ...)standardGeneric("whiches.max"))} if (!isGeneric("whicheses.min")) {setGeneric("whiches.min", function(x, ...)standardGeneric("whiches.min"))} if (!isGeneric("origin<-")) {setGeneric("origin<-", function(x, value) standardGeneric("origin<-"))} if (!isGeneric("weighted.mean")) {setGeneric("weighted.mean", function(x, w, ...) standardGeneric("weighted.mean"))} if (!isGeneric("%in%")) { setGeneric("%in%", function(x, table) standardGeneric("%in%"))} if (!isGeneric("adjacent")) {setGeneric("adjacent", function(x, ...) standardGeneric("adjacent"))} if (!isGeneric("aggregate")) {setGeneric("aggregate", function(x, ...) standardGeneric("aggregate"))} if (!isGeneric("animate")) { setGeneric("animate", function(x, ...) standardGeneric("animate")) } if (!isGeneric("approxNA")) {setGeneric("approxNA", function(x, ...) standardGeneric("approxNA"))} if (!isGeneric("area")) {setGeneric("area", function(x, ...) standardGeneric("area"))} if (!isGeneric("as.data.frame")) { setGeneric("as.data.frame", function(x, row.names = NULL, optional = FALSE, ...) standardGeneric("as.data.frame")) } if (!isGeneric("as.factor")) {setGeneric("as.factor", function(x) standardGeneric("as.factor"))} if (!isGeneric("is.factor")) {setGeneric("is.factor", function(x) standardGeneric("is.factor"))} if (!isGeneric("atan2")) { setGeneric("atan2", function(y, x) standardGeneric("atan2"))} if (!isGeneric("bbox")) {setGeneric("bbox", function(obj) standardGeneric("bbox"))} if (!isGeneric("barplot")) {setGeneric("barplot", function(height,...) standardGeneric("barplot"))} if (!isGeneric("boundaries")) { setGeneric("boundaries", function(x, ...) standardGeneric("boundaries"))} if (!isGeneric("boxplot")) { setGeneric("boxplot", function(x, ...) standardGeneric("boxplot")) } if (!isGeneric("brick")) { setGeneric("brick", function(x, ...) standardGeneric("brick"))} if (!isGeneric("buffer")) {setGeneric("buffer", function(x, ...) standardGeneric("buffer"))} if (!isGeneric("calc")) {setGeneric("calc", function(x, fun, ...) standardGeneric("calc")) } if (!isGeneric("clamp")) {setGeneric("clamp", function(x, ...) standardGeneric("clamp")) } if (!isGeneric("click")) { setGeneric("click", function(x, ...) standardGeneric("click"))} if (!isGeneric("clump")) {setGeneric("clump", function(x, ...) standardGeneric("clump")) } if (!isGeneric("contour")) { setGeneric("contour", function(x,...) standardGeneric("contour"))} if ( !isGeneric("corLocal") ) { setGeneric("corLocal", function(x, y, ...) standardGeneric("corLocal"))} if (!isGeneric("couldBeLonLat")) { setGeneric("couldBeLonLat", function(x, ...) standardGeneric("couldBeLonLat"))} if (!isGeneric("cover")) {setGeneric("cover", function(x, y, ...) standardGeneric("cover"))} if (!isGeneric("crop")) { setGeneric("crop", function(x, y, ...) standardGeneric("crop"))} if (!isGeneric("crosstab")) { setGeneric("crosstab", function(x, y, ...) standardGeneric("crosstab"))} if (!isGeneric("crs")) { setGeneric("crs", function(x, ...) standardGeneric("crs")) } if (!isGeneric("crs<-")) { setGeneric("crs<-", function(x, ..., value) standardGeneric("crs<-")) } if (!isGeneric("cut")) {setGeneric("cut", function(x, ...) standardGeneric("cut"))} if (!isGeneric("direction")) {setGeneric("direction", function(x, ...) standardGeneric("direction"))} if (!isGeneric("density")) { setGeneric("density", function(x, ...) standardGeneric("density"))} if (!isGeneric("disaggregate")) {setGeneric("disaggregate", function(x, ...) standardGeneric("disaggregate"))} if (!isGeneric("distance")) {setGeneric("distance", function(x, y, ...)standardGeneric("distance"))} if (!isGeneric("erase")) {setGeneric("erase", function(x, y, ...) standardGeneric("erase"))} if (!isGeneric("extend")) {setGeneric("extend", function(x, y, ...) standardGeneric("extend"))} if (!isGeneric("extract")) { setGeneric("extract", function(x, y, ...) standardGeneric("extract"))} if (!isGeneric("flip")) { setGeneric("flip", function(x, ...) standardGeneric("flip")) } if (!isGeneric("focal")) { setGeneric("focal", function(x, ...) standardGeneric("focal"))} if (!isGeneric("freq")) {setGeneric("freq", function(x, ...) standardGeneric("freq"))} if (!isGeneric("geom")) { setGeneric("geom", function(x, ...) standardGeneric("geom"))} if (!isGeneric("gridDistance")) {setGeneric("gridDistance", function(x, ...) standardGeneric("gridDistance"))} if (!isGeneric("head")) { setGeneric("head", function(x, ...) standardGeneric("head"))} if (!isGeneric("hasValues")) { setGeneric("hasValues", function(x, ...) standardGeneric("hasValues"))} if (!isGeneric("inMemory")) {setGeneric("inMemory", function(x, ...) standardGeneric("inMemory"))} #if (!isGeneric("ifel")) {setGeneric("ifel", function(test, yes, no, ...) standardGeneric("ifel"))} if (!isGeneric("image")) {setGeneric("image", function(x,...) standardGeneric("image"))} if (!isGeneric("init")) {setGeneric("init", function(x, ...) standardGeneric("init"))} if (!isGeneric("interpolate")) { setGeneric("interpolate", function(object, ...) standardGeneric("interpolate"))} if (!isGeneric("intersect")) { setGeneric("intersect", function(x, y) standardGeneric("intersect"))} if (!isGeneric("isLonLat")) { setGeneric("isLonLat", function(x, ...) standardGeneric("isLonLat"))} if (!isGeneric("layerize")) { setGeneric("layerize", function(x, y, ...) standardGeneric("layerize"))} if (!isGeneric("metadata")) { setGeneric("metadata", function(x, ...) standardGeneric("metadata"))} if (!isGeneric("match")) { setGeneric("match", function(x, table, nomatch=NA_integer_, incomparables=NULL) standardGeneric("match"))} if (!isGeneric("mask")) { setGeneric("mask", function(x, mask, ...) standardGeneric("mask"))} if (!isGeneric(".median")) {setGeneric(".median", function(x, y, ...) standardGeneric(".median"))} if (!isGeneric("merge")) {setGeneric("merge", function(x, y, ...) standardGeneric("merge"))} if (!isGeneric("mosaic")) {setGeneric("mosaic", function(x, y, ...)standardGeneric("mosaic"))} if (!isGeneric("modal")) {setGeneric("modal", function(x, ...) standardGeneric("modal"))} if (!isGeneric("ncell")) { setGeneric("ncell", function(x) standardGeneric("ncell")) } if (!isGeneric("ncol")) { setGeneric("nrow", function(x) standardGeneric("nrow")) } if (!isGeneric("ncol<-")) { setGeneric("ncol<-", function(x, ..., value) standardGeneric("ncol<-")) } if (!isGeneric("nrow")) { setGeneric("nrow", function(x) standardGeneric("nrow")) } if (!isGeneric("nrow<-")) { setGeneric("nrow<-", function(x, ..., value) standardGeneric("nrow<-")) } if (!isGeneric("overlay")) { setGeneric("overlay", function(x, y, ...) standardGeneric("overlay"))} if (!isGeneric("origin")) { setGeneric("origin", function(x, ...) standardGeneric("origin")) } if (!isGeneric("pairs")) { setGeneric("pairs", function(x, ...) standardGeneric("pairs"))} if (!isGeneric("persp")) { setGeneric("persp", function(x,...) standardGeneric("persp")) } if (!isGeneric("plot")) {setGeneric("plot", function(x,y,...)standardGeneric("plot"))} if (!isGeneric("plotRGB")) { setGeneric("plotRGB", function(x, ...) standardGeneric("plotRGB"))} if (!isGeneric("predict")) {setGeneric("predict", function(object, ...) standardGeneric("predict"))} if (!isGeneric("quantile")) {setGeneric("quantile", function(x, ...)standardGeneric("quantile"))} if (!isGeneric("RGB")) {setGeneric("RGB", function(x, ...) standardGeneric("RGB"))} if ( !isGeneric("raster") ) {setGeneric("raster", function(x, ...) standardGeneric("raster"))} if (!isGeneric("rasterize")) {setGeneric("rasterize", function(x, y, ...) standardGeneric("rasterize"))} if (!isGeneric("readStart")) {setGeneric("readStart", function(x, ...) standardGeneric("readStart"))} if (!isGeneric("readStop")) {setGeneric("readStop", function(x) standardGeneric("readStop"))} if (!isGeneric("reclassify")) { setGeneric("reclassify", function(x, rcl, ...) standardGeneric("reclassify"))} if (!isGeneric("res")) { setGeneric("res", function(x) standardGeneric("res")) } if (!isGeneric("res<-")) { setGeneric("res<-", function(x, value) standardGeneric("res<-")) } if (!isGeneric("resample")) { setGeneric("resample", function(x, y, ...) standardGeneric("resample"))} if (!isGeneric("rotate")) { setGeneric("rotate", function(x, ...) standardGeneric("rotate"))} if (!isGeneric("sampleRegular")) { setGeneric("sampleRegular", function(x, size, ...) standardGeneric("sampleRegular"))} if (!isGeneric("sampleRandom")) { setGeneric("sampleRandom", function(x, size, ...) standardGeneric("sampleRandom"))} if (!isGeneric("sampleStratified")) {setGeneric("sampleStratified", function(x, size, ...) standardGeneric("sampleStratified"))} if (!isGeneric("select")) {setGeneric("select", function(x, ...) standardGeneric("select"))} if (!isGeneric("setMinMax")) {setGeneric("setMinMax", function(x, ...) standardGeneric("setMinMax")) } if (!isGeneric("shift")) {setGeneric("shift", function(x, ...) standardGeneric("shift"))} if (!isGeneric("stretch")) {setGeneric("stretch", function(x, ...) standardGeneric("stretch"))} if (!isGeneric("subset")) { setGeneric("subset", function(x, ...) standardGeneric("subset"))} if (!isGeneric("t")) { setGeneric("t", function(x) standardGeneric("t"))} if (!isGeneric("tail")) { setGeneric("tail", function(x, ...) standardGeneric("tail"))} if (!isGeneric("terrain")) { setGeneric("terrain", function(x, ...) standardGeneric("terrain"))} if (!isGeneric("text")) { setGeneric("text", function(x, ...) standardGeneric("text")) } if (!isGeneric("trim")) { setGeneric("trim", function(x, ...) standardGeneric("trim"))} if (!isGeneric("unique")) { setGeneric("unique", function(x, incomparables=FALSE, ...) standardGeneric("unique")) } if (!isGeneric("union")) {setGeneric("union", function(x, y)standardGeneric("union"))} if (!isGeneric("setValues")) {setGeneric("setValues", function(x, values, ...) standardGeneric("setValues"))} if (!isGeneric("values")) { setGeneric("values", function(x, ...) standardGeneric("values")) } if (!isGeneric("values<-")) { setGeneric("values<-", function(x, value) standardGeneric("values<-"))} if (!isGeneric("which.max")) {setGeneric("which.max", function(x)standardGeneric("which.max"))} if (!isGeneric("which.min")) {setGeneric("which.min", function(x)standardGeneric("which.min"))} if (!isGeneric("writeRaster")) {setGeneric("writeRaster", function(x, filename, ...) standardGeneric("writeRaster"))} if (!isGeneric("writeStart")) { setGeneric("writeStart", function(x, filename, ...) standardGeneric("writeStart"))} if (!isGeneric("writeStop")) { setGeneric("writeStop", function(x) standardGeneric("writeStop"))} if (!isGeneric("writeValues")) { setGeneric("writeValues", function(x, v, ...) standardGeneric("writeValues")) } if (!isGeneric("wkt")) { setGeneric("wkt", function(obj) standardGeneric("wkt")) } if (!isGeneric('symdif')) {setGeneric('symdif', function(x, y, ...) standardGeneric('symdif'))} if (!isGeneric("xres")) { setGeneric("xres", function(x) standardGeneric("xres")) } if (!isGeneric("yres")) { setGeneric("yres", function(x) standardGeneric("yres")) } if (!isGeneric("zonal")) {setGeneric("zonal", function(x, z, ...) standardGeneric("zonal"))} if (!isGeneric("zoom")) {setGeneric("zoom", function(x, ...)standardGeneric("zoom"))} if (!isGeneric("yFromRow")) { setGeneric("yFromRow", function(object, row) standardGeneric("yFromRow")) } if (!isGeneric("xFromCol")) { setGeneric("xFromCol", function(object, col) standardGeneric("xFromCol")) } if (!isGeneric("colFromX")) { setGeneric("colFromX", function(object, x) standardGeneric("colFromX")) } if (!isGeneric("rowFromY")) { setGeneric("rowFromY", function(object, y) standardGeneric("rowFromY")) } if (!isGeneric("cellFromXY")) { setGeneric("cellFromXY", function(object, xy) standardGeneric("cellFromXY")) } if (!isGeneric("cellFromRowCol")) { setGeneric("cellFromRowCol", function(object, row, col, ...) standardGeneric("cellFromRowCol")) } if (!isGeneric("cellFromRowColCombine")) { setGeneric("cellFromRowColCombine", function(object, row, col, ...) standardGeneric("cellFromRowColCombine")) } if (!isGeneric("xyFromCell")) { setGeneric("xyFromCell", function(object, cell, ...) standardGeneric("xyFromCell")) } if (!isGeneric("yFromCell")) { setGeneric("yFromCell", function(object, cell) standardGeneric("yFromCell")) } if (!isGeneric("xFromCell")) { setGeneric("xFromCell", function(object, cell) standardGeneric("xFromCell")) } if (!isGeneric("rowColFromCell")) { setGeneric("rowColFromCell", function(object, cell) standardGeneric("rowColFromCell")) } if (!isGeneric("rowFromCell")) { setGeneric("rowFromCell", function(object, cell) standardGeneric("rowFromCell")) } if (!isGeneric("colFromCell")) { setGeneric("colFromCell", function(object, cell) standardGeneric("colFromCell")) } # (!isGeneric("#")) { setGeneric("#", function(object) standardGeneric("#")) } if (!isGeneric("xmin")) {setGeneric("xmin", function(x) standardGeneric("xmin"))} if (!isGeneric("xmax")) {setGeneric("xmax", function(x) standardGeneric("xmax"))} if (!isGeneric("ymin")) {setGeneric("ymin", function(x) standardGeneric("ymin"))} if (!isGeneric("ymax")) {setGeneric("ymax", function(x) standardGeneric("ymax"))} if (!isGeneric("xmin<-")) { setGeneric("xmin<-", function(x, ..., value) standardGeneric("xmin<-")) } if (!isGeneric("xmax<-")) { setGeneric("xmax<-", function(x, ..., value) standardGeneric("xmax<-")) } if (!isGeneric("ymin<-")) { setGeneric("ymin<-", function(x, ..., value) standardGeneric("ymin<-")) } if (!isGeneric("ymax<-")) { setGeneric("ymax<-", function(x, ..., value) standardGeneric("ymax<-")) } raster/R/resample.R0000644000176200001440000000725014507510157013717 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod('resample', signature(x='Raster', y='Raster'), function(x, y, method="bilinear", filename="", ...) { # to do: compare projections of x and y ln <- names(x) nl <- nlayers(x) if (nl == 1) { y <- raster(y) if (method=='ngb') { colortable(y) <- colortable(x) } } else { y <- brick(y, values=FALSE, nl=nl) } if (!hasValues(x)) { return(y) } if (!method %in% c('bilinear', 'ngb')) { stop('invalid method') } if (method == 'ngb') method <- 'simple' skipaggregate <- isTRUE(list(...)$skipaggregate) if (!skipaggregate) { rres <- res(y) / res(x) resdif <- max(rres) if (resdif > 2) { ag <- pmax(1, floor(rres-1)) if (max(ag) > 1) { if (method == 'bilinear') { x <- aggregate(x, ag, 'mean') } else { x <- aggregate(x, ag, modal) } } } } e <- .intersectExtent(x, y, validate=TRUE) filename <- trim(filename) if (canProcessInMemory(y, 4*nl)) { inMemory <- TRUE v <- matrix(NA, nrow=ncell(y), ncol=nlayers(x)) } else { inMemory <- FALSE y <- writeStart(y, filename=filename, ... ) } if (.doCluster()) { cl <- getCluster() on.exit( returnCluster() ) nodes <- min(ceiling(y@nrows/10), length(cl)) # at least 10 rows per node message('Using cluster with ', nodes, ' nodes') utils::flush.console() tr <- blockSize(y, minblocks=nodes, n=nl*4*nodes) pb <- pbCreate(tr$n, label='resample', ...) clFun <- function(i) { #r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xy <- xyFromCell(y, cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, ncol(y)) ) .xyValues(x, xy, method=method) } parallel::clusterExport(cl, c('x', 'y', 'tr', 'method'), envir=environment()) .sendCall <- eval( parse( text="parallel:::sendCall") ) for (ni in 1:nodes) { .sendCall(cl[[ni]], clFun, list(ni), tag=ni) } if (inMemory) { for (i in 1:tr$n) { d <- .recvOneData(cl) if (! d$value$success) { stop('cluster error') } start <- cellFromRowCol(y, tr$row[d$value$tag], 1) end <- cellFromRowCol(y, tr$row[d$value$tag]+tr$nrows[d$value$tag]-1, y@ncols) v[start:end, ] <- d$value$value ni <- ni + 1 if (ni <= tr$n) { .sendCall(cl[[d$node]], clFun, list(ni), tag=ni) } pbStep(pb) } y <- setValues(y, v) if (filename != '') { writeRaster(y, filename, ...) } } else { for (i in 1:tr$n) { d <- .recvOneData(cl) y <- writeValues(y, d$value$value, tr$row[d$value$tag]) ni <- ni + 1 if (ni <= tr$n) { .sendCall(cl[[d$node]], clFun, list(ni), tag=ni) } pbStep(pb) } y <- writeStop(y) } } else { tr <- blockSize(y, n=nl*4) pb <- pbCreate(tr$n, label='resample', ...) if (inMemory) { for (i in 1:tr$n) { #r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xy <- xyFromCell(y, cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, ncol(y)) ) vals <- .xyValues(x, xy, method=method) start <- cellFromRowCol(y, tr$row[i], 1) end <- cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, y@ncols) v[start:end, ] <- vals pbStep(pb, i) } v <- setValues(y, v) if (filename != '') { v <- writeRaster(v, filename, ...) } pbClose(pb) names(v) <- ln return(v) } else { for (i in 1:tr$n) { #r <- tr$row[i]:(tr$row[i]+tr$nrows[i]-1) xy <- xyFromCell(y, cellFromRowCol(y, tr$row[i], 1) : cellFromRowCol(y, tr$row[i]+tr$nrows[i]-1, ncol(y)) ) vals <- .xyValues(x, xy, method=method) y <- writeValues(y, vals, tr$row[i]) pbStep(pb, i) } y <- writeStop(y) } } pbClose(pb) names(y) <- ln return(y) } ) raster/R/bind.R0000644000176200001440000002006214507510157013017 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric("bind")) { setGeneric("bind", function(x, y, ...) standardGeneric("bind")) } setMethod('bind', signature(x='data.frame', y='missing'), function(x, y, ..., variables=NULL) { if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } } return(x) } ) setMethod('bind', signature(x='data.frame', y='data.frame'), function(x, y, ..., variables=NULL) { x <- .frbind(x, y) if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } else { variables <- NULL } } dots <- list(...) if (length(dots) > 1) { for (i in 1:length(dots)) { d <- dots[[i]] if (!inherits(d, 'data.frame')) { next } if (!is.null(variables)) { d <- d[, which(colnames(d) %in% variables), drop=FALSE] } if (nrow(d) > 0) { x <- .frbind(x, d) } } } x } ) setMethod('bind', signature(x='matrix', y='missing'), function(x, y, ..., variables=NULL) { if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } } return(x) } ) setMethod('bind', signature(x='matrix', y='matrix'), function(x, y, ..., variables=NULL) { x <- .frbindMatrix(x, y) if (!is.null(variables)) { variables <- as.character(stats::na.omit(variables)) if (length(variables) > 1) { x <- x[, which(colnames(x) %in% variables), drop=FALSE] } else { variables <- NULL } } dots <- list(...) if (length(dots) > 1) { for (i in 1:length(dots)) { d <- dots[[i]] if (!inherits(d, 'data.frame')) { next } if (!is.null(variables)) { d <- d[, which(colnames(d) %in% variables), drop=FALSE] } if (nrow(d) > 0) { x <- .frbindMatrix(x, d) } } } x } ) setMethod('bind', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ..., keepnames=FALSE) { prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x <- list(x, y, ...) for (i in 1:length(x)) { if (!inherits(x[[i]], "SpatialPolygons")) { stop("all additional arguments must be SpatialPolygons") } x[[i]]@proj4string <- sp::CRS(as.character(NA)) } rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn, use.names = FALSE)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialPolygons')) { x <- do.call( rbind, x) if (inherits(x, "Spatial")) { x@proj4string <- prj } return(x) } if (all(cls == 'SpatialPolygonsDataFrame')) { dat <- lapply( x, function(x) { methods::slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialPolygons')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) x <- sp::SpatialPolygonsDataFrame(x, dat) x@proj4string <- prj return(x) } dat <- NULL # dataFound <- FALSE for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { # dataFound <- TRUE if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:length(x[[i]]@polygons),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat) + length(x[[i]])),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialPolygons')) x <- do.call(rbind, x) x <- sp::SpatialPolygonsDataFrame(x, dat, match.ID=FALSE) x@proj4string <- prj x } ) setMethod('bind', signature(x='SpatialLines', y='SpatialLines'), function(x, y, ..., keepnames=FALSE) { prj <- x@proj4string if (is.na(prj)) prj <- y@proj4string x <- list(x, y, ...) for (i in 1:length(x)) { if (!inherits(x[[i]], "SpatialLines")) { stop("all additional arguments must be SpatialLines") } x[[i]]@proj4string <- sp::CRS(as.character(NA)) } rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn, use.names = FALSE)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialLines')) { x <- do.call( rbind, x) x@proj4string <- prj return(x) } if (all(cls == 'SpatialLinesDataFrame')) { dat <- lapply( x, function(x) { methods::slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialLines')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) x <- sp::SpatialLinesDataFrame(x, dat) x@proj4string <- prj return(x) } dat <- NULL # dataFound <- FALSE for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { # dataFound <- TRUE if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:length(x[[i]]@lines),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat) + length(x[[i]])), ] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialLines')) x <- do.call(rbind, x) x <- sp::SpatialLinesDataFrame(x, dat, match.ID=FALSE) x@proj4string <- prj x } ) setMethod('bind', signature(x='SpatialPoints', y='SpatialPoints'), function(x, y, ..., keepnames=FALSE) { x <- list(x, y, ...) rwn <- lapply(x, row.names) i <- sapply(rwn, length) > 0 if (!all(i)) { if (!any(i)) { return(x[[1]]) } x <- x[i] if (length(x) == 1) { return( x[[1]] ) } } ln <- sapply(rwn, length) rnu <- .uniqueNames(unlist(rwn, use.names = FALSE)) end <- cumsum(ln) start <- c(0, end[-length(end)]) + 1 for (i in 1:length(x)) { if (keepnames) { if (! all(rnu[start[i]:end[i]] == rwn[[i]]) ) { row.names(x[[i]]) <- rnu[start[i]:end[i]] } } else { row.names(x[[i]]) <- as.character(start[i]:end[i]) } } cls <- sapply(x, class) if (all(cls == 'SpatialPoints')) { return( do.call( rbind, x)) } if (all(cls == 'SpatialPointsDataFrame')) { dat <- lapply( x, function(x) { methods::slot(x, 'data') } ) dat <- do.call(.frbind, dat) x <- sapply(x, function(y) as(y, 'SpatialPoints')) x <- do.call( rbind, x) rownames(dat) <- row.names(x) return( sp::SpatialPointsDataFrame(x, dat) ) } dat <- NULL for (i in 1:length(x)) { if (.hasSlot(x[[i]], 'data')) { if (is.null(dat)) { dat <- x[[i]]@data } else { dat <- .frbind(dat, x[[i]]@data) } } else { if ( is.null(dat)) { dat <- data.frame() dat[1:nrow(x[[i]]@coords),] <- NA rownames(dat) <- row.names(x[[i]]) } else { dat[(nrow(dat)+1):(nrow(dat)+nrow(x[[i]]@coords)),] <- NA } } } # if (! dataFound ) { return( do.call(rbind, x) ) } x <- sapply(x, function(x) as(x, 'SpatialPoints')) x <- do.call(rbind, x) sp::SpatialPointsDataFrame(x, dat) } ) setMethod('bind', signature(x='list', y='missing'), function(x, y, ..., keepnames=FALSE) { if (length(x) < 2) { return(unlist(x)) } names(x)[1:2] <- c('x', 'y') x$keepnames <- keepnames do.call(bind, x) } ) raster/R/distanceToEdge.R0000644000176200001440000000114514507510157014766 0ustar liggesusers .distToEdge <- function(x) { xy1 <- xyFromCell(x, 1) xy2 <- xyFromCell(x, ncell(x)) a <- cbind(xFromCol(x, 1), yFromRow(x, 1:nrow(x))) b <- cbind(xFromCol(x, 2), yFromRow(x, 1:nrow(x))) dX <- pointDistance(a,b,longlat=T) m = matrix(1:ncol(x), nrow=nrow(x), ncol=ncol(x), byrow=T) m <- m * dX z <- raster(x) z[] <- m z2 <- flip(z, 'x') z <- min(z, z2) dY1 <- pointDistance(xy1, cbind(xy1[1], yFromRow(x, 1:nrow(x))), longlat=T) dY2 <- pointDistance(xy2, cbind(xy2[1], yFromRow(x, 1:nrow(x))), longlat=T) dY <- pmin(dY1, dY2) b <- raster(x) b[] <- rep(dY, each=ncol(x)) d <- min(z,b) d } raster/R/sampleRegular.R0000644000176200001440000001256114507510157014713 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2009 # Version 0.9 # Licence GPL v3 setMethod('sampleRegular', signature(x='Raster'), function( x, size, ext=NULL, cells=FALSE, xy=FALSE, asRaster=FALSE, sp=FALSE, ...) { stopifnot(hasValues(x) | isTRUE(xy)) size <- round(size) stopifnot(size > 0) nl <- nlayers(x) rotated <- rotated(x) if (is.null(ext)) { rcut <- raster(x) firstrow <- 1 lastrow <- nrow(rcut) firstcol <- 1 lastcol <- ncol(rcut) } else { rcut <- crop(raster(x), ext) ext <- extent(rcut) yr <- yres(rcut) xr <- xres(rcut) firstrow <- rowFromY(x, ext@ymax-0.5 *yr) lastrow <- rowFromY(x, ext@ymin+0.5*yr) firstcol <- colFromX(x, ext@xmin+0.5*xr) lastcol <- colFromX(x, ext@xmax-0.5*xr) } allx <- FALSE if (size >= ncell(rcut)) { if (!is.null(ext)) { x <- crop(x, ext) } if (asRaster & !rotated) { return(x) } nr <- nrow(rcut) nc <- ncol(rcut) allx <- TRUE } else { Y <- X <- sqrt(ncell(rcut)/size) nr <- max(1, floor((lastrow - firstrow + 1) / Y)) nc <- max(1, floor((lastcol - firstcol + 1) / X)) rows <- (lastrow - firstrow + 1)/nr * 1:nr + firstrow - 1 rows <- rows - (0.5 * (lastrow - firstrow + 1)/nr) cols <- (lastcol - firstcol + 1)/nc * 1:nc + firstcol - 1 cols <- cols - (0.5 * (lastcol - firstcol + 1)/nc) cols <- unique(round(cols)) rows <- unique(round(rows)) cols <- cols[cols > 0] rows <- rows[rows > 0] nr <- length(rows) nc <- length(cols) } hv <- hasValues(x) # if (fromDisk(x) & useGDAL & hv) { # if ( any(rotated | .driver(x, FALSE) != 'gdal') ) { # useGDAL <- FALSE # } else { # offs <- c(firstrow,firstcol)-1 # reg <- c(nrow(rcut), ncol(rcut))-1 # if ( nl > 1 ) { # v <- matrix(NA, ncol=nl, nrow=prod(nr, nc)) # for (i in 1:nl) { # xx <- x[[i]] # con <- rgdal::GDAL.open(xx@file@name, silent=TRUE) # band <- bandnr(xx) # vv <- rgdal::getRasterData(con, band=band, offset=offs, region.dim=reg, output.dim=c(nr, nc)) # rgdal::closeDataset(con) # if (xx@data@gain != 1 | xx@data@offset != 0) { # vv <- vv * xx@data@gain + xx@data@offset # } # if (xx@file@nodatavalue < 0) { # vv[vv <= xx@file@nodatavalue] <- NA # } else { # vv[vv == xx@file@nodatavalue] <- NA # } # v[, i] <- vv # } # } else { # band <- bandnr(x) # con <- rgdal::GDAL.open(x@file@name, silent=TRUE) # v <- rgdal::getRasterData(con, band=band, offset=offs, region.dim=reg, output.dim=c(nr, nc)) # rgdal::closeDataset(con) # v <- matrix(v, ncol=1) # colnames(v) <- names(x) # if (x@data@gain != 1 | x@data@offset != 0) { # v <- v * x@data@gain + x@data@offset # } # if (.naChanged(x)) { # if (x@file@nodatavalue < 0) { # v[v <= x@file@nodatavalue] <- NA # } else { # v[v == x@file@nodatavalue] <- NA # } # } # } # if (asRaster) { # if (is.null(ext)) { # outras <- raster(x) # } else { # outras <- raster(ext) # crs(outras) <- crs(x) # } # nrow(outras) <- nr # ncol(outras) <- nc # if (nl > 1) { # outras <- brick(outras, nl=nl) # outras <- setValues(outras, v) # } else { # outras <- setValues(outras, as.vector(v)) # } # names(outras) <- names(x) # if (any(is.factor(x))) { # levels(outras) <- levels(x) # } # return(outras) # } else { # if (cells) { # warning("'cells=TRUE' is ignored when 'useGDAL=TRUE'") # } # if (xy) { # warning("'xy=TRUE' is ignored when 'useGDAL=TRUE'") # } # if (sp) { # warning("'sp=TRUE' is ignored when 'useGDAL=TRUE'") # } # return( v ) # } # } # } if (allx) { cell <- 1:ncell(rcut) } else { cell <- cellFromRowCol(x, rep(rows, each=nc), rep(cols, times=nr)) } if (asRaster) { if (rotated) { if (is.null(ext)) { outras <- raster(extent(x)) } else { outras <- raster(ext) crs(outras) <- crs(x) } ncol(outras) <- nc nrow(outras) <- nr xy <- xyFromCell(outras, 1:ncell(outras)) if (hv) { m <- .xyValues(x, xy) } else { m <- NA } } else { if (allx) { if (!is.null(ext)) { return(crop(x, ext)) } else { return(x) } } cell <- cellFromRowCol(x, rep(rows, each=nc), rep(cols, times=nr)) if (hv) { m <- .cellValues(x, cell) } else { m <- NA } if (is.null(ext)) { outras <- raster(x) } else { outras <- raster(ext) crs(outras) <- crs(x) } nrow(outras) <- nr ncol(outras) <- nc } if (nl > 1) { outras <- brick(outras, nl=nl) } outras <- setValues(outras, m) names(outras) <- names(x) if (any(is.factor(x))) { levels(outras) <- levels(x) } return(outras) } else { if (allx) { cell <= 1:ncell(rcut) } else { cell <- cellFromRowCol(x, rep(rows, each=nc), rep(cols, times=nr)) } m <- NULL nstart <- 1 if (xy) { m <- xyFromCell(x, cell) nstart <- 3 } if (cells) { m <- cbind(m, cell=cell) nstart <- nstart + 1 } if (hv) { m <- cbind(m, .cellValues(x, cell)) colnames(m)[nstart:(nstart+nl-1)] <- names(x) } if (sp) { if (hv) { m <- sp::SpatialPointsDataFrame(xyFromCell(x, cell), data.frame(m), proj4string=.getCRS(x)) } else { m <- sp::SpatialPoints(xyFromCell(x, cell), proj4string=.getCRS(x)) } } return(m) } } ) raster/R/readRasterBrick.R0000644000176200001440000001654114507510157015161 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 1.0 # Licence GPL v3 .readRasterBrickValues <- function(object, startrow, nrows=1, startcol=1, ncols=ncol(object)) { if (nrows < 1) { stop("nrows should be > 1") } startrow <- min(max(1, round(startrow)), object@nrows) endrow <- min(object@nrows, startrow+nrows-1) nrows <- endrow - startrow + 1 if (ncols < 1) { stop("ncols should be > 1") } startcol <- min(max(1, round(startcol)), object@ncols) endcol <- min(object@ncols, startcol+ncols-1) ncols <- endcol - startcol + 1 if (.isNativeDriver(object@file@driver)) { getBSQData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) { if (c==1 & ncols==raster@ncols ) { if (r==1 & nrows==raster@nrows) { nc <- nrows*ncols*raster@data@nlayers seek(raster@file@con, raster@file@offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) dim(result) <- c(nrows*ncols, raster@data@nlayers) } else { ncells <- nrows*ncols result <- matrix(nrow=ncells, ncol=raster@data@nlayers) for (b in 1:raster@data@nlayers) { offset <- raster@file@offset + (b-1) * raster@ncols * raster@nrows + (r-1) * raster@ncols seek(raster@file@con, offset * dsize) result[,b] <- readBin(raster@file@con, what=dtype, n=ncells, dsize, dsign, endian=raster@file@byteorder) } } } else { nc <- nrows*ncols result <- matrix(nrow=nc, ncol=raster@data@nlayers) res <- matrix(ncol=nrows, nrow=ncols) for (b in 1:raster@data@nlayers) { offset <- raster@file@offset + (b-1) * raster@ncols * raster@nrows + (r-1) * raster@ncols + (c-1) for (i in 1:nrows) { off <- offset + (i-1) * raster@ncols seek(raster@file@con, off * dsize) res[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } result[,b] <- as.vector(res) } } return( result ) } getBilData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) { if (c==1 & ncols==raster@ncols ) { nc <- nrows*ncols*raster@data@nlayers if (r==1 & nrows==raster@nrows) { seek(raster@file@con, raster@file@offset * dsize) res <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } else { offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) seek(raster@file@con, offset * dsize) res <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } } else { res <- matrix(ncol=nrows*raster@data@nlayers, nrow=ncols) offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) + (c-1) for (i in 1:ncol(res)) { off <- offset + (i-1) * raster@ncols seek(raster@file@con, off * dsize) res[,i] <- readBin(raster@file@con, what=dtype, n=ncols, dsize, dsign, endian=raster@file@byteorder) } res <- as.vector(res) } result <- matrix(nrow=ncols*nrows, ncol=nlayers(raster)) dim(res) <- c(ncols, raster@data@nlayers*nrows) a <- rep(1:raster@data@nlayers, nrows) for (b in 1:raster@data@nlayers) { result[,b] <- as.vector(res[,a==b]) } return(result) } getBipData <- function(raster, r, nrows, c, ncols, dtype, dsize, dsign) { if (c==1 & ncols==raster@ncols ) { nc <- nrows*ncols*raster@data@nlayers if (r==1 & nrows==raster@nrows) { seek(raster@file@con, raster@file@offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } else { offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) seek(raster@file@con, offset * dsize) result <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } } else { nc <- ncols*raster@data@nlayers result <- matrix(ncol=nrows, nrow=ncols*raster@data@nlayers) offset <- raster@file@offset + raster@data@nlayers * raster@ncols * (r-1) for (i in 1:nrows) { off <- offset + (i-1) * raster@data@nlayers * raster@ncols + (c-1) * raster@data@nlayers seek(raster@file@con, off * dsize) result[,i] <- readBin(raster@file@con, what=dtype, n=nc, dsize, dsign, endian=raster@file@byteorder) } result <- as.vector(result) } dim(result) <- c(raster@data@nlayers, nrows*ncols) t(result) } if (! object@file@toptobottom ) { stop('bottom-to-top data not supported for RasterBrick objects') } dtype <- substr(object@file@datanotation, 1, 3) if (dtype == "INT" | dtype == "LOG" ) { dtype <- "integer" } else { dtype <- "numeric" } dsize <- dataSize(object@file@datanotation) dsign <- dataSigned(object@file@datanotation) if (dsize > 2) { dsign <- TRUE } is.open <- object@file@open if (!is.open) { object <- readStart(object) } if (object@data@nlayers > 1) { bo <- object@file@bandorder if (bo == 'BSQ') { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } else if (bo == 'BIL') { result <- getBilData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } else if (bo == 'BIP') { result <- getBipData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } } else { result <- getBSQData(object, r=startrow, nrows=nrows, c=startcol, ncols=ncols, dtype=dtype, dsize=dsize, dsign=dsign) } if (!is.open) { object <- readStop(object) } # result[is.nan(result)] <- NA if (object@file@datanotation == 'INT4U') { i <- !is.na(result) & result < 0 result[i] <- 2147483647 - result[i] } if (dtype == 'numeric') { result[result <= (0.999999 * object@file@nodatavalue)] <- NA result[is.nan(result)] <- NA } else { result[result == object@file@nodatavalue ] <- NA } if (dtype == 'logical') { result <- as.logical(result) } } else if (object@file@driver == 'netcdf') { result <- .readRowsBrickNetCDF(object, startrow, nrows, startcol, ncols) # } else if (object@file@driver == 'big.matrix') { # # b <- attr(object@file, 'big.matrix') # start <- cellFromRowCol(object, startrow, startcol) # end <- cellFromRowCol(object, endrow, endcol) # result <- b[start:end, ] } else { #use GDAL # offs <- c((startrow - 1), (startcol - 1)) # reg <- c(nrows, ncols) # con <- rgdal::GDAL.open(object@file@name, silent = TRUE) ## result <- rgdal::getRasterData(con, offset=offs, region.dim=reg) ## result <- do.call(cbind, lapply(1:nlayers(object), function(i) as.vector(result[,,i]))) ## just as fast, it seems: # result <- matrix(nrow = ncols * nrows, ncol = nlayers(object)) # for (b in 1:object@data@nlayers) { # result[, b] <- rgdal::getRasterData(con, offset = offs, # region.dim = reg, band = b) # } # rgdal::closeDataset(con) # result[result == object@file@nodatavalue] <- NA object <- rast(object) readStart(object) result <- readValues(object, startrow, nrows, startcol, ncols, mat=TRUE, dataframe=FALSE) result[is.nan(result)] <- NA readStop(object) } ## terra adjusts #if (inherits(object, "Raster")) { # if (object@data@gain != 1 | object@data@offset != 0) { # result <- result * object@data@gain + object@data@offset # } #} colnames(result) <- names(object) return(result) } raster/R/hdrIDRISI.R0000644000176200001440000000421514507510157013566 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2009 # Version 0.9 # Licence GPL v3 .writeHdrIDRISI <- function(x, old=FALSE) { hdrfile <- filename(x) hdrfile <- .setFileExtensionHeader(hdrfile, 'IDRISI') dtype <- .shortDataType(x@file@datanotation) dsize <- dataSize(x) if (dataType(x) == 'INT1U') { pixtype <- 'byte' } else if (dataType(x) == 'INT2S') { pixtype <- 'integer' } else { pixtype <- 'real' } if (couldBeLonLat(x)) { refsystem <- 'latlong' refunits <- 'degrees'; } else { refsystem <- 'plane'; refunits <- 'm'; } thefile <- file(hdrfile, "w") # open an txt file connectionis if (!old) cat('file format : IDRISI Raster A.1\n', file = thefile) cat('file title : ', names(x), "\n", sep='', file = thefile) cat('data type : ', pixtype, "\n", sep='', file = thefile) cat('file type : binary\n', sep='', file = thefile) cat('columns : ', ncol(x), "\n", sep='', file = thefile) cat('rows : ', nrow(x), "\n", sep='', file = thefile) cat('ref. system : ', refsystem, "\n", sep='', file = thefile) cat('ref. units : ', refunits, "\n", sep='', file = thefile) cat('unit dist. : 1.0000000', "\n", sep='', file = thefile) cat('min. X : ', as.character(xmin(x)), "\n", sep='', file = thefile) cat('max. X : ', as.character(xmax(x)), "\n", sep='', file = thefile) cat('min. Y : ', as.character(ymin(x)), "\n", sep='', file = thefile) cat('max. Y : ', as.character(ymax(x)), "\n", sep='', file = thefile) cat("pos'n error : unknown\n", file = thefile) cat('resolution : ', xres(x), "\n", sep='', file = thefile) cat('min. value : ', minValue(x), "\n", sep='', file = thefile) cat('max. value : ', maxValue(x), "\n", sep='', file = thefile) if (!old) cat('display min : ', minValue(x), "\n", sep='', file = thefile) if (!old) cat('display max : ', maxValue(x), "\n", sep='', file = thefile) cat('value units : unspecified\n', file = thefile) cat('value error : unknown\n', file = thefile) cat('flag value : ', .nodatavalue(x), "\n", sep='', file = thefile) cat("flag def'n : no data\n", file = thefile) cat('legend cats : 0\n', file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/select.R0000644000176200001440000000542114507510157013364 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 if (!isGeneric("select")) { setGeneric("select", function(x, ...) standardGeneric("select")) } setMethod('select', signature(x='Raster'), function(x, use='rec', ...) { use <- substr(tolower(use), 1, 3) stopifnot(use %in% c('rec', 'pol')) if (use == 'rec') { e <- drawExtent() int <- intersect(e, extent(x)) if (is.null(int)) { x <- NULL } else { x <- crop(x, e) } } else { e <- drawPoly() int <- intersect(extent(x), e) if (is.null(int)) { x <- NULL } else { x <- crop(x, e) x <- mask(x, e) } } x } ) setMethod('select', signature(x='Spatial'), function(x, use='rec', draw=TRUE, col='cyan', size=2, ...) { use <- substr(tolower(use), 1, 3) stopifnot(use %in% c('rec', 'pol')) if (use == 'rec') { e <- as(drawExtent(), 'SpatialPolygons') } else { e <- drawPoly() } e@proj4string <- x@proj4string int <- intersect(extent(e), extent(x)) if (is.null(int)) { return( NULL ) } if (inherits(x, 'SpatialPolygons')) { #valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) #int <- rgeos::gIntersects(x, e, byid=TRUE) int <- relate(vect(x), vect(e), "intersects") int <- apply(int, 2, any) if (any(int)) { x <- x[int, ] if (draw) { sp::plot(x, add=TRUE, border=col, lwd=size) } } else { x <- NULL } } else if (inherits(x, 'SpatialLines')) { #valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) #int <- rgeos::gIntersects(x, e, byid=TRUE) int <- relate(vect(x), vect(e), "intersects") int <- apply(int, 2, any) if (any(int)) { x <- x[int, ] if (draw) { sp::plot(x, add=TRUE, col=col, lwd=size) } } else { x <- NULL } } else if (inherits(x, 'SpatialGrid')) { cls <- class(x) if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPointsDataFrame') } else { x <- as(x, 'SpatialPoints') } i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { x <- x[i,] sp::gridded(x) <- TRUE x <- as(x, cls) if (draw) { sp::plot(x, col=col, cex=size, add=TRUE) } } else { x <- NULL } } else if (inherits(x, 'SpatialPixels')) { cls <- class(x) if (.hasSlot(x, 'data')) { x <- as(x, 'SpatialPointsDataFrame') } else { x <- as(x, 'SpatialPoints') } i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { x <- x[i,] x <- as(x, cls) if (draw) { points(x, col=col, cex=size) } } else { x <- NULL } } else { # SpatialPoints i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { x <- x[i,] if (draw) { points(x, col=col, cex=size) } } else { x <- NULL } } x } ) raster/R/rasterizePoints.R0000644000176200001440000001303614507510157015313 0ustar liggesusers# Author: Robert J. Hijmans, Paul Hiemstra, Steven Mosher # Date : January 2009 # Version 0.9 # Licence GPL v3 .pointsToRaster <- function(xy, r, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...) { rs <- raster(r) if (mask & update) { stop('use either "mask=TRUE" OR "update=TRUE", or neither') } else if (mask) { oldraster <- r } else if (update) { oldraster <- r if (!is.numeric(updateValue)) { if (is.na(updateValue)) { updateValue <- 'NA' } else if (!(updateValue == 'NA' | updateValue == '!NA' | updateValue == 'all')) { stop('updateValue should be either "all", "NA", "!NA"') } } } if (is.character(fun)) { if (!(fun %in% c('first', 'last', 'sum', 'min', 'max', 'count'))) { stop('invalid value for fun') } if (fun == 'sum') { fun <- sum } else if (fun == 'min') { fun <- min } else if (fun == 'max') { fun <- max } else { if (na.rm) { if (fun == 'first') { fun <- function(x, ...) { # stats::na.omit(x[1]) # fix by Daniel Schlapfer stats::na.omit(x)[1] } } else if (fun == 'last') { fun <- function(x, ...) { x <- stats::na.omit(x); x[length(x)] } } else if (fun == 'count') { fun <- function(x, ...) length(stats::na.omit(x)) } } else { if (fun == 'first') { fun <- function(x, ...) { x[1] } } else if (fun == 'last') { fun <- function(x, ...) { # x[length(x)] # fix by Daniel Schlapfer x <- stats::na.omit(x) if (length(x) > 0) { x[length(x)] } else { NA } } } else if (fun == 'count') { fun <- function(x, ...) length(x) } } } } points <- .pointsToMatrix(xy) field <- .getPutVals(xy, field, nrow(points), mask) xy <- points nres <- max(length(fun(1)), length(fun(1:5))) ncols <- 1 if (NCOL(field) > 1) { if (nres > 1) stop('Either use a single function for "fun", or a single vector for "field"') nres <- ncols <- ncol(field) } else { if (is.atomic(field) & length(field)==1) { field <- rep(field, dim(xy)[1]) } if (nrow(xy) != NROW(field)) { stop('number of points does not match the number of fields') } } cells <- cellFromXY(rs, xy) # todisk <- TRUE todisk <- FALSE if (!canProcessInMemory(rs, 2 * nres)) { if (filename == '') { filename <- rasterTmpFile() } todisk <- TRUE } if (todisk) { rows <- rowFromCell(rs, cells) cols <- colFromCell(rs, cells) xyarc <- cbind(xy, rows, cols, field) urows <- unique(rows) # urows <- urows[order(urows)] if (nres==1) { dna <- vector(length=ncol(rs)) dna[] <- background } else { rs <- brick(rs) # return a'RasterBrick' rs@data@nlayers <- nres if (ncols > 1) { names(rs) <- colnames(field) } dna <- matrix(background, nrow=ncol(rs), ncol=nres) datacols <- 5:ncol(xyarc) } pb <- pbCreate(nrow(rs), ...) rs <- writeStart(rs, filename=filename, ...) for (r in 1:rs@nrows) { d <- dna if (r %in% urows) { ss <- subset(xyarc, xyarc[,3] == r) #ucols <- unique(ss[,5]) #for (c in 1:length(ucols)) { # sss <- subset(ss, ss[,5] == ucols[c] ) # d[ucols[c]] <- fun(sss[,3]) #} if (ncols > 1) { v <- aggregate(ss[,datacols,drop=FALSE], list(ss[,4]), fun, na.rm=na.rm) cells <- as.numeric(v[,1]) d[cells, ] <- as.matrix(v)[,-1] } else { v <- tapply(ss[,5], ss[,4], fun, na.rm=na.rm) cells <- as.numeric(rownames(v)) if (nres > 1) { v <- as.matrix(v) v <- t(apply(v, 1, function(x) x[[1]])) # Reshape the data if more than one value is returned by 'fun' d[cells, ] <- v } else { d[cells] <- v } } } # need to check if nlayers matches ncols (how many layers returned?) if (mask) { oldvals <- getValues(oldraster, r) ind <- which(is.na(d)) oldvals[ind] <- NA d <- oldvals } else if (update) { oldvals <- getValues(oldraster, r) if (updateValue == "all") { ind <- which(!is.na(d)) } else if (updateValue == "zero") { ind <- which(oldvals==0 & !is.na(d)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { ind <- which(!is.na(oldvals) & !is.na(d)) } oldvals[ind] <- d[ind] d <- oldvals } rs <- writeValues(rs, d, r) pbStep(pb, r) } rs <- writeStop(rs) pbClose(pb) } else { v <- aggregate(field, list(cells), fun, na.rm=na.rm) cells <- as.numeric(v[,1]) v <- as.matrix(v)[,-1,drop=FALSE] if(inherits(v[1], "list")) { v <- t(apply(v, 1, function(x) x[[1]])) # Reshape the data if more than one value is returned by 'fun' } if (ncol(v) > 1) { vv <- matrix(background, nrow=ncell(rs), ncol=dim(v)[2]) vv[cells, ] <- v rs <- brick(rs) # return a'RasterBrick' } else { vv <- 1:ncell(rs) vv[] <- background vv[cells] <- v } if (mask) { oldvals <- getValues(oldraster) ind <- which(is.na(vv)) oldvals[ind] <- NA vv <- oldvals } else if (update) { oldvals <- getValues(oldraster) if (updateValue == "all") { ind <- which(!is.na(vv)) } else if (updateValue == "zero") { ind <- which(oldvals==0 & !is.na(vv)) } else if (updateValue == "NA") { ind <- which(is.na(oldvals)) } else { ind <- which(!is.na(oldvals) & !is.na(vv)) } oldvals[ind] <- vv[ind] vv <- oldvals } rs <- setValues(rs, vv) if (ncols > 1) { cn <- colnames(field) if (! is.null(cn)) { names(rs) <- cn } } if (filename != "") { rs <- writeRaster(rs, filename=filename, ...) } } return(rs) } raster/R/roundExtent.R0000644000176200001440000000144014507510157014421 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod("Math2", signature(x='Extent'), function (x, digits=0) { #digits <- max(0, round(digits)) x@xmin <- methods::callGeneric( x@xmin, digits) x@xmax <- methods::callGeneric( x@xmax, digits) x@ymin <- methods::callGeneric( x@ymin, digits) x@ymax <- methods::callGeneric( x@ymax, digits) validObject(x) return(x) } ) setMethod("floor", signature(x='Extent'), function (x) { x@xmin <- floor( x@xmin) x@xmax <- ceiling( x@xmax) x@ymin <- floor( x@ymin) x@ymax <- ceiling( x@ymax) return(x) } ) setMethod("ceiling", signature(x='Extent'), function (x) { x@xmin <- ceiling( x@xmin) x@xmax <- floor( x@xmax) x@ymin <- ceiling( x@ymin) x@ymax <- floor( x@ymax) return(x) } ) raster/R/gridDistance.R0000644000176200001440000001310614507510157014504 0ustar liggesusers# Author: Jacob van Etten # email jacobvanetten@yahoo.com # Date : May 2010 # Version 1.1 # Licence GPL v3 # RH: updated for igraph (from igraph0) # sept 23, 2012 setMethod("gridDistance", signature("RasterLayer"), function(x, origin, omit=NULL, filename="", ...) { if( !requireNamespace("igraph")) { stop('you need to install the igraph package to be able to use this function') } if (missing(origin)) { stop("you must supply an 'origin' argument") } if (! hasValues(x) ) { stop('cannot compute distance on a RasterLayer with no data') } lonlat <- couldBeLonLat(x) filename <- trim(filename) if (filename != "" & file.exists(filename)) { if (! .overwrite(...)) { stop("file exists. Use another name or 'overwrite=TRUE' if you want to overwrite it") } } # keep canProcessInMemory for debugging # need to test more to see how much igraph can deal with if ( canProcessInMemory(x, n=10) ) { out <- raster(x) x <- getValues(x) # to avoid keeping values in memory twice oC <- which(x %in% origin) ftC <- which(!(x %in% omit)) v <- .calcDist(out, ncell(out), ftC, oC, lonlat=lonlat) v[is.infinite(v)] <- NA out <- setValues(out, v) if (filename != "") { out <- writeRaster(out, filename, ...) } return(out) } else { tr <- blockSize(x, n=1) pb <- pbCreate(tr$n*2 - 1, ...) #going up r1 <- writeStart(raster(x), rasterTmpFile(), overwrite=TRUE) for (i in tr$n:1) { chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) startCell <- (tr$row[i]-1) * ncol(x) chunkSize <- length(chunk) oC <- which(chunk %in% origin) ftC <- which(!(chunk %in% omit)) if (length(ftC) != 0) { if (i < tr$n) { firstRowftC <- firstRowftC + chunkSize chunkDist <- .calcDist(x, chunkSize=chunkSize + ncol(x), ftC=c(ftC, firstRowftC), oC=c(oC, firstRowftC), perCell=c(rep(0,times=length(oC)),firstRowDist), startCell=startCell, lonlat=lonlat)[1:chunkSize] } else { chunkDist <- .calcDist(x, chunkSize=chunkSize, ftC=ftC, oC=oC, perCell=0, startCell=startCell, lonlat=lonlat) } } else { if (i < tr$n) { firstRowftC <- firstRowftC + chunkSize } chunkDist <- rep(NA, tr$nrows[i] * ncol(r1)) } firstRow <- chunk[1:ncol(x)] firstRowDist <- chunkDist[1:ncol(x)] firstRowftC <- which(!(firstRow %in% omit)) firstRowDist <- firstRowDist[firstRowftC] chunkDist[is.infinite(chunkDist)] <- NA r1 <- writeValues(r1, chunkDist, tr$row[i]) pbStep(pb) } r1 <- writeStop(r1) #going down out <- writeStart(raster(x), filename=filename, overwrite=TRUE, ...) for (i in 1:tr$n) { chunk <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) chunkSize <- length(chunk) startCell <- (tr$row[i]-1) * ncol(x) oC <- which(chunk %in% origin) ftC <- which(!(chunk %in% omit)) if (length(ftC) != 0) { if (i > 1) { chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) chunkDist[is.na(chunkDist)] <- Inf chunkDist <- pmin(chunkDist, .calcDist(x, chunkSize=chunkSize+ncol(x), ftC = c(lastRowftC, ftC+ncol(x)), oC = c(lastRowftC, oC+ncol(x)), perCell = c(lastRowDist, rep(0,times=length(oC))), startCell = startCell - ncol(x), lonlat=lonlat)[-(1:ncol(r1))]) } else { chunkDist <- getValues(r1, row=tr$row[i], nrows=tr$nrows[i]) chunkDist[is.na(chunkDist)] <- Inf chunkDist <- pmin(chunkDist, .calcDist(x, chunkSize=chunkSize, ftC=ftC, oC=oC, perCell=0, startCell=startCell, lonlat=lonlat)) } } else { chunkDist <- rep(NA, tr$nrows[i] * ncol(out)) } lastRow <- chunk[(length(chunk)-ncol(x)+1):length(chunk)] lastRowDist <- chunkDist[(length(chunkDist)-ncol(x)+1):length(chunkDist)] lastRowftC <- which(!(lastRow %in% omit)) lastRowDist <- lastRowDist[lastRowftC] chunkDist[is.infinite(chunkDist)] <- NA out <- writeValues(out, chunkDist, tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) return(out) } } ) .calcDist <- function(x, chunkSize, ftC, oC, perCell=0, startCell=0, lonlat) { if (length(oC) > 0) { #adj <- adjacency(x, fromCells=ftC, toCells=ftC, directions=8) adj <- adjacent(x, ftC, directions=8, target=ftC, pairs=TRUE) startNode <- max(adj)+1 #extra node to serve as origin adjP <- rbind(adj, cbind(rep(startNode, times=length(oC)), oC)) distGraph <- igraph::graph.edgelist(adjP, directed=TRUE) if (length(perCell) == 1) { if (perCell == 0) { perCell <- rep(0, times=length(oC)) } } if (lonlat) { distance <- pointDistance(xyFromCell(x,adj[,1]+startCell), xyFromCell(x,adj[,2]+startCell), lonlat=TRUE) igraph::E(distGraph)$weight <- c(distance, perCell) } else { sameRow <- which(rowFromCell(x, adj[,1]) == rowFromCell(x, adj[,2])) sameCol <- which(colFromCell(x, adj[,1]) == colFromCell(x, adj[,2])) igraph::E(distGraph)$weight <- sqrt(xres(x)^2 + yres(x)^2) igraph::E(distGraph)$weight[sameRow] <- xres(x) igraph::E(distGraph)$weight[sameCol] <- yres(x) igraph::E(distGraph)$weight[(length(adj[,1])+1):(length(adj[,1])+length(oC))] <- perCell } shortestPaths <- igraph::shortest.paths(distGraph, startNode) shortestPaths <- shortestPaths[-(length(shortestPaths))] #chop startNode off if (length(shortestPaths) < chunkSize) { #add Inf values where shortest.paths() leaves off before completing all nodes shortestPaths <- c(shortestPaths, rep(Inf, times=chunkSize-length(shortestPaths))) } } else { shortestPaths <- rep(Inf, times=chunkSize) } return(shortestPaths) } raster/R/rectify.R0000644000176200001440000000100114507510157013540 0ustar liggesusers# Robert J. Hijmans # May 2010 # Version 1.0 # Licence GPL v3 rotated <- function(x) { isTRUE(try(x@rotated, silent=TRUE)) } setMethod("rectify", signature(x="Raster"), function(x, ext, res, method='ngb', filename='', ...) { stopifnot(rotated(x)) if ( missing(ext)) { ext <- extent(x) } else { ext <- extent(ext) } out <- raster(ext) if ( missing(res)) { res(out) <- abs(raster::res(x)) } else { res(out) <- res } resample(x, out, method=method, filename=filename, ...) } ) raster/R/hist.R0000644000176200001440000000415014507510157013052 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 setMethod('hist', signature(x='Raster'), function(x, layer, maxpixels=100000, plot=TRUE, main, ...) { if (missing(layer)) { y <- 1:nlayers(x) } else if (is.character(layer)) { y <- match(layer, names(x)) } else { y <- layer } y <- unique(as.integer(round(y))) y <- stats::na.omit(y) y <- y[ y >= 1 & y <= nlayers(x) ] nl <- length(y) if (nl == 0) { stop('no layers selected') } if (missing(main)) { main=names(x) } if (nl > 1) { res <- list() if (nl > 16) { warning('only the first 16 layers are plotted') nl <- 16 y <- y[1:16] } nc <- ceiling(sqrt(nl)) nr <- ceiling(nl / nc) mfrow <- graphics::par("mfrow") spots <- mfrow[1] * mfrow[2] if (spots < nl) { graphics::par(mfrow=c(nr, nc)) } for (i in 1:length(y)) { res[[i]] = .hist1(raster(x, y[i]), maxpixels=maxpixels, main=main[y[i]], plot=plot, ...) } } else if (nl==1) { if (nlayers(x) > 1) { x <- x[[y]] main <- main[y] } res <- .hist1(x, maxpixels=maxpixels, main=main, plot=plot, ...) } if (plot) { return(invisible(res)) } else { return(res) } } ) .hist1 <- function(x, maxpixels, main, plot, ...){ if ( inMemory(x) ) { v <- getValues(x) } else if ( fromDisk(x) ) { if (ncell(x) <= maxpixels) { v <- stats::na.omit(getValues(x)) } else { # TO DO: make a function that does this by block and combines all data into a single histogram v <- sampleRandom(x, maxpixels) msg <- paste(round(100 * maxpixels / ncell(x)), "% of the raster cells were used", sep="") if (maxpixels > length(v)) { msg <- paste(msg, " (of which ", 100 - round(100 * length(v) / maxpixels ), "% were NA)", sep="") } warning( paste(msg, ". ",length(v)," values used.", sep="") ) } } else { stop('cannot make a histogram; need data on disk or in memory') } if (.shortDataType(x) == 'LOG') { v <- v * 1 } if (plot) { hist(v, main=main, plot=plot, ...) } else { hist(v, plot=plot, ...) } } raster/R/tmpFile.R0000644000176200001440000000633314507510157013510 0ustar liggesusers# Author: Robert J. Hijmans # Date : May 2009 # Version 0.9 # Licence GPL v3 .fileSaveDialog <- function(filetypes="") { if (! requireNamespace("tcltk") ) { stop('you need to install the tcltk library') } if (filetypes == "") { filetypes="{{GeoTIFF} {.tif} } {{grid files} {.grd}}" } tcltk::tclvalue(tcltk::tkgetSaveFile(filetypes=filetypes)) } .fileOpenDialog <- function(filetypes="") { if (! requireNamespace("tcltk") ) { stop('you need to install the tcltk library') } if (filetypes == "") { filetypes="{{All Files} *} {{GeoTIFF} {.tif} } {{grid files} {.grd}}" } tcltk::tclvalue(tcltk::tkgetOpenFile(filetypes=filetypes)) } .old_rasterTmpFile <- function(prefix='raster_tmp_') { f <- getOption('rasterTmpFile') if (!is.null(f)) { f <- trim(f) if (! f == '' ) { options('rasterTmpFile' = NULL) return(f) } } extension <- .defaultExtension(.filetype()) d <- tmpDir(create=TRUE) # dir.create(d, showWarnings = FALSE) f <- paste(round(stats::runif(10)*10), collapse="") d <- paste(d, prefix, f, extension, sep="") if (file.exists(d)) { d <- rasterTmpFile(prefix=prefix) } if (getOption('verbose')) { cat('writing raster to:', d) } return(d) } rasterTmpFile <- function(prefix='r_tmp_') { f <- getOption('rasterTmpFile') if (!is.null(f)) { f <- trim(f) if (! f == '' ) { options('rasterTmpFile' = NULL) return(f) } } extension <- .defaultExtension(.filetype()) d <- tmpDir() while(TRUE) { # added pid as suggested by Daniel Schlaepfer to avoid overlapping file names when running parallel processes and using set.seed() in each node f <- paste(prefix, gsub(" ", "_", gsub(":", "", as.character(Sys.time()))), "_", Sys.getpid(), "_", paste(sample(0:9,5,replace=TRUE),collapse=''), extension, sep = "") tmpf <- normalizePath(file.path(d, f), winslash = "/", mustWork=FALSE) if (! file.exists(tmpf)) { break } } if (getOption('verbose')) { cat('writing raster to:', tmpf) } return(tmpf) } .removeTrailingSlash <- function(d) { if (substr(d, nchar(d), nchar(d)) == '/') { d <- substr(d, 1, nchar(d)-1) } if (substr(d, nchar(d), nchar(d)) == '\\') { d <- substr(d, 1, nchar(d)-1) } return(d) } removeTmpFiles <- function(h=24) { # remove files in the temp folder that are > h hours old warnopt <- getOption('warn') on.exit(options('warn'= warnopt)) tmpdir <- tmpDir(create=FALSE) if (!is.na(tmpdir)) { d <- .removeTrailingSlash(tmpdir) f <- list.files(path=d, pattern='r_tmp*', full.names=TRUE, include.dirs=TRUE) # f <- list.files(path=d, pattern='[.]gr[di]', full.names=TRUE, include.dirs=TRUE) fin <- file.info(f) dif <- Sys.time() - fin$mtime dif <- as.numeric(dif, units="hours") f <- f[which(dif > h)] unlink(f, recursive=TRUE) } options('warn'=warnopt) } showTmpFiles <- function() { f <- NULL tmpdir <- tmpDir(create=FALSE) if (!is.na(tmpdir)) { d <- .removeTrailingSlash(tmpdir) if (file.exists(d)) { f <- list.files(d, pattern='r_tmp_') #f <- list.files(d, pattern='\\.gri$') if (length(f) == 0) { cat('--- none ---\n') } else { ff <- f extension(ff) <- '' ff <- paste(unique(ff), '\n', sep='') cat(ff) } } else { cat('--- none ---\n') } } else { cat('--- none ---\n') } invisible(f) } raster/R/zApply.R0000644000176200001440000000101014507510157013352 0ustar liggesusers# Oscar Perpinan Lamigueiro zApply <- function(x, by, fun=mean, name='', ...){ z <- getZ(x) stopifnot(length(z) == nlayers(x)) ##from aggregate.zoo my.unique <- function(x) x[match(x, x) == seq_len(length(x))] my.sort <- function(x) x[order(x)] if (is.function(by)) { by <- by(z) } ##stopifnot(length(time(x)) == length(by)) b <- stackApply(x, as.numeric(factor(by)), match.fun(fun), ...) zval <- my.sort(my.unique(by)) b <- setZ(b, zval, name) names(b) <- as.character(zval) b } raster/R/is.na.R0000644000176200001440000000525414507510157013121 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 setMethod("is.na", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.na(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.na( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("is.nan", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.nan(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.nan( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("is.finite", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.finite(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.finite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("is.infinite", signature(x='Raster'), function(x) { if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return( setValues(r, is.infinite(getValues(x))) ) } else { tr <- blockSize(x) pb <- pbCreate(tr$n, label='is.na') r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', format=.filetype(), overwrite=TRUE ) for (i in 1:tr$n) { v <- is.infinite( getValuesBlock(x, row=tr$row[i], nrows=tr$nrows[i]) ) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) raster/R/readCellsGDAL.R0000644000176200001440000000674614507510157014446 0ustar liggesusers .readCellsGDAL <- function(x, cells, layers) { x <- rast(x) levels(x) <- NULL x <- x[cells] as.matrix(x)[,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@ncols # con <- rgdal::GDAL.open(x@file@name, silent=TRUE) # if (laysel == 1) { # for (i in 1:length(rows)) { # offs <- c(rows[i]-1, 0) # v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, nc), band = layers) # thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] # colrow[colrow[,2]==rows[i], 3] <- v[thisrow[,1]] # } # } else { # for (i in 1:length(rows)) { # thisrow <- colrow[colrow[,2] == rows[i], , drop=FALSE] # if (nrow(thisrow) == 1) { # offs <- c(rows[i]-1, thisrow[,1]-1) # v <- as.vector( rgdal::getRasterData(con, offset=offs, region.dim=c(1, 1)) ) # colrow[colrow[,2]==rows[i], 2+(1:laysel)] <- v[layers] # } else { # offs <- c(rows[i]-1, 0) # v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, nc)) # v <- do.call(cbind, lapply(1:nl, function(i) v[,,i])) # colrow[colrow[,2]==rows[i], 2+(1:laysel)] <- v[thisrow[,1], layers] # } # } # } # rgdal::closeDataset(con) # colnames(colrow)[2+(1:laysel)] <- names(x)[layers] # colrow[, 2+(1:laysel)] # } # ...readCellsGDAL <- function(x, cells, layers) { # # new version by kendonB via mdsumner # # https://github.com/mdsumner/raster-rforge/pull/16/files#diff-5cf48e61a52c5d9bc1d671a341f80d77 # # reverted --- too slow # nl <- nlayers(x) # if (nl == 1) { # if (inherits(x, 'RasterLayer')) { # layers <- bandnr(x) # } else { # layers <- 1 # } # } # laysel <- length(layers) # colrow <- matrix(ncol=2+laysel, nrow=length(cells)) # colrow[,1] <- colFromCell(x, cells) # colrow[,2] <- rowFromCell(x, cells) # colrow <- colrow[order(colrow[,2], colrow[,1]), , drop = FALSE] # # This is one if contiguous, something else if not (except for the end of a row) # diffrowcol <- diff(colrow[,2]) + diff(colrow[,1]) # # Block numbers # blocknums <- cumsum(c(TRUE, diffrowcol != 1)) # nc <- x@ncols # con <- rgdal::GDAL.open(x@file@name, silent=TRUE) # if (laysel == 1) { # for (blocknum in unique(blocknums)) { # block_lgl <- blocknum == blocknums # offs <- c(colrow[block_lgl,2][1] - 1, colrow[block_lgl, 1][1] - 1) # v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, sum(block_lgl)), band = layers) # colrow[block_lgl, 3] <- v # } # } else { # for (blocknum in unique(blocknums)) { # block_lgl <- blocknum == blocknums # this_block <- colrow[block_lgl, , drop = FALSE] # offs <- c(colrow[block_lgl,2][1] - 1, colrow[block_lgl, 1][1] - 1) # if (nrow(this_block) == 1) { # v <- as.vector( rgdal::getRasterData(con, offset=offs, region.dim=c(1, 1)) ) # colrow[block_lgl, 2+(1:laysel)] <- v[layers] # } else { # v <- rgdal::getRasterData(con, offset=offs, region.dim=c(1, sum(block_lgl)), band = layers) # v <- do.call(cbind, lapply(1:nl, function(i) v[,,i])) # colrow[block_lgl, 2 + (1:laysel)] <- v # } # } # } # rgdal::closeDataset(con) # colnames(colrow)[2+(1:laysel)] <- names(x)[layers] # colrow[, 2+(1:laysel), drop = laysel == 1] # } raster/R/extension.R0000644000176200001440000000517214507510157014124 0ustar liggesusers# return or change file extensions # Author: Robert J. Hijmans # Date : October 2008 # Version 1.0 # Licence GPL v3 extension <- function(filename, value=NULL, maxchar=10) { if (!is.null(value)) { extension(filename) <- value return(filename) } lfn <- nchar(filename) ext <- list() for (f in 1:length(filename)) { extstart <- -1 for (i in lfn[f] : 2) { if (substr(filename[f], i, i) == ".") { extstart <- i break } } if (extstart > 0) { ext[f] <- substr(filename[f], extstart, lfn[f]) } else { ext[f] <- "" } } ext <- unlist(ext) ext[nchar(ext) > maxchar] <- '' return(ext) } 'extension<-' <- function(filename, value) { value <- trim(value) if (value != "" & substr(value, 1, 1) != ".") { value <- paste(".", value, sep="") } lfn <- nchar(filename) fname <- list() for (f in 1:length(filename)) { extstart <- -1 for (i in lfn[f] : 2) { if (substr(filename[f], i, i) == ".") { extstart <- i break } } if (extstart > 0 & (lfn[f] - extstart) < 8) { fname[f] <- paste(substr(filename[f], 1, extstart-1), value, sep="") } else { fname[f] <- paste(filename[f], value, sep="") } } return( unlist(fname) ) } .getExtension <- function(f, format) { if (.setfileext()) { def <- .defaultExtension(format, f) if (def != '') { extension(f) <- def } } return(f) } .defaultExtension <- function(format=.filetype(), filename="") { format <- toupper(format) if (format == 'RASTER') { return('.grd') } else if (format == 'GTIFF') { e <- extension(filename) if (tolower(e) %in% c(".tiff", ".tif")) { return (e) } else { return('.tif') } } else if (format == 'CDF') { return('.nc') } else if (format == 'KML') { return('.kml') } else if (format == 'KMZ') { return('.kmz') # } else if (format == 'BIG.MATRIX') { return('.big') } else if (format == 'BIL') { return('.bil') } else if (format == 'BSQ') { return('.bsq') } else if (format == 'BIP') { return('.bip') } else if (format == 'ASCII') { return('.asc') } else if (format == 'RST') { return('.rst') } else if (format == 'ILWIS') { return('.mpr') } else if (format == 'SAGA') { return('.sdat') } else if (format == 'BMP') { return('.bmp') } else if (format == 'ADRG') { return('.gen') } else if (format == 'BT') { return('.bt') } else if (format == 'EHdr') { return('.bil') } else if (format == 'ENVI') { return('.envi') } else if (format == 'ERS') { return('.ers') } else if (format == 'GSBG') { return('.grd') } else if (format == 'HFA') { return( '.img') } else if (format == 'IDA') { return( '.img') } else if (format == 'RMF') { return('.rsw') } else { return('') } } raster/R/col2RGB.R0000644000176200001440000000053614507510157013301 0ustar liggesusers .col2RGB <- function(x) { d <- t( grDevices::col2rgb(x@legend@colortable) ) d <- data.frame(id=0:255, d) subs(x, d, which=2:4) } .alphaCT <- function(x, alpha) { ct <- colortable(x) z <- t(grDevices::col2rgb(ct)) ct <- apply(z, 1, function(i) grDevices::rgb(i[1], i[2], i[3], alpha*255, maxColorValue=255)) colortable(x) <- ct return(x) } raster/R/naValue.R0000644000176200001440000000143314507510157013477 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 .naChanged <- function(x) { if (.hasSlot(x@file, 'NAchanged')) { return(x@file@NAchanged) } else { return(TRUE) } } 'NAvalue<-' <- function(x, value) { if (inherits(x, 'RasterStack')) { nl <- nlayers(x) if (length(value) == 1) { value <- rep(value[[1]], nl) } else { v <- vector(length=nl) v[] <- as.vector(value) value <- v } for (i in 1:nl) { x@layers[[i]]@file@nodatavalue <- value[i] x@layers[[i]]@file@NAchanged <- TRUE } } else { x@file@nodatavalue <- value[[1]] x@file@NAchanged <- TRUE } return(x) } NAvalue <- function(x) { if (inherits(x, 'RasterStack')) { sapply(x@layers, function(x) { x@file@nodatavalue }) } else { return(x@file@nodatavalue) } } raster/R/predict.R0000644000176200001440000001442614507510157013544 0ustar liggesusers# Author: Robert J. Hijmans # Date : August 2009 # Version 0.9 # Licence GPL v3 setMethod('predict', signature(object='Raster'), function(object, model, filename="", fun=predict, ext=NULL, const=NULL, index=1, na.rm=TRUE, inf.rm=FALSE, factors=NULL, format, datatype, overwrite=FALSE, progress="", ...) { filename <- trim(filename) if (missing(format)) { format <- .filetype(filename=filename) } if (missing(datatype)) { datatype <- .datatype() } if ( ! hasValues(object) ) { stop('No values associated with this Raster object') } if (inherits(model, 'DistModel')) { # models defined in package 'dismo' return ( predict(model, object, filename=filename, ext=ext, progress=progress, format=format, overwrite=overwrite, ...) ) } if (length(index) > 1) { predrast <- brick(object, values=FALSE, nl=length(index)) } else { predrast <- raster(object) } if (!is.null(ext)) { predrast <- crop(predrast, extent(ext)) firstrow <- rowFromY(object, yFromRow(predrast, 1)) firstcol <- colFromX(object, xFromCol(predrast, 1)) } else { firstrow <- 1 firstcol <- 1 } ncols <- ncol(predrast) if (ncol(predrast) < ncol(object)) { gvb <- TRUE } else { gvb <- FALSE } lyrnames <- names(object) haveFactor <- FALSE facttest <- TRUE if (!is.null(factors)) { stopifnot(is.list(factors)) f <- names(factors) if (any(trimws(f) == "")) { stop("all factors must be named") } } else { if (inherits(model, "randomForest")) { f <- names(which(sapply(model$forest$xlevels, max) != "0")) if (length(f) > 0) { factors <- model$forest$xlevels[f] } } else if (inherits(model, "gbm")) { dafr <- model$gbm.call$dataframe vars <- model$gbm.call$gbm.x dafr <- dafr[,vars] i <- sapply(dafr, is.factor) if (any(i)) { j <- which(i) factors <- list() for (k in 1:length(j)) { factors[[k]] <- levels(dafr[[ j[k] ]]) } f <- colnames(dafr)[j] } } else { #glm and others try(factors <- model$xlevels, silent=TRUE) f <- names(factors) } } if (length(factors) > 0) { haveFactor <- TRUE lyrnamesc <- c(lyrnames, names(const)) if (!all(f %in% lyrnamesc)) { ff <- f[!(f %in% lyrnamesc)] warning(paste("factor name(s):", paste(ff, collapse=", "), " not in layer names")) f[(f %in% lyrnamesc)] } } constnames <- names(const) if (!canProcessInMemory(predrast) && filename == '') { filename <- rasterTmpFile() } if (filename == "") { v <- matrix(NA, ncol=nlayers(predrast), nrow=ncell(predrast)) } else { predrast <- writeStart(predrast, filename=filename, format=format, datatype=datatype, overwrite=overwrite ) } tr <- blockSize(predrast, n=nlayers(predrast)+3) napred <- matrix(rep(NA, ncol(predrast) * tr$nrows[1] * nlayers(predrast)), ncol=nlayers(predrast)) factres <- FALSE pb <- pbCreate(tr$n, progress=progress, label="predict") for (i in 1:tr$n) { if (i==tr$n) { ablock <- 1:(ncol(object) * tr$nrows[i]) napred <- matrix(rep(NA, ncol(predrast) * tr$nrows[i] * nlayers(predrast)), ncol=nlayers(predrast)) } rr <- firstrow + tr$row[i] - 1 if (gvb) { blockvals <- data.frame(getValuesBlock(object, row=rr, nrows=tr$nrows[i], firstcol, ncols)) } else { blockvals <- data.frame(getValues(object, row=rr, nrows=tr$nrows[i])) # faster } # need to do this if using a single variable colnames(blockvals) <- lyrnames if (! is.null(const)) { blockvals <- cbind(blockvals, const) constnames <- names(const) } if (haveFactor) { for (j in 1:length(f)) { flev <- fvs <- factors[[j]] if (!is.null(const)) { if (!(f[j] %in% constnames)) { if (!is.numeric(fvs)) { flev <- 1:length(flev) } } } fv <- blockvals[, f[j]] # failed with character factors. See #91 #fv[!(fv %in% flev)] <- NA #fv <- factor(fv, levels=flev, labels=fvs) if (is.numeric(fv)) { flev <- as.numeric(flev) if (any(is.na(flev))) stop("cannot process these factors") } fv[!(fv %in% flev)] <- NA fv <- factor(fv, levels=flev, labels=fvs) blockvals[,f[j]] <- fv } } if (na.rm) { if (inf.rm) { blockvals[!is.finite(as.matrix(blockvals))] <- NA } blockvals <- stats::na.omit(blockvals) } nrb <- nrow(blockvals) if (nrb == 0 ) { predv <- napred } else { predv <- fun(model, blockvals, ...) if (inherits(predv, 'list')) { predv <- unlist(predv, use.names = FALSE) if (length(predv) != nrow(blockvals)) { predv <- matrix(predv, nrow=nrow(blockvals)) } } else if (is.array(predv)) { predv <- as.matrix(predv) } if (isTRUE(dim(predv)[2] > 1)) { predv <- predv[,index, drop=FALSE] for (fi in 1:ncol(predv)) { if (is.factor(predv[,fi])) { predv[,fi] <- as.integer(as.character(predv[,fi])) } } # if data.frame predv <- as.matrix(predv) } else if (is.factor(predv)) { # should keep track of this to return a factor type RasterLayer factres <- TRUE if (facttest) { suppressWarnings(tst <- as.integer(as.character(levels(predv)))) if (any(is.na(tst))) { factaschar = FALSE } else { factaschar = TRUE } levs <- levels(predv) predrast@data@attributes <- list(data.frame(ID=1:length(levs), value=levs)) predrast@data@isfactor <- TRUE facttest <- FALSE } if (factaschar) { predv <- as.integer(as.character(predv)) } else { predv <- as.integer(predv) } } if (na.rm) { naind <- as.vector(attr(blockvals, "na.action")) if (!is.null(naind)) { p <- napred p[-naind,] <- predv predv <- p rm(p) } } } if (filename == '') { cells <- cellFromRowCol(predrast, tr$row[i], 1):cellFromRowCol(predrast, tr$row[i]+tr$nrows[i]-1, ncol(predrast)) v[cells, ] <- predv } else { predrast <- writeValues(predrast, predv, tr$row[i]) } pbStep(pb, i) } pbClose(pb) if (length(index) > 1) { try(names(predrast) <- colnames(predv), silent=TRUE) } if (filename == '') { predrast <- setValues(predrast, v) # or as.vector } else { predrast <- writeStop(predrast) } return(predrast) } ) raster/R/alignExtent.R0000644000176200001440000000607414507510157014374 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 alignExtent <- function(extent, object, snap='near') { snap <- tolower(snap) stopifnot(snap %in% c('near', 'in', 'out')) extent <- extent(extent) if (!inherits(object, 'BasicRaster')) { stop('object should inherit from BasicRaster') } res <- res(object) orig <- origin(object) # snap points to pixel boundaries if (snap == 'near') { xmn <- round((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- round((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- round((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- round((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } else if (snap == 'out') { xmn <- floor((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- ceiling((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- floor((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- ceiling((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } else if (snap == 'in') { xmn <- ceiling((extent@xmin-orig[1]) / res[1]) * res[1] + orig[1] xmx <- floor((extent@xmax-orig[1]) / res[1]) * res[1] + orig[1] ymn <- ceiling((extent@ymin-orig[2]) / res[2]) * res[2] + orig[2] ymx <- floor((extent@ymax-orig[2]) / res[2]) * res[2] + orig[2] } if (xmn == xmx) { if (xmn <= extent@xmin) { xmx <- xmx + res[1] } else { xmn <- xmn - res[1] } } if (ymn == ymx) { if (ymn <= extent@ymin) { ymx <- ymx + res[2] } else { ymn <- ymn - res[2] } } e <- extent(xmn, xmx, ymn, ymx) #intersect(e, extent(object)) return(e) } .Old.alignExtent <- function(extent, object) { object <- raster(object) oldext <- extent(object) e <- extent(extent) e@xmin <- min(e@xmin, oldext@xmin) e@xmax <- max(e@xmax, oldext@xmax) e@ymin <- min(e@ymin, oldext@ymin) e@ymax <- max(e@ymax, oldext@ymax) col <- colFromX(object, e@xmin) mn <- xFromCol(object, col) - 0.5 * xres(object) mx <- xFromCol(object, col) + 0.5 * xres(object) if (abs(e@xmin - mn) > abs(e@xmin - mx)) { e@xmin <- mx } else { e@xmin <- mn } col <- colFromX(object, e@xmax) if (is.na(col)) mn <- xFromCol(object, col) - 0.5 * xres(object) mx <- xFromCol(object, col) + 0.5 * xres(object) if (abs(e@xmax - mn) > abs(e@xmax - mx)) { e@xmax <- mx } else { e@xmax <- mn } row <- rowFromY(object, e@ymin) mn <- yFromRow(object, row) - 0.5 * yres(object) mx <- yFromRow(object, row) + 0.5 * yres(object) if (abs(e@ymin - mn) > abs(e@ymin - mx)) { e@ymin <- mx } else { e@ymin <- mn } row <- rowFromY(object, e@ymax) mn <- yFromRow(object, row) - 0.5 * yres(object) mx <- yFromRow(object, row) + 0.5 * yres(object) if (abs(e@ymax - mn) > abs(e@ymax - mx)) { e@ymax <- mx } else { e@ymax <- mn } if ( e@ymin == e@ymax ) { if (oldext@ymax > e@ymax) { e@ymax = e@ymax + yres(object) } if (oldext@ymin < e@ymin) { e@ymin = e@ymin - yres(object) } } if ( e@xmin == e@xmax ) { if (oldext@xmax > e@xmax) { e@xmax = e@xmax + xres(object) } if (oldext@xmin < e@xmin) { e@xmin = e@xmin - xres(object) } } return(e) } raster/R/addFiles.R0000644000176200001440000000121214507510157013612 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .addFiles <- function(x, rasterfiles, bands=rep(1, length(rasterfiles))) { if (length(bands) == 1) { bands=rep(bands, length(rasterfiles)) } rasters <- list() for (i in 1:length(rasterfiles)) { if (bands[[i]] < 1) { r <- raster(rasterfiles[[i]], band=1) rasters <- c(rasters, r) if (nbands(r) > 1) { for (j in 2:nbands(r)) { r <- raster(rasterfiles[[i]], band=j) rasters <- c(rasters, r) } } } else { rasters <- c(rasters, raster(rasterfiles[[i]], FALSE, band=bands[[i]])) } } x <- addLayer(x, rasters) return(x) } raster/R/kernelDens.R0000644000176200001440000000172414507510157014201 0ustar liggesusers ### this is the kde2d function from the MASS packlage with minimal changes .kde2d <- function (x, y, h, n, lims) { nx <- length(x) gx <- seq.int(lims[1L], lims[2L], length.out = n[1L]) gy <- seq.int(lims[3L], lims[4L], length.out = n[2L]) h <- h/4 ax <- outer(gx, x, "-")/h[1L] ay <- outer(gy, y, "-")/h[2L] tcrossprod(matrix(stats::dnorm(ax), , nx), matrix(stats::dnorm(ay), , nx))/(nx * h[1L] * h[2L]) } .kernelDens <- function(p, x, bandwidth, ...) { .bandwidth.nrd <- function(x) { ### this function is from the MASS package r <- stats::quantile(x, c(0.25, 0.75)) h <- (r[2L] - r[1L])/1.34 4 * 1.06 * min(sqrt(stats::var(x)), h) * length(x)^(-1/5) } if(missing(bandwidth)) { bw <- c(.bandwidth.nrd(p[,1]), .bandwidth.nrd(p[,2])) } else { bw <- rep(bandwidth, length.out = 2L) } v <- .kde2d(p[,1], p[,2], bw, dim(x)[1:2], as.vector(t(bbox(x)))) v <- t(v) v <- v[nrow(v):1, ] setValues(x, v) } #a = kernelDens(xy, r) raster/R/compare_Logical.R0000644000176200001440000002512214507510157015165 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .getAdjustedE <- function(r, tr, i, e) { startcell <- cellFromRowCol(r, tr$row[i] , 1) len <- cellFromRowCol(r, tr$row[i] + (tr$nrows[i]-1), ncol(r)) - startcell + 1 n <- (startcell / length(e)) %% 1 if (n > 0 ) { start <- round(n * length(e)) } else { start <- 1 } out <- c(e[start:length(e)], rep(e, floor(len/length(e)))) out[1:len] } .asLogical <- function(x) { x[x!=0] <- 1 return(x) } setMethod('==', signature(e1='BasicRaster', e2='BasicRaster'), function(e1,e2){ cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) return(cond) } ) setMethod('!=', signature(e1='BasicRaster', e2='BasicRaster'), function(e1,e2){ cond <- compareRaster(c(e1, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) return(!cond) } ) setMethod('!', signature(x='Raster'), function(x){ if (nlayers(x) > 1) { r <- brick(x, values=FALSE) } else { r <- raster(x) } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' return(setValues(r, ! getValues(x))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- ! .asLogical(getValues(x, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) return(r) } } ) setMethod("Compare", signature(e1='Raster', e2='logical'), function(e1,e2){ nl <- nlayers(e1) if (nl > 1) { r <- brick(e1, values=FALSE) } else { r <- raster(e1) } if (length(e2) > 1 & nl > 1) { if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(t(getValues(e1)), e2 ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(getValues(e1), e2 ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='logical', e2='Raster'), function(e1,e2){ nl <- nlayers(e2) if (nl > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e2) } if (length(e1) > 1 & nl > 1) { if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(e1, t(getValues(e2)) ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric(e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(e1, getValues(e2) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e1) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- methods::callGeneric(e1, getValues(e, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='Raster', e2='numeric'), function(e1, e2){ nl <- nlayers(e1) if (nl > 1) { r <- brick(e1, values=FALSE) } else { r <- raster(e1) } if (length(e2) > 1 & nl > 1) { if (length(e2) != nl) { a <- rep(NA, nl) a[] <- e2 e2 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(t(getValues(e1)), e2 ) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric( t(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), e2)) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e2) > ncell(r)) { e2 <- e2[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(getValues(e1), e2)) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e2) v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), e2) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='numeric', e2='Raster'), function(e1, e2){ nl <- nlayers(e2) if (nl > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e2) } if (length(e1) > 1 & nl > 1) { if (length(e1) != nl) { a <- rep(NA, nl) a[] <- e1 e1 <- a } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, values=t(methods::callGeneric(e1, t(getValues(e2))) ) ) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- t(methods::callGeneric(e1, t(getValues(e2, row=tr$row[i], nrows=tr$nrows[i])))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } } else { if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' if (length(e1) > ncell(r)) { e1 <- e1[1:ncell(r)] } r <- setValues(r, values=methods::callGeneric(e1, getValues(e2))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) if (length(e2) > 0) { for (i in 1:tr$n) { e <- .getAdjustedE(r, tr, i, e1) v <- methods::callGeneric(e, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- methods::callGeneric(e1, getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } } r <- writeStop(r) pbClose(pb) } } return(r) } ) setMethod("Compare", signature(e1='Raster', e2='Raster'), function(e1, e2){ if (nlayers(e1) > 1) { if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) { stop('number of layers of objects do not match') } r <- brick(e1, values=FALSE) } else if (nlayers(e2) > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e1) } cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) if (!cond) { stop("Cannot compare Rasters that have different BasicRaster attributes. See compareRaster()") } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, methods::callGeneric(getValues(e1), getValues(e2))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- methods::callGeneric(getValues(e1, row=tr$row[i], nrows=tr$nrows[i]), getValues(e2, row=tr$row[i], nrows=tr$nrows[i])) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod("Logic", signature(e1='Raster', e2='Raster'), function(e1, e2){ if (nlayers(e1) > 1) { r <- brick(e1, values=FALSE) if (nlayers(e2) > 1 & nlayers(e2) != nlayers(e1)) { stop('number of layers of objects do not match') } } else if (nlayers(e2) > 1) { r <- brick(e2, values=FALSE) } else { r <- raster(e1) } cond <- compareRaster(c(r, e2), extent=TRUE, rowcol=TRUE, crs=TRUE, tolerance=0.05, stopiffalse=FALSE) if (!cond) { stop("Cannot compare Rasters that have different BasicRaster attributes. See compareRaster()") } if (canProcessInMemory(r, 3)) { dataType(r) <- 'LOG1S' r <- setValues(r, methods::callGeneric(.asLogical(getValues(e1)), .asLogical(getValues(e2)))) } else { tr <- blockSize(r) pb <- pbCreate(tr$n) r <- writeStart(r, filename=rasterTmpFile(), datatype='LOG1S', overwrite=TRUE ) for (i in 1:tr$n) { v <- methods::callGeneric(.asLogical(getValues(e1, row=tr$row[i], nrows=tr$nrows[i])), .asLogical(getValues(e2, row=tr$row[i], nrows=tr$nrows[i]))) r <- writeValues(r, v, tr$row[i]) pbStep(pb, i) } r <- writeStop(r) pbClose(pb) } return(r) } ) setMethod("Compare", signature(e1='Extent', e2='Extent'), function(e1,e2){ a <- methods::callGeneric(e2@xmin, e1@xmin) b <- methods::callGeneric(e1@xmax, e2@xmax) c <- methods::callGeneric(e2@ymin, e1@ymin) d <- methods::callGeneric(e1@ymax, e2@ymax) a & b & c & d } ) raster/R/direction.R0000644000176200001440000000360614507510157014070 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # revised October 2011 # Version 1.0 # Licence GPL v3 setMethod('direction', signature(x='RasterLayer'), function(x, filename='', degrees=FALSE, from=FALSE, doEdge=FALSE, ...) { out <- raster(x) if (couldBeLonLat(out)) { longlat=TRUE } else { longlat=FALSE } if (doEdge) { r <- boundaries(x, classes=FALSE, type='inner', asNA=TRUE, progress=.progress(...)) pts <- try( rasterToPoints(r, fun=function(z){ z>0 } )[,1:2, drop=FALSE] ) } else { pts <- try( rasterToPoints(x)[,1:2, drop=FALSE] ) } if (inherits(pts, "try-error")) { stop('This function has not yet been implemented for very large files') } if (nrow(pts) == 0) { stop('RasterLayer has no NA cells (for which to compute a direction)') } filename <- trim(filename) if ( canProcessInMemory(out, 3)) { vals <- getValues(x) i <- which(is.na(vals)) xy <- xyFromCell(out, i) vals[] <- NA vals[i] <- .Call('_raster_directionToNearestPoint', xy, pts, longlat, degrees, from, a=6378137.0, f=1/298.257223563, PACKAGE='raster') out <- setValues(out, vals) if (filename != '') { out <- writeRaster(out, filename, ...) } return(out) } out <- writeStart(out, filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, label='direction', ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- getValues(x, tr$row[i], tr$nrows[i]) j <- which(is.na(vals)) vals[] <- NA if (length(j) > 0) { vals[j] <- .Call('_raster_directionToNearestPoint', xy[j, ,drop=FALSE], pts, longlat, degrees, from, a=6378137.0, f=1/298.257223563, PACKAGE='raster') } out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } ) raster/R/properties.R0000644000176200001440000000224414507510157014301 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .driver <- function(object, warn=TRUE) { if (inherits(object, 'RasterStack')) { d <- sapply(object@layers, function(x) x@file@driver) if (any(d == '' & warn)) { warning('There is no driver associated with one or more layers of this RasterStack') } } else { d <- object@file@driver if (d == '' & warn) { warning('no file/driver associated with this Raster object') } } return(d) } .nodatavalue <- function(object) { if (inherits(object, 'RasterStack')) { return( sapply(object@layers, function(x) x@file@nodatavalue) ) } return(object@file@nodatavalue) } filename <- function(x) { if (inherits(x, 'RasterStack')) { return(x@filename) } return(x@file@name) } # fileext <- toupper(extension(fn)) # if ( fileext == ".GRD" | fileext == ".GRI" ) { # return('raster') # } else { # return('gdal') # } # fcon <- class(try( object@file@con, silent = T ))[1] # if (fcon == 'file') { # return('raster') # } else if (fcon == "GDALReadOnlyDataset") { # return('gdal') # } else if (fcon == "try-error") { # return('NA') # } else { # stop('unknown driver') # } raster/R/plotRaster2.R0000644000176200001440000000255114507510157014327 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2009 # Version 0.9 # Licence GPL v3 .plotraster2 <- function(object, col=rev(terrain.colors(250)), maxpixels=100000, xlab='', ylab='', ext=NULL, xlim, ylim, add=FALSE, addfun=NULL, colNA=NA, main, facvar=0, alpha=NULL, ...) { if ( ! hasValues(object) ) { stop('no values associated with this RasterLayer') } maxpixels <- max(1, maxpixels) if (is.null(ext)) { ext <- extent(object) } else { ext <- intersect(extent(object), ext) } if (!missing(xlim)) { if (xlim[1] >= xlim[2]) stop('invalid xlim') if (xlim[1] < ext@xmax) ext@xmin <- xlim[1] if (xlim[2] > ext@xmin) ext@xmax <- xlim[2] } if (!missing(ylim)) { if (ylim[1] >= ylim[2]) stop('invalid ylim') if (ylim[1] < ext@ymax) ext@ymin <- ylim[1] if (ylim[2] > ext@ymin) ext@ymax <- ylim[2] } # leg <- object@legend object <- sampleRegular(object, size=maxpixels, ext=ext, asRaster=TRUE) if (!is.null(alpha)) { if (inherits(alpha, 'RasterLayer')) { alpha <- sampleRegular(alpha, size=maxpixels, ext=ext, asRaster=TRUE) } } if (facvar > 0) { object <- deratify(object, facvar) } if (missing(main)) { main <- '' #main <- names(object) } .rasterImagePlot(object, col=col, xlab=xlab, ylab=ylab, add=add, colNA=colNA, main=main, alpha=alpha, ...) if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } } raster/R/xyMinMax.R0000644000176200001440000000207714507510157013663 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod('xmin', signature(x='BasicRaster'), function(x) { return(extent(x)@xmin) }) setMethod('xmax', signature(x='BasicRaster'), function(x) { return(extent(x)@xmax) }) setMethod('ymin', signature(x='BasicRaster'), function(x) { return(extent(x)@ymin) }) setMethod('ymax', signature(x='BasicRaster'), function(x) { return(extent(x)@ymax) }) setMethod('xmin', signature(x='Extent'), function(x) { return(x@xmin) }) setMethod('xmax', signature(x='Extent'), function(x) { return(x@xmax) }) setMethod('ymin', signature(x='Extent'), function(x) { return(x@ymin) }) setMethod('ymax', signature(x='Extent'), function(x) { return(x@ymax) }) setMethod('xmin', signature(x='Spatial'), function(x) { return(extent(x)@xmin) }) setMethod('xmax', signature(x='Spatial'), function(x) { return(extent(x)@xmax) }) setMethod('ymin', signature(x='Spatial'), function(x) { return(extent(x)@ymin) }) setMethod('ymax', signature(x='Spatial'), function(x) { return(extent(x)@ymax) }) raster/R/disaggregate.R0000644000176200001440000000510714507510157014534 0ustar liggesusers# Author: Robert Hijmans # Date : October 2008 - December 2011 # Version 1.0 # Licence GPL v3 # April 2012: Several patches & improvements by Jim Regetz setMethod('disaggregate', signature(x='Raster'), function(x, fact=NULL, method='', filename='', ...) { method <- tolower(method) if (!method %in% c('bilinear', '')) { stop('unknown "method". Should be "bilinear" or ""') } stopifnot(!is.null(fact)) fact <- as.integer(round(fact)) if (length(fact)==1) { if (fact == 1) return(x) if (fact < 2) { stop('fact should be >= 1') } xfact <- yfact <- fact } else if (length(fact)==2) { xfact <- fact[1] yfact <- fact[2] if (xfact < 1) { stop('fact[1] should be > 0') } if (yfact < 1) { stop('fact[2] should be > 0') } if (xfact == 1 & yfact == 1) { return(x) } } else { stop('length(fact) should be 1 or 2') } filename <- trim(filename) nl <- nlayers(x) if (nl > 1) { out <- brick(x, values=FALSE) } else { out <- raster(x) } ncx <- ncol(x) nrx <- nrow(x) dim(out) <- c(nrx * yfact, ncx * xfact) names(out) <- names(x) if (! inherits(x, 'RasterStack')) { if (! inMemory(x) & ! fromDisk(x) ) { return(out) } } if (method=='bilinear') { return(resample(x, out, method='bilinear', filename=filename, ...)) } if (canProcessInMemory(out, 3)) { x <- getValues(x) cols <- rep(seq.int(ncx), each=xfact) rows <- rep(seq.int(nrx), each=yfact) cells <- as.vector( outer(cols, ncx*(rows-1), FUN="+") ) if (nl > 1) { x <- x[cells, ] } else { x <- x[cells] } out <- setValues(out, x) if (filename != '') { out <- writeRaster(out, filename=filename,...) } } else { tr <- blockSize(x, n=nlayers(x) * prod(fact)) rown <- (tr$row-1) * yfact + 1 pb <- pbCreate(tr$n, label='disaggregate', ...) if (is.null(list(...)$datatype)) { out <- writeStart(out, filename=filename, datatype=.commonDataType(dataType(x)), ...) } else { out <- writeStart(out, filename=filename, ...) } x <- readStart(x, ...) cols <- rep(seq.int(ncx), each=xfact) rows <- rep(seq.int(tr$nrows[1]), each=yfact) cells <- as.vector( outer(cols, ncx*(rows-1), FUN="+") ) for (i in 1:tr$n) { if (i == tr$n) { if (tr$nrows[i] != tr$nrows[1]) { rows <- rep(seq.int(tr$nrows[i]), each=yfact) cells <- outer(cols, ncx*(rows-1), FUN="+") } } v <- getValues(x, tr$row[i], tr$nrows[i]) if (nl > 1) { v <- v[cells, ] } else { v <- v[cells] } out <- writeValues(out, v, rown[i]) pbStep(pb, i) } out <- writeStop(out) x <- readStop(x) pbClose(pb) } return(out) } ) raster/R/overlay.R0000644000176200001440000001134114507510157013564 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 # version 1, April 2012 setMethod('overlay', signature(x='Raster', y='Raster'), function(x, y, ..., fun, filename="", recycle=TRUE, forcefun=FALSE){ if (missing(fun)) { stop("you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum'") } lst <- list(...) isRast <- sapply(lst, function(x) inherits(x, 'Raster')) if (sum(unlist(isRast)) > 0) { x <- c(x, y, lst[isRast]) lst <- lst[! isRast ] } else { x <- list(x, y) } lst$fun <- fun lst$filename <- filename lst$recycle <- recycle lst$forcefun <- forcefun lst$x <- x do.call(.overlayList, lst) } ) setMethod('overlay', signature(x='Raster', y='missing'), function(x, y, ..., fun, filename="", unstack=TRUE, forcefun=FALSE){ if (missing(fun)) { stop("you must supply a function 'fun'.\nE.g., 'fun=function(x,y){return(x+y)} or fun=sum'") } x <- .makeRasterList(x, unstack=unstack) .overlayList(x, fun=fun, filename=filename, forcefun=forcefun, ...) } ) .overlayList <- function(x, fun, filename="", recycle=TRUE, forcefun=FALSE, ...){ ln <- length(x) if (ln < 1) { stop('no Rasters') } if (ln > 1) { compareRaster(x) } nl <- sapply(x, nlayers) maxnl <- max(nl) filename <- trim(filename) testmat <- NULL testlst <- vector(length=length(x), mode='list') w <- getOption('warn') options('warn'=-1) for (i in 1:length(testlst)) { v <- extract(x[[i]], 1:5) testmat <- cbind(testmat, as.vector(v)) testlst[[i]] <- v } options('warn'= w) test1 <- try ( apply(testmat, 1, fun) , silent=TRUE ) if ((!inherits(test1, "try-error")) & (!forcefun)) { doapply <- TRUE if (! is.null(dim(test1))) { test1 <- t(test1) } else { test1 <- matrix(test1, ncol=maxnl) } nlout <- NCOL(test1) } else { doapply <- FALSE dovec <- FALSE test2 <- try ( do.call(fun, testlst), silent=TRUE ) nlout <- length(test2)/5 if ((inherits(test2, "try-error")) | length(test2) < 5) { dovec <- TRUE testlst <- lapply(testlst, as.vector) test3 <- try ( do.call(fun, testlst), silent=TRUE ) nlout <- length(test3)/5 if ((inherits(test3, "try-error")) | length(test3) < 5) { stop('cannot use this formula, probably because it is not vectorized') } } } if (nlout == 1) { out <- raster(x[[1]]) } else { out <- brick(x[[1]], values=FALSE, nl=nlout) } if ( canProcessInMemory(out, sum(nl)+maxnl) ) { pb <- pbCreate(3, label='overlay', ...) pbStep(pb, 1) if (doapply) { valmat <- matrix(nrow=ncell(out)*maxnl, ncol=length(x)) for (i in 1:length(x)) { if (ncell(x[[i]]) < nrow(valmat)) { options('warn'=-1) valmat[,i] <- as.vector(getValues(x[[i]])) * rep(1, nrow(valmat)) options('warn'= w) } else { valmat[,i] <- as.vector(getValues(x[[i]])) } } pbStep(pb, 2) vals <- apply(valmat, 1, fun) if (! is.null(dim(vals))) { vals <- t(vals) } vals <- matrix(vals, nrow=ncell(out)) } else { for (i in 1:length(x)) { x[[i]] <- getValues(x[[i]]) } if (dovec) { x <- lapply(x, as.vector) } pbStep(pb, 2) vals <- do.call(fun, x) vals <- matrix(vals, nrow=ncell(out)) } pbStep(pb, 3) out <- setValues(out, vals) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } pbClose(pb) return(out) } else { if (filename == "") { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=sum(nl)+maxnl) pb <- pbCreate(tr$n, label='overlay', ...) if (doapply) { valmat = matrix(nrow=tr$nrows[1]*ncol(out)*maxnl, ncol=length(x)) for (i in 1:tr$n) { if (i == tr$n) { valmat = matrix(nrow=tr$nrows[i]*ncol(out)*maxnl , ncol=length(x)) } for (j in 1:length(x)) { v <- as.vector(getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i])) if (length(v) < nrow(valmat)) { options('warn'=-1) valmat[,j] <- v * rep(1, nrow(valmat)) options('warn'=w) } else { valmat[,j] <- v } } vv <- apply(valmat, 1, fun) if (! is.null(dim(vv))) { vals <- t(vv) } vv <- matrix(vv, ncol=nlout) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } } else { vallist <- list() for (i in 1:tr$n) { if (dovec) { for (j in 1:length(x)) { vallist[[j]] <- as.vector( getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) ) } } else { for (j in 1:length(x)) { vallist[[j]] <- getValues(x[[j]], row=tr$row[i], nrows=tr$nrows[i]) } } vv <- do.call(fun, vallist) vv <- matrix(vv, ncol=nlout) out <- writeValues(out, vv, tr$row[i]) pbStep(pb, i) } } pbClose(pb) out <- writeStop(out) } return(out) } raster/R/intersect_sp.R0000644000176200001440000002655714507510157014624 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 #.checkGEOS <- function() { # stopifnot(requireNamespace("rgeos")) # gval <- rgeos::get_RGEOS_CheckValidity() # rgeos::set_RGEOS_CheckValidity(2L) # gval #} setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y) { # warning("this method will be removed. You can use 'terra::intersect' instead") as(intersect(vect(x), vect(y)), "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # # threshold <- get_RGEOS_polyThreshold() # # on.exit(set_RGEOS_polyThreshold(threshold)) # # minarea <- min(apply(bbox(union(extent(x), extent(y))), 1, diff) / 1000000, 0.00001) # # set_RGEOS_polyThreshold(minarea) # # slivers <- get_RGEOS_dropSlivers() # # on.exit(set_RGEOS_dropSlivers(slivers)) # # set_RGEOS_dropSlivers(TRUE) # x <- sp::spChFIDs(x, as.character(1:length(x))) # y <- sp::spChFIDs(y, as.character(1:length(y))) # subs <- rgeos::gIntersects(x, y, byid=TRUE) # if (sum(subs)==0) { # warning('polygons do not intersect') # return(NULL) # } # xdata <-.hasSlot(x, 'data') # ydata <-.hasSlot(y, 'data') # dat <- NULL # if (xdata & ydata) { # nms <- .goodNames(c(colnames(x@data), colnames(y@data))) # colnames(x@data) <- xnames <- nms[1:ncol(x@data)] # colnames(y@data) <- ynames <- nms[(ncol(x@data)+1):length(nms)] # dat <- cbind(x@data[NULL, ,drop=FALSE], y@data[NULL, ,drop=FALSE]) # } else if (xdata) { # dat <- x@data[NULL, ,drop=FALSE] # xnames <- colnames(dat) # } else if (ydata) { # dat <- y@data[NULL, ,drop=FALSE] # ynames <- colnames(dat) # } # subsx <- apply(subs, 2, any) # subsy <- apply(subs, 1, any) # int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_lower_td=TRUE) # # if (inherits(int, "SpatialCollections")) { # # if (is.null(int@polyobj)) { # merely touching, no intersection # # #warning('polygons do not intersect') # # return(NULL) # # } # # int <- int@polyobj # # } # if (!inherits(int, 'SpatialPolygons')) { # # warning('polygons do not intersect') # return(NULL) # } # if (!is.null(dat)) { # ids <- do.call(rbind, strsplit(row.names(int), ' ')) # rows <- 1:length(ids[,1]) # if (xdata) { # idsx <- match(ids[,1], rownames(x@data)) # dat[rows, xnames] <- x@data[idsx, ] # } # if (ydata) { # idsy <- match(ids[,2], rownames(y@data)) # dat[rows, ynames] <- y@data[idsy, ] # } # rownames(dat) <- 1:nrow(dat) # int <- sp::spChFIDs(int, as.character(1:nrow(dat))) # int <- sp::SpatialPolygonsDataFrame(int, dat) # } # if (length(int) > 0) { # w <- getOption('warn') # on.exit(options('warn' = w)) # options('warn'=-1) # j <- rgeos::gIsValid(int, byid=TRUE, reason=FALSE) # if (!all(j)) { # bad <- which(!j) # for (i in bad) { # # it could be that a part of a polygon is a sliver, but that other parts are OK # a <- sp::disaggregate(int[i, ]) # if (length(a) > 1) { # jj <- which(rgeos::gIsValid(a, byid=TRUE, reason=FALSE)) # a <- a[jj, ] # if (length(a) > 0) { # int@polygons[i] <- aggregate(a)@polygons # j[i] <- TRUE # } # } # } # int <- int[j,] # } # } # int@proj4string <- prj # int } ) setMethod('intersect', signature(x='SpatialPolygons', y='SpatialLines'), function(x, y) { # warning("this method will be removed. You can use 'terra::intersect' instead") as(intersect(vect(x), vect(y)), "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # gval <- rgeos::get_RGEOS_CheckValidity() # if (gval != 2) { # on.exit(rgeos::set_RGEOS_CheckValidity(gval)) # rgeos::set_RGEOS_CheckValidity(2L) # } # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # subs <- rgeos::gIntersects(x, y, byid=TRUE) # if (sum(subs)==0) { # warning('lines and polygons do not intersect') # return(NULL) # } # if (inherits(x, "Spatial")) { x@proj4string <- prj } # i <- which(apply(subs, 2, any)) # x[i, ] } ) setMethod('intersect', signature(x='SpatialLines', y='SpatialPolygons'), function(x, y) { # warning("this method will be removed. You can use 'terra::intersect' instead") as(intersect(vect(x), vect(y)), "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # gval <- rgeos::get_RGEOS_CheckValidity() # if (gval != 2) { # on.exit(rgeos::set_RGEOS_CheckValidity(gval)) # rgeos::set_RGEOS_CheckValidity(2L) # } # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # x <- sp::spChFIDs(x, as.character(1:length(x))) # y <- sp::spChFIDs(y, as.character(1:length(y))) # if (! identical( .proj4string(x), .proj4string(y)) ) { # warning('non identical crs') # y@proj4string <- x@proj4string # } # subs <- rgeos::gIntersects(x, y, byid=TRUE) # if (sum(subs)==0) { # warning('lines and polygons do not intersect') # return(NULL) # } # xdata <-.hasSlot(x, 'data') # ydata <-.hasSlot(y, 'data') # dat <- NULL # if (xdata & ydata) { # nms <- .goodNames(c(colnames(x@data), colnames(y@data))) # colnames(x@data) <- xnames <- nms[1:ncol(x@data)] # colnames(y@data) <- ynames <- nms[(ncol(x@data)+1):length(nms)] # dat <- cbind(x@data[NULL, ,drop=FALSE], y@data[NULL, ,drop=FALSE]) # } else if (xdata) { # dat <- x@data[NULL, ,drop=FALSE] # xnames <- colnames(dat) # } else if (ydata) { # dat <- y@data[NULL, ,drop=FALSE] # ynames <- colnames(dat) # } # subsx <- apply(subs, 2, any) # subsy <- apply(subs, 1, any) # int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_lower_td=TRUE) # # if (inherits(int, "SpatialCollections")) { # # if (is.null(int@polyobj)) { # merely touching, no intersection # # #warning('polygons do not intersect') # # return(NULL) # # } # # int <- int@polyobj # # } # if (!inherits(int, 'SpatialLines')) { # # warning('polygons do not intersect') # return(NULL) # } # if (!is.null(dat)) { # ids <- do.call(rbind, strsplit(row.names(int), ' ')) # rows <- 1:length(ids[,1]) # if (xdata) { # idsx <- match(ids[,1], rownames(x@data)) # dat[rows, xnames] <- x@data[idsx, ] # } # if (ydata) { # idsy <- match(ids[,2], rownames(y@data)) # dat[rows, ynames] <- y@data[idsy, ] # } # rownames(dat) <- 1:nrow(dat) # int <- sp::spChFIDs(int, as.character(1:nrow(dat))) # int <- sp::SpatialLinesDataFrame(int, dat) # } # if (length(int) > 0) { # j <- which(rgeos::gIsValid(int, byid=TRUE, reason=FALSE)) # int <- int[j, ] # } # int@proj4string <- prj # int } ) setMethod('intersect', signature(x='SpatialLines', y='SpatialLines'), function(x, y) { # warning("this method will be removed. You can use 'terra::intersect' instead") as(intersect(vect(x), vect(y)), "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # gval <- rgeos::get_RGEOS_CheckValidity() # if (gval != 2) { # on.exit(rgeos::set_RGEOS_CheckValidity(gval)) # rgeos::set_RGEOS_CheckValidity(2L) # } # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # xdata <-.hasSlot(x, 'data') # ydata <-.hasSlot(y, 'data') # x <- sp::spChFIDs(x, as.character(1:length(x))) # y <- sp::spChFIDs(y, as.character(1:length(y))) # if (! any(c(xdata, ydata))) { # z <- rgeos::gIntersection(x, y, byid=TRUE) # if (is.null(z)) { # z <- sp::SpatialPoints(cbind(0,0), proj4string=prj) # z <- sp::SpatialPointsDataFrame(z,data.frame(x=0, y=0)) # return( z[-1, ] ) # } # rn <- rownames(z@coords) # d <- data.frame(matrix(as.integer(unlist(strsplit(rn, ' '))), ncol=2, byrow=TRUE)) # colnames(d) <- c('x', 'y') # rownames(z@coords) <- NULL # z <- sp::SpatialPointsDataFrame(z, d) # z@proj4string <- prj # return(z) # } # z <- rgeos::gIntersection(y, x, byid=TRUE) # if (is.null(z)) { # z <- sp::SpatialPoints(cbind(0,0), proj4string=prj) # return( z[-1, ] ) # } # if (inherits(z, 'SpatialCollections')) { # z <- z@pointobj # } # s <- strsplit(sp::spChFIDs(z), ' ') # s <- matrix(as.integer(unlist(s)), ncol=2, byrow=TRUE) # if (xdata & ydata) { # nms <- .goodNames(c(colnames(x@data), colnames(y@data))) # xnames <- nms[1:ncol(x@data)] # ynames <- nms[(ncol(x@data)+1):length(nms)] # xd <- x@data[s[,2], ] # yd <- y@data[s[,1], ] # d <- cbind(xd, yd) # colnames(d) <- c(xnames, ynames) # } else if (xdata) { # d <- x@data[s[,2], ] # } else if (ydata) { # d <- y@data[s[,1], ] # } # row.names(d) <- NULL # row.names(z) <- as.character(1:length(z)) # z@proj4string <- prj # sp::SpatialPointsDataFrame(z, d) } ) setMethod('intersect', signature(x='SpatialPolygons', y='SpatialPoints'), function(x, y) { # warning("this method will be removed. You can use 'terra::intersect' instead") as(intersect(vect(x), vect(y)), "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # gval <- rgeos::get_RGEOS_CheckValidity() # if (gval != 2) { # on.exit(rgeos::set_RGEOS_CheckValidity(gval)) # rgeos::set_RGEOS_CheckValidity(2L) # } # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # i <- rgeos::gIntersects(x, y, byid=TRUE) # i <- which(apply(i, 2, any)) # if (inherits(x, "Spatial")) { x@proj4string <- prj } # x[i, ] } ) setMethod('intersect', signature(x='SpatialPoints', y='ANY'), function(x, y) { # warning("this method will be removed. You can use 'terra::intersect' instead") if (inherits(y, 'SpatialLines')) { stop('intersect of SpatialPoints and Lines is not supported because of numerical inaccuracies.\nUse "buffer", to create polygons from the lines and use these in intersect') } if (inherits(y, 'SpatialPolygons')) { as(intersect(vect(x), vect(y)), "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # gval <- rgeos::get_RGEOS_CheckValidity() # if (gval != 2) { # on.exit(rgeos::set_RGEOS_CheckValidity(gval)) # rgeos::set_RGEOS_CheckValidity(2L) # } # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # i <- rgeos::gIntersects(y, x, byid=TRUE) # j <- cbind(1:length(y), rep(1:length(x), each=length(y)), as.vector(t(i))) # j <- j[j[,3] == 1, -3, drop=FALSE] # j <- j[order(j[,2]), ,drop=FALSE] # x <- x[j[,2], ] # if (.hasSlot(y, 'data')) { # d <- y@data[j[,1], ] # if (!.hasSlot(x, 'data')) { # x <- sp::SpatialPointsDataFrame(x, d) # } else { # x@data <- cbind(x@data, d) # } # } # x@proj4string <- prj # return(x) } else { y <- extent(y) xy <- sp::coordinates(x)[,1:2,drop=FALSE] i <- xy[,1] >= y@xmin & xy[,1] <= y@xmax & xy[,2] >= y@ymin & xy[,2] <= y@ymax x[i, ] } } ) setMethod('intersect', signature(x='SpatialPolygons', y='ANY'), function(x, y) { y <- extent(y) y <- as(y, 'SpatialPolygons') intersect(x, y) } ) raster/R/ifelse.R0000644000176200001440000000125614507510157013356 0ustar liggesusers# Author: Robert J. Hijmans # Date : May 2019 # Version 1.0 # Licence GPL v3 #setMethod("ifel", signature(test="Raster", yes="ANY", no="ANY"), .ifel <- function(test, yes, no, filename="", ...) { if (!inherits(no, "Raster")) { stopifnot(is.numeric(no)) if (length(no) > 1) warning('only the first element of "no" is used') no <- reclassify(test, rbind(c(0,no[1]), c(1,NA))) } else { no <- mask(no, test, maskvalue=TRUE) } if (!inherits(yes, "Raster")) { stopifnot(is.numeric(yes)) if (length(yes) > 1) warning('only the first element of "yes" is used') yes <- reclassify(test, rbind(c(1,yes[1]), c(0,NA))) } cover(no, yes, filename=filename) } #) raster/R/rasterFromFile.R0000644000176200001440000000644714507510157015042 0ustar liggesusers# R raster package # Date : September 2009 # Version 1.0 # Licence GPL v3 .rasterObjectFromFile <- function(x, band=1, objecttype='RasterLayer', native=FALSE, silent=TRUE, offset=NULL, ncdf=FALSE, ...) { x <- trim(x) if (x=="" | x==".") { # etc? stop('provide a valid filename') } # fix for opendap https://r-forge.r-project.org/forum/message.php?msg_id=5015 start <- tolower(substr(x, 1, 3)) if (! start %in% c('htt', 'ftp')) { y <- NULL try( y <- normalizePath( x, mustWork=TRUE), silent=TRUE ) if (! is.null(y)) { x <- y } } fileext <- toupper(extension(x)) if ((fileext == ".GRD") || (fileext == ".GRI")) { grifile <- .setFileExtensionValues(x, 'raster') grdfile <- .setFileExtensionHeader(x, 'raster') if ( file.exists( grdfile) && file.exists( grifile)) { return ( .rasterFromRasterFile(grdfile, band=band, objecttype, ...) ) } } if (! file.exists(x) ) { if (extension(x) == '') { grifile <- .setFileExtensionValues(x, 'raster') grdfile <- .setFileExtensionHeader(x, 'raster') if ( file.exists( grdfile) & file.exists( grifile)) { return ( .rasterFromRasterFile(grdfile, band=band, objecttype, ...) ) } else { # stop('file: ', x, ' does not exist') } } } #if (isTRUE(GMT)) { # return(.rasterObjectFromCDF_GMT(x)) #} if (( fileext %in% c(".HE5", ".NC", ".NCF", ".NC4", ".CDF", ".NCDF", ".NETCDF")) | (isTRUE(ncdf))) { return ( .rasterObjectFromCDF(x, type=objecttype, band=band, ...) ) } if ( fileext == ".GRD") { if (.isNetCDF(x)) { return ( .rasterObjectFromCDF(x, type=objecttype, band=band, ...) ) } } # if ( fileext == ".BIG" | fileext == ".BRD") { # return( .rasterFromRasterFile(x, band=band, objecttype, driver='big.matrix', ...) ) # } if (!is.null(offset)) { return ( .rasterFromASCIIFile(x, offset, ...) ) } ## MDSumner, NSIDC data if (fileext %in% c(".BIN")) { r <- .rasterFromNSIDCFile(x) if (!is.null(r)) return(r) } # if(!native) { # if (! .requireRgdal(FALSE) ) { # native <- TRUE # } # } if (native) { if ( fileext == ".ASC" ) { return ( .rasterFromASCIIFile(x, ...) ) } if ( fileext %in% c(".BIL", ".BIP", ".BSQ")) { return ( .rasterFromGenericFile(x, type=objecttype, ...) ) } if ( fileext %in% c(".RST", ".RDC") ) { # not tested much return ( .rasterFromIDRISIFile(x, ...) ) } if ( fileext %in% c(".DOC", ".IMG") ) { # not tested much return ( .rasterFromIDRISIFile(x, old=TRUE, ...)) } if ( fileext %in% c(".SGRD", ".SDAT") ) { # barely tested return ( .rasterFromSAGAFile(x, ...) ) } } # old IDRISI format if ( fileext == ".DOC" ) { if (file.exists( extension(x, '.img'))) { return( .rasterFromIDRISIFile(x, old=TRUE, ...)) } } if ( fileext %in% c(".SGRD", ".SDAT") ) { r <- .rasterFromSAGAFile(x, ...) if (r@file@toptobottom | r@data@gain != 1) { return(r) } # else use gdal } #if (! .requireRgdal(FALSE) ) { # stop("Cannot create RasterLayer object from this file; perhaps you need to install rgdal first") #} test <- try( r <- .rasterFromGDAL(x, band=band, objecttype, ...), silent=silent ) if (inherits(test, "try-error")) { if (!file.exists(x)) { stop("Cannot create a RasterLayer object from this file. (file does not exist)") } stop("Cannot create a RasterLayer object from this file.") } else { return(r) } } raster/R/names.R0000644000176200001440000000303014507510157013202 0ustar liggesusers# Author: Robert J. Hijmans # Date: October 2008 # Version 0.9 # Licence GPL v3 .uniqueNames <- function(x, sep='.') { dups <- unique(x[duplicated(x)]) for (dup in dups) { j <- which(x == dup) x[j] <- paste(x[j], sep, 1:length(j), sep='') } x } .goodNames <- function(ln, prefix='layer') { validNames(ln, prefix) } validNames <- function(x, prefix='layer') { x <- trim(as.character(x)) x[is.na(x)] <- "" if (.standardnames()) { x[x==''] <- prefix x <- make.names(x, unique=FALSE) } .uniqueNames(x) } setMethod('labels', signature(object='Raster'), function(object) { names(object) } ) setMethod('names', signature(x='Raster'), function(x) { if (.hasSlot(x@data, 'names')) { ln <- x@data@names } else { ln <- x@layernames } ln <- ln[1:nlayers(x)] validNames(as.vector(ln)) } ) setMethod('names', signature(x='RasterStack'), function(x) { ln <- sapply(x@layers, function(i) i@data@names) ln <- ln[1:nlayers(x)] validNames(as.vector(ln)) } ) setMethod('names<-', signature(x='Raster'), function(x, value) { nl <- nlayers(x) if (is.null(value)) { value <- rep('', nl) } else if (length(value) != nl) { stop('incorrect number of layer names') } value <- validNames(value) if (inherits(x, 'RasterStack')){ x@layers <- sapply(1:nl, function(i){ r <- x@layers[[i]] r@data@names <- value[i] r }) } else { if (.hasSlot(x@data, 'names')) { x@data@names <- value } else { x@layernames <- value } } return(x) } ) raster/R/focal.R0000644000176200001440000001750214507510157013174 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2011 # Version 1.0 # Licence GPL v3 .checkngb <- function(ngb, mustBeOdd=FALSE) { ngb <- as.integer(round(ngb)) if (length(ngb) == 1) { ngb <- c(ngb, ngb) } else if (length(ngb) > 2) { stop('ngb should be a single value or two values') } if (min(ngb) < 1) { stop("ngb should be larger than 1") } if (mustBeOdd) { if (any(ngb %% 2 == 0)) { stop('neighborhood size must be an odd number') } } return(ngb) } .wwarn <- function() { if (! isTRUE(options('rasterFocalWarningGiven'))) { warning('the computation of the weights matrix has changed in version 2.1-35. The sum of weights is now 1') options(rasterFocalWarningGiven=TRUE) } } .getW <- function(w) { if (length(w) == 1) { w <- round(w) stopifnot(w > 0) w <- matrix(1, ncol=w, nrow=w) w <- w / sum(w) .wwarn() } else if (length(w) == 2) { w <- round(w) w <- matrix(1, ncol=w[1], nrow=w[2]) w <- w / sum(w) .wwarn() } if (! is.matrix(w) ) { stop('w should be a single number, two numbers, or a matrix') } return(w) } setMethod('focal', signature(x='RasterLayer'), function(x, w, fun, filename='', na.rm=FALSE, pad=FALSE, padValue=NA, NAonly=FALSE, ...) { stopifnot(hasValues(x)) # mistakes because of differences with old focal and old focalFilter dots <- list(...) if (!is.null(dots$filter)) { warning('argument "filter" is ignored!') } if (!is.null(dots$ngb)) { warning('argument "ngb" is ignored!') } # w <- .getW(w) stopifnot(is.matrix(w)) d <- dim(w) if (prod(d) == 0) { stop('ncol and nrow of w must be > 0') } if (min(d %% 2) == 0) { stop('w must have uneven sides') } # to get the weights in the (by row) order for the C routine # but keeping nrow and ncol as-is w[] <- as.vector(t(w)) out <- raster(x) filename <- trim(filename) padrows <- FALSE if (pad) { padrows <- TRUE } gll <- as.integer(.isGlobalLonLat(out)) if (gll) { pad <- TRUE } # if (NAonly) { # na.rm <- TRUE # } dofun <- TRUE domean <- FALSE if (missing(fun)) { dofun <- FALSE domean <- FALSE } else { fun2 <- .makeTextFun(fun) if (is.character(fun2)) { if (fun2=='mean') { domean <- TRUE dofun <- FALSE } else if (fun2 == 'sum') { dofun <- FALSE } } } if (dofun) { if (na.rm) { runfun <- function(x) as.double( fun(x, na.rm=TRUE) ) } else { runfun <- function(x) as.double( fun(x) ) } } NAonly <- as.integer(NAonly) narm <- as.integer(na.rm) domean <- as.integer(domean) if (canProcessInMemory(out)) { if (pad) { # this should be done in C, but for now.... f <- floor(d / 2) v <- as.matrix(x) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) } else { if (dofun) { v <- .focal_fun(values(x), w, as.integer(dim(out)), runfun, NAonly) } else { v <- .focal_sum( values(x), w, as.integer(dim(out)), narm, NAonly, domean) } } out <- setValues(out, v) if (filename != '') { out <- writeRaster(out, filename, ...) } } else { out <- writeStart(out, filename,...) tr <- blockSize(out, minblocks=3, minrows=3) pb <- pbCreate(tr$n, label='focal', ...) addr <- floor(nrow(w) / 2) addc <- floor(ncol(w) / 2) nc <- ncol(out) nc1 <- 1:(nc * addc) if (pad) { f <- floor(d / 2) v <- getValues(x, row=1, nrows=tr$nrows[1]+addr) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[ , -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v, 1) pbStep(pb) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr)) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } i <- tr$n v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr) v <- matrix(v, ncol=ncol(out), byrow=TRUE) if (padrows) { padRows <- matrix(padValue, ncol=ncol(out), nrow=f[1]) v <- rbind(padRows, v, padRows) } if (gll) { v <- cbind(v[, (ncol(v)-f[2]+1):ncol(v)], v, v[, 1:f[2]]) } else { padCols <- matrix(padValue, nrow=nrow(v), ncol=f[2]) v <- cbind(padCols, v, padCols) } paddim <- as.integer(dim(v)) if (dofun) { v <- .focal_fun(as.vector(t(v)), w, paddim, runfun, NAonly) } else { v <- .focal_sum( as.vector(t(v)), w, paddim, narm, NAonly, domean) } v <- matrix(v, nrow=paddim[1], ncol=paddim[2], byrow=TRUE) if (padrows) { v <- v[-c(1:f[1], (nrow(v)-f[1]+1):nrow(v)), -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } else { v <- v[, -c(1:f[2], (ncol(v)-f[2]+1):ncol(v))] } v <- as.vector(t(v)) out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } else { v <- getValues(x, row=1, nrows=tr$nrows[1]+addr) if (dofun) { v <- .focal_fun(v, w, as.integer(c(tr$nrows[1]+addr, nc)), runfun, NAonly) } else { v <- .focal_sum( v, w, as.integer(c(tr$nrows[1]+addr, nc)), narm, NAonly, domean) } out <- writeValues(out, v, 1) pbStep(pb) for (i in 2:(tr$n-1)) { v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+(2*addr)) if (dofun) { v <- .focal_fun(v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), runfun, NAonly) } else { v <- .focal_sum( v, w, as.integer(c(tr$nrows[i]+(2*addr), nc)), narm, NAonly, domean) } out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } i <- tr$n v <- getValues(x, row=tr$row[i]-addr, nrows=tr$nrows[i]+addr) if (dofun) { v <- .focal_fun(v, w, as.integer(c(tr$nrows[i]+addr, nc)), runfun, NAonly) } else { v <- .focal_sum( v, w, as.integer(c(tr$nrows[i]+addr, nc)), narm, NAonly, domean) } out <- writeValues(out, v[-nc1], tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/gainoffset.R0000644000176200001440000000232014507510157014225 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2010 # Version 1.0 # Licence GPL v3 'gain<-' <- function(x, value) { value <- as.numeric(value[1]) if (inherits(x, 'RasterStack')) { x@layers <- lapply( x@layers, function(z) { if (fromDisk(z)) { z@data@gain <- value } else if (hasValues(z)) { z <- z * value } return(z) } ) } else { if (fromDisk(x)) { x@data@gain <- value } else if (hasValues(x)) { x <- x * value } } return(x) } gain <- function(x) { if (inherits(x, 'RasterStack')) { r <- sapply( x@layers, function(z) { z@data@gain } ) } else { r <- x@data@gain } return(r) } 'offs<-' <- function(x, value) { value <- as.numeric(value[1]) if (inherits(x, 'RasterStack')) { x@layers <- lapply( x@layers, function(z) { if (fromDisk(z)) { z@data@offset <- value } else if (hasValues(z)) { z <- z + value } return(z) } ) } else { if (fromDisk(x)) { x@data@offset <- value } else if (hasValues(x)) { x <- x + value } } return(x) } offs <- function(x) { if (inherits(x, 'RasterStack')) { r <- sapply( x@layers, function(z) { z@data@offset } ) } else { r <- x@data@offset } return(r) } raster/R/stackSelect.R0000644000176200001440000000351714507510157014356 0ustar liggesusers# Author: Robert J. Hijmans # Date: March 2011 # Version 1 # Licence GPL v3 if (!isGeneric("stackSelect")) { setGeneric("stackSelect", function(x, y, ...) standardGeneric("stackSelect")) } setMethod('stackSelect', signature(x='RasterStackBrick', y='Raster'), function(x, y, recycle=FALSE, type='index', filename='', ...) { filename <- trim(filename) out <- brick(x, values=FALSE) nlx <- nlayers(out) nly <- nlayers(y) compareRaster(out, y) if (recycle) { stopifnot(nly > 1) stopifnot(nlx > nly) stopifnot(nlx %% nly == 0) type <- tolower(type) stopifnot(type %in% c('index', 'truefalse')) nl <- nlx+nlx+nly maxnl <- nly nr <- nlx / nly id <- as.integer( (rep(1:nr, each=nly)-1) * nly ) } else { if (nly == 1) { out <- raster(out) } else { out@data@nlayers <- nlayers(y) } nl <- nlx+nly maxnl <- nlx id <- 0 } ib <- (nlx+1):(nlx+nly) if (canProcessInMemory(x, nl)) { y <- round(getValues(y)) if (type == 'truefalse') { y <- t(apply(y,1,function(x)x*(1:nly))) } y[y < 1 | y > maxnl] <- NA x <- cbind(getValues(x), y) x <- apply(x, 1, function(z) z[z[ib]+id] ) out <- setValues(out, t(x)) if (filename != "") { out <- writeRaster(out, filename=filename, ...) } } else { if (filename == '') { filename <- rasterTmpFile() } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=nlx+nly) pb <- pbCreate(tr$n, ...) for (i in 1:tr$n) { j <- round(getValues(y, row=tr$row[i], nrows=tr$nrows[i])) if (type == 'truefalse') { j <- t(apply(j, 1, function(x)x*(1:nly))) } j[j < 1 | j > maxnl] <- NA v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) v <- cbind(v, j) v <- apply(v, 1, function(z) z[z[ib]+id] ) out <- writeValues(out, t(v), tr$row[i]) pbStep(pb) } out <- writeStop(out) pbClose(pb) } return(out) } ) raster/R/filler.R0000644000176200001440000000104614507510157013361 0ustar liggesusers .filler <- function(x, y, maxv=12, circular=FALSE) { # should rewrite this using apply (or C) fill <- function(x, y) { r <- matrix(NA, nrow=length(x), ncol=maxv) if (circular) { for (i in 1:nrow(r)) { if (!is.na(y[i])) { if (x[i] < y[i]) { r[i, x[i]:y[i]] <- 1 } else { r[i, c(x[i]:maxv, 1:y[i])] <- 1 } } } r } else { for (i in 1:nrow(r)) { if (!is.na(y[i])) { r[i, x[i]:y[i]] <- 1 } } r } } x <- overlay(x, y, fun=fill) names(x) = paste('v', 1:maxv, sep='') x } raster/R/canProcessInMemory.R0000644000176200001440000000447714507510157015677 0ustar liggesusers# Authors: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 #.RAMavailable <- function(defmem=.maxmemory()) { # # if (useC) { # .availableRAM(defmem) # } else { # essentially the same results as above, but slower # if ( .Platform$OS.type == "windows" ) { # mem <- system2("wmic", args = "OS get FreePhysicalMemory /Value", stdout = TRUE) # mem3 <- gsub("\r", "", mem[3]) # mem3 <- gsub("FreePhysicalMemory=", "", mem3) # memavail <- as.numeric(mem3) * 1024 #memavail <- 0.5 * (utils::memory.size(NA) - utils::memory.size(FALSE)) # } else if ( .Platform$OS.type == "unix" ) { # mac is also "unix" and this does not work on mac # memavail <- as.numeric(system("awk '/MemFree/ {print $2}' /proc/meminfo", intern=TRUE)) # } else { #don't know how to do this on a mac # memavail <- defmem # } # } # memavail #} canProcessInMemory <- function(x, n=4, verbose=FALSE) { # for testing purposes # rasterOptions(format='GTiff') # requireNamespace("ncdf4") # rasterOptions(format='big.matrix') # rasterOptions(format='CDF') # rasterOptions(overwrite=TRUE) # rasterOptions(todisk=TRUE) # return(FALSE) if (.toDisk()) { return(FALSE) } nc <- ncell(x) # avoid vectors that are too long n <- n * nlayers(x) memneed <- nc * n * 8 if (memneed < .minmemory()) { if (verbose) { gb <- 1073741824 cat(" GB") cat(paste("\n needed :", round(memneed / gb, 2))) cat("below minmemory threshold") } return(TRUE) } maxmem <- .maxmemory() memavail <- .availableRAM(maxmem) if (verbose) { gb <- 1073741824 cat(" GB") cat(paste("\navailable :", round(memavail / gb, 2))) cat(paste0("\n ", round(100*.memfrac()) , "% : ", round(.memfrac() * memavail / gb, 2))) cat(paste("\n needed :", round(memneed / gb, 2))) cat(paste("\n allowed :", round(maxmem / gb, 2), " (if available)\n")) } if (nc > (2^31 -1)) return(FALSE) # can't use all of it; default is 60% memavail <- .memfrac() * memavail # the below allows you to safely set a high maxmem # but still limit total mem use memavail <- min(memavail, maxmem) if (memneed > memavail) { # new (hidden) option; the 0.25 could be another option # now you can only make it lower via chunksize options(rasterChunk = min(.chunksize(), memavail * 0.25)) return(FALSE) } else { return(TRUE) } } raster/R/click.R0000644000176200001440000001035714507510157013176 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 - December 2011 # Version 1.0 # Licence GPL v3 .getClicks <- function(...) { res <- list() while(TRUE) { loc <- graphics::locator(1, ...) if (is.null(loc)) break res <- c(res, loc) } matrix(res, ncol=2, byrow=TRUE) } .getCellFromClick <- function(x, n, type, id, ...) { loc <- graphics::locator(n, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=1:n) } cells <- cellFromXY(x, xyCoords) cells <- unique(stats::na.omit(cells)) if (length(cells) == 0 ) { stop('no valid cells selected') } cells } setMethod('click', signature(x='missing'), function(x, n=1, type="n", ...) { loc <- graphics::locator(n, type, ...) cbind(x=loc$x, y=loc$y) } ) setMethod('click', signature(x='SpatialGrid'), function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) { r <- raster(x) cells <- .getCellFromClick(r, n, type, id, ...) if (.hasSlot(x, 'data')) { value <- x@data[cells, ,drop=FALSE] } else { value <- NULL } if (cell) { value <- data.frame(cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } ) setMethod('click', signature(x='SpatialPixels'), function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) { r <- raster(x) cells <- .getCellFromClick(r, n, type, id, ...) if (.hasSlot(x, 'data')) { value <- x@data[cells, ,drop=FALSE] } else { value <- NULL } if (cell) { value <- data.frame(cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } ) .oldclick <- function(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) { cells <- .getCellFromClick(x, n, type, id, ...) value <- .cellValues(x, cells) if (is.null(dim(value))) { value <- matrix(value) colnames(value) <- names(x) } if (cell) { value <- data.frame(cell=cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } value } setMethod('click', signature(x='Raster'), function(x, n=Inf, id=FALSE, xy=FALSE, cell=FALSE, type="n", show=TRUE, ...) { values <- NULL i <- 0 n <- max(n, 1) while (i < n) { i <- i + 1 loc <- graphics::locator(1, type, ...) if (is.null(loc)) break xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=i) } cells <- stats::na.omit(cellFromXY(x, xyCoords)) if (length(cells) == 0) break value <- extract(x, cells) if (cell) { value <- data.frame(cell=cells, value) } if (xy) { xyCoords <- xyFromCell(x, cells) colnames(xyCoords) <- c('x', 'y') value <- data.frame(xyCoords, value) } if (show) { print(value) utils::flush.console() } if (is.null(dim(value))) { value <- matrix(value) colnames(value) <- names(x) } values <- rbind(values, value) } if (show) { invisible(values) } else { values } return(values) }) setMethod('click', signature(x='SpatialPolygons'), function(x, n=1, id=FALSE, xy=FALSE, type="n", ...) { loc <- graphics::locator(n, type, ...) xyCoords <- cbind(x=loc$x, y=loc$y) if (id) { text(xyCoords, labels=1:n) } xyCoords <- sp::SpatialPoints(xyCoords) xyCoords@proj4string <- x@proj4string i <- which(!is.na(sp::over(x, xyCoords))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } if (xy) { x <- cbind(xyCoords, x) } return(x) } ) setMethod('click', signature(x='SpatialLines'), function(x, ...) { e <- as(drawExtent(), 'SpatialPolygons') e@proj4string <- x@proj4string i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } x } ) setMethod('click', signature(x='SpatialPoints'), function(x, ...) { e <- as(drawExtent(), 'SpatialPolygons') e@proj4string <- x@proj4string i <- which(!is.na(sp::over(x, e))) if (length(i) > 0) { if (.hasSlot(x, 'data')) { x <- x@data[i,] } else { x <- row.names(x)[i] } } else { x <- NULL } x } ) raster/R/coverPolygons.R0000644000176200001440000000570214507510157014760 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 setMethod('cover', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y, ..., identity=FALSE){ # warning("this method will be removed. You can use 'terra::cover' instead") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) yy <- list(y, ...) i <- which(sapply(yy, function(x) inherits(x, 'SpatialPolygons'))) if (length(i)==0) { stop('additional arguments should be of class SpatialPolygons') } else if (length(i) < length(yy)) { warning('additional arguments that are not of class SpatialPolygons are ignored') yy <- yy[i] } x <- vect(x) for (y in yy) { x <- cover(x, vect(y), identity=identity, expand=FALSE) } x # if (identity) { # x <- .coverIdentity(x, yy) # if (inherits(x, "Spatial")) { x@proj4string <- prj } # return(x) # } # for (y in yy) { # y@proj4string <- sp::CRS(as.character(NA)) # subs <- rgeos::gIntersects(x, y, byid=TRUE) # if (!any(subs)) { # next # } else { # int <- crop(y, x) # x <- erase(x, int) # x <- bind(x, int) # } # } # x@proj4string <- prj # x } ) # .coverIdentity <- function(x, yy) { # for (y in yy) { # y@proj4string <- sp::CRS(as.character(NA)) # i <- rgeos::gIntersects(x, y) # if (!i) { # next # } # x <- sp::spChFIDs(x, as.character(1:length(x))) # y <- sp::spChFIDs(y, as.character(1:length(y))) # if (.hasSlot(x, 'data')) { # xnames <- colnames(x@data) # } else { # xnames <-NULL # } # if (.hasSlot(y, 'data')) { # ynames <- colnames(y@data) # } else { # ynames <-NULL # } # if (is.null(xnames) & !is.null(ynames)) { # dat <- y@data[NULL, ,drop=FALSE] # dat[1:length(x), ] <- NA # x <- sp::SpatialPolygonsDataFrame(x, dat) # xnames <- ynames # } # yinx <- which(ynames %in% xnames) # doAtt <- TRUE # if (length(yinx) == 0) { # doAtt <- FALSE # } # subs <- rgeos::gIntersects(x, y, byid=TRUE) # subsx <- apply(subs, 2, any) # subsy <- apply(subs, 1, any) # int <- rgeos::gIntersection(x[subsx,], y[subsy,], byid=TRUE, drop_lower_td=TRUE) # #if (inherits(int, "SpatialCollections")) { # # if (is.null(int@polyobj)) { # ?? # # warning('polygons do not intersect') # # next # # } # # int <- int@polyobj # #} # if (!inherits(int, 'SpatialPolygons')) { # warning('polygons do not intersect') # next # } # if (doAtt) { # ids <- do.call(rbind, strsplit(row.names(int), ' ')) # idsy <- match(ids[,2], rownames(y@data)) # rows <- 1:length(idsy) # dat <- x@data[NULL, ,drop=FALSE] # dat[rows, yinx] <- y@data[idsy, yinx] # int <- sp::SpatialPolygonsDataFrame(int, dat, match.ID=FALSE) # } # x <- erase(x, int) # if (is.null(x)) { # x <- int # } else { # x <- bind(x, int) # } # } # x # } raster/R/calc.R0000644000176200001440000001411314507510157013005 0ustar liggesusers# Author: Robert J. Hijmans & Matteo Mattiuzzi # Date : June 2008 # Version 0.9 # Licence GPL v3 .makeTextFun <- function(fun) { if (!inherits(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@generic == 'mean', silent=TRUE)) if (test1 | test2) { fun <- 'mean' } } } return(fun) } .getRowFun <- function(fun) { if (fun == 'mean') { return(rowMeans) } else if (fun == 'sum') { return(rowSums) } else if (fun == 'min') { return(.rowMin) } else if (fun == 'max') { return(.rowMax) } else { stop('unknown fun') } } .getColFun <- function(fun) { if (fun == 'mean') { return(colMeans) } else if (fun == 'sum') { return(colSums) } else if (fun == 'min') { return(.colMin) } else if (fun == 'max') { return(.colMax) } else { stop('unknown fun') } } .calcTest <- function(tstdat, fun, na.rm, forcefun=FALSE, forceapply=FALSE) { if (forcefun & forceapply) { forcefun <- FALSE forceapply <- FALSE } trans <- FALSE doapply <- FALSE makemat <- FALSE nl <- NCOL(tstdat) if (nl == 1) { # the main difference with nl > 1 is that # it is important to avoid using apply when a normal fun( ) call will do. # that is a MAJOR time saver. But in the case of a RasterStackBrick it is more # natural to try apply first. if (forceapply) { doapply <- TRUE makemat <- TRUE tstdat <- matrix(tstdat, ncol=1) if (missing(na.rm)) { test <- try( apply(tstdat, 1, fun), silent=TRUE) } else { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) } if (length(test) < length(tstdat) | inherits(test, "try-error")) { stop('cannot forceapply this function') } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } else { if (! missing(na.rm)) { test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) if (inherits(test, "try-error")) { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) doapply <- TRUE if (inherits(test, "try-error")) { stop("cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?") } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } } else { test <- try(fun(tstdat), silent=TRUE) if (length(test) < length(tstdat) | inherits(test, "try-error")) { doapply <- TRUE makemat <- TRUE tstdat <- matrix(tstdat, ncol=1) test <- try( apply(tstdat, 1, fun), silent=TRUE) if (inherits(test, "try-error")) { stop("cannot use this function") } if (is.matrix(test)) { if (ncol(test) > 1) { trans <- TRUE } } } } } } else { if (forcefun) { doapply <- FALSE test <- fun(tstdat) } else { doapply <- TRUE if (! missing(na.rm)) { test <- try( apply(tstdat, 1, fun, na.rm=na.rm), silent=TRUE) if (inherits(test, "try-error")) { doapply <- FALSE test <- try(fun(tstdat, na.rm=na.rm), silent=TRUE) if (inherits(test, "try-error")) { stop("cannot use this function. Perhaps add '...' or 'na.rm' to the function arguments?") } } else if (is.matrix(test)) { trans <- TRUE } } else { test <- try( apply(tstdat, 1, fun), silent=TRUE) if (inherits(test, "try-error")) { doapply <- FALSE test <- try(fun(tstdat), silent=TRUE) if (inherits(test, "try-error")) { stop("cannot use this function") } } else if (is.matrix(test)) { trans <- TRUE } } } } if (trans) { test <- t(test) test <- ncol(test) } else { test <- length(test) / 5 } nlout <- as.integer(test) list(doapply=doapply, makemat=makemat, trans=trans, nlout=nlout) } #.calcTest(test[1:5], fun, forceapply=T) setMethod('calc', signature(x='Raster', fun='function'), function(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) { nl <- nlayers(x) test <- .calcTest(x[1:5], fun, na.rm, forcefun, forceapply) doapply <- test$doapply makemat <- test$makemat trans <- test$trans nlout <- test$nlout if (nlout == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) out@data@nlayers <- nlout } fun <- .makeTextFun(fun) if (inherits(fun, 'character')) { doapply <- FALSE fun <- .getRowFun(fun) } filename <- trim(filename) estnl <- (nlayers(x) + nlayers(out)) * 2 if (canProcessInMemory(x, estnl)) { x <- getValues(x) if (makemat) { x <- matrix(x, ncol=1) } if (missing(na.rm)) { if (! doapply ) { x <- fun(x ) } else { x <- apply(x, 1, fun ) } } else { if ( ! doapply ) { x <- fun(x, na.rm=na.rm ) } else { x <- apply(x, 1, fun, na.rm=na.rm) } } if (trans) { x <- t(x) } x <- setValues(out, x) if (filename != '') { x <- writeRaster(x, filename, ...) } return(x) } # else x <- readStart(x) out <- writeStart(out, filename=filename, ...) tr <- blockSize(out, n=estnl) pb <- pbCreate(tr$n, label='calc', ...) if (missing(na.rm)) { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if ( ! doapply ) { v <- fun(v) if (nlout > 1 && !is.matrix(v)) { v <- matrix(v, ncol=nlout) } } else { if (makemat) { v <- matrix(v, ncol=1) } v <- apply(v, 1, fun) if (trans) { v <- t(v) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb) } } else { for (i in 1:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) if ( ! doapply ) { v <- fun(v, na.rm=na.rm) if (nlout > 1 && !is.matrix(v)) { v <- matrix(v, ncol=nlout) } } else { if (makemat) { v <- matrix(v, ncol=1) } v <- apply(v, 1, fun, na.rm=na.rm) if (trans) { v <- t(v) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb) } } out <- writeStop(out) x <- readStop(x) pbClose(pb) return(out) } ) raster/R/plotRGB.R0000644000176200001440000000714414507510157013422 0ustar liggesusers# Author: Robert J. Hijmans # Date : April 2010 # Version 0.9 # Licence GPL v3 # partly based on functions in the pixmap package by Friedrich Leisch setMethod("plotRGB", signature(x='RasterStackBrick'), function(x, r=1, g=2, b=3, scale, maxpixels=500000, stretch=NULL, ext=NULL, interpolate=FALSE, colNA='white', alpha, bgalpha, addfun=NULL, zlim=NULL, zlimcol=NULL, axes=FALSE, xlab='', ylab='', asp=NULL, add=FALSE, margins=FALSE, ...) { x <- x[[c(r, g, b)]] if (missing(scale)) { scale <- 255 if (! inherits(x, 'RasterStack')) { if ( x@data@haveminmax ) { scale <- max(max(x@data@max), 255) } } } scale <- as.vector(scale)[1] r <- sampleRegular(raster(x,1), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) g <- sampleRegular(raster(x,2), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) b <- sampleRegular(raster(x,3), maxpixels, ext=ext, asRaster=TRUE, useGDAL=TRUE) RGB <- cbind(getValues(r), getValues(g), getValues(b)) if (!is.null(zlim)) { if (length(zlim) == 2) { zlim <- sort(zlim) if (is.null(zlimcol)) { RGB[ RGBzlim[2] ] <- zlim[2] } else { #if (is.na(zlimcol)) { RGB[RGBzlim[2]] <- NA } } else if (NROW(zlim) == 3 & NCOL(zlim) == 2) { for (i in 1:3) { zmin <- min(zlim[i,]) zmax <- max(zlim[i,]) if (is.null(zlimcol)) { RGB[RGB[,i] < zmin, i] <- zmin RGB[RGB[,i] > zmax, i] <- zmax } else { #if (is.na(zlimcol)) { RGB[RGB < zmin | RGB > zmax, i] <- NA } } } else { stop('zlim should be a vector of two numbers or a 3x2 matrix (one row for each color)') } } RGB <- stats::na.omit(RGB) if (!is.null(stretch)) { stretch = tolower(stretch) if (stretch == 'lin') { RGB[,1] <- .linStretchVec(RGB[,1]) RGB[,2] <- .linStretchVec(RGB[,2]) RGB[,3] <- .linStretchVec(RGB[,3]) scale <- 255 } else if (stretch == 'hist') { RGB[,1] <- .eqStretchVec(RGB[,1]) RGB[,2] <- .eqStretchVec(RGB[,2]) RGB[,3] <- .eqStretchVec(RGB[,3]) scale <- 255 } else if (stretch != '') { warning('invalid stretch value') } } naind <- as.vector( attr(RGB, "na.action") ) if (!is.null(naind)) { bg <- grDevices::col2rgb(colNA) bg <- grDevices::rgb(bg[1], bg[2], bg[3], alpha=bgalpha, maxColorValue=255) z <- rep( bg, times=ncell(r)) z[-naind] <- grDevices::rgb(RGB[,1], RGB[,2], RGB[,3], alpha=alpha, maxColorValue=scale) } else { z <- grDevices::rgb(RGB[,1], RGB[,2], RGB[,3], alpha=alpha, maxColorValue=scale) } z <- matrix(z, nrow=nrow(r), ncol=ncol(r), byrow=T) requireNamespace("grDevices") bb <- as.vector(t(bbox(r))) if (!add) { if ((!axes) & (!margins)) { graphics::par(plt=c(0,1,0,1)) } if (is.null(asp)) { if (couldBeLonLat(x)) { ym <- mean(c(x@extent@ymax, x@extent@ymin)) asp <- 1/cos((ym * pi)/180) #asp <- min(5, 1/cos((ym * pi)/180)) } else { asp <- 1 } } xlim=c(bb[1], bb[2]) ylim=c(bb[3], bb[4]) plot(NA, NA, xlim=xlim, ylim=ylim, type = "n", xaxs='i', yaxs='i', xlab=xlab, ylab=ylab, asp=asp, axes=FALSE, ...) if (axes) { xticks <- graphics::axTicks(1, c(xmin(r), xmax(r), 4)) yticks <- graphics::axTicks(2, c(ymin(r), ymax(r), 4)) if (xres(r) %% 1 == 0) xticks = round(xticks) if (yres(r) %% 1 == 0) yticks = round(yticks) graphics::axis(1, at=xticks) graphics::axis(2, at=yticks, las = 1) #graphics::axis(3, at=xticks, labels=FALSE, lwd.ticks=0) #graphics::axis(4, at=yticks, labels=FALSE, lwd.ticks=0) } } graphics::rasterImage(z, bb[1], bb[3], bb[2], bb[4], interpolate=interpolate, ...) if (!is.null(addfun)) { if (is.function(addfun)) { addfun() } } } ) raster/R/zoom.R0000644000176200001440000000273614507510157013077 0ustar liggesusers# R function for the raster package # Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 setMethod('zoom', signature(x='Raster'), function(x, ext=drawExtent(), maxpixels=100000, layer=1, new=TRUE, useRaster=TRUE, ...) { if (is.function(ext)) { ext <- ext # force to start with drawing before creating a new graphics device } else { ext <- extent(ext) } if (new) { grDevices::dev.new() } if (nlayers(x) > 1) { x <- raster(x, layer) } if (length(colortable(x)) > 0) { .plotCT(x, maxpixels=maxpixels, ext=ext, ...) } else if (useRaster) { .plotraster2(x, maxpixels=maxpixels, ext=ext, ...) } else { .plotraster(x, col=col, maxpixels=maxpixels, ...) } return(invisible(ext)) } ) setMethod('zoom', signature(x='Spatial'), function(x, ext=drawExtent(), new=TRUE, ...) { if (is.function(ext)) { ext <- ext # force to start with drawing before creating a new graphics device } else { ext <- extent(ext) } if (new) { grDevices::dev.new() } sp::plot(x, xlim=c(ext@xmin, ext@xmax), ylim=c(ext@ymin, ext@ymax), ...) return(invisible(ext)) } ) setMethod('zoom', signature(x='missing'), function(x, ext=drawExtent(), new=TRUE, ...) { if (is.function(ext)) { ext <- ext # force to start with drawing before creating a new graphics device } else { ext <- extent(ext) } if (new) { grDevices::dev.new() } plot(0, xlim=c(ext@xmin, ext@xmax), ylim=c(ext@ymin, ext@ymax), type='n', ...) return(invisible(ext)) } ) raster/R/blend.R0000644000176200001440000000610214507510157013166 0ustar liggesusers# Authors: Rafael Wueest, WSL Birmensdorf, Switzerland, rafael.wueest@wsl.ch, # Etienne B. Racine, Robert J. Hijmans # Date : November 2012 # Version 1.0 # Licence GPL v3 # needs to be generalized to n input rasters and to multi-layer objects .old_blend <- function(r1, r2) { i <- intersect(raster(r1), raster(r2)) j <- extend(i, c(1,1)) a <- crop(r1, j) b <- crop(r2, j) values(a) <- 1 values(b) <- 2 ab <- merge(a, b) ba <- merge(b, a) p1 <- rasterToPoints(ab, function(x) x==2) p2 <- rasterToPoints(ba, function(x) x==1) d1 <- distanceFromPoints(i, p1[,1:2]) d2 <- distanceFromPoints(i, p2[,1:2]) dsum <- d1 + d2 z1 <- d1 * crop(r1, d1) / dsum z2 <- d2 * crop(r2, d2) / dsum merge(z1 + z2, r1, r2) } .blend <- function(x, y, logistic=FALSE, filename='', ...) { # check for difference in extent stopifnot( extent(x) != extent(y)) # define logistic function if (logistic) { G <- 1 f <- 0.001 k <- log(G/f-1)/(0.5*G) logfun <- function(x) { G /(1+exp(-k*G*x)*(G/f-1)) } } # create intersection rasters i <- intersect(raster(x), raster(y)) j <- extend(i, c(1,1)) # is one of the rasters nested within the other? ex <- extent(x) ey <- extent(y) exy <- union(ex, ey) if (exy==ex | exy==ey){ # the nested case # which raster has the smaller extent? if (extent(x) < extent(y)){ rlarge <- y rsmall <- x } else { rlarge <- x rsmall <- y } # create points around nested raster a <- crop(rlarge, j) a <- setValues(a, 1) b <- crop(rsmall, j) b <- setValues(b, 2) ba <- merge(b, a) p <- rasterToPoints(ba, function(x) x==1) # calculate distances to points in nested raster d <- distanceFromPoints(i, p[,1:2]) # standardize these distances dmin <- cellStats(d,'min') d.sc <- (d - dmin + 1e-9) / (cellStats(d,'max') - dmin) # the logistic case if(logistic){ d.sc<-logfun(d.sc) } # create distance weighted rasters z1 <- d.sc * crop(rsmall, d.sc) z2 <- abs(1-d.sc) * crop(rlarge, d.sc) # merge rasters m <- merge(z1 + z2, rsmall, rlarge, filename=filename, ...) } else { # the overlapping case # create points around ovelapping area a <- crop(x, j) a <- setValues(a, 1) b <- crop(y, j) b <- setValues(b, 2) ab <- merge(a, b) ba <- merge(b, a) p1 <- rasterToPoints(ab, function(x) x==2) p2 <- rasterToPoints(ba, function(x) x==1) # calculate distances to points in overlapping area d1 <- distanceFromPoints(i, p1[,1:2]) d2 <- distanceFromPoints(i, p2[,1:2]) # the logistic case if(logistic){ d1min <- cellStats(d1,'min') d2min <- cellStats(d2,'min') d1 <- logfun((d1 - d1min + 1e-9)/(cellStats(d1,'max') - d1min)) d2 <- logfun((d2 - d2min + 1e-9)/(cellStats(d2,'max') - d2min)) } # sum distance rasters dsum <- d1 + d2 # create distance weighted rasters z1 <- d1 * crop(x, d1) / dsum z2 <- d2 * crop(y, d2) / dsum z <- sum(z1, z2) # merge rasters m <- merge(z, x, y, filename=filename, ...) } m } raster/R/randomize.R0000644000176200001440000000042114507510157014070 0ustar liggesusers .randomize <- function(x, ...) { if (!hasValues(x)) { return(x) } nl <- nlayers(x) if (nl > 1) { y <- brick(x, values=FALSE) for (i in 1:nl) { y <- setValues(y, sample(getValues(x[[i]])), layer=i) } y } else { setValues(x, sample(getValues(x))) } } raster/R/boxplot.R0000644000176200001440000000233014507510157013570 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2010 # Version 1.0 # Licence GPL v3 setMethod('boxplot', signature(x='RasterStackBrick'), function(x, maxpixels=100000, ...) { nl <- nlayers(x) cn <- names(x) if ( canProcessInMemory(x)) { x <- getValues(x) } else { warning('taking a sample of ', maxpixels, ' cells') x <- sampleRegular(x, maxpixels, useGDAL=TRUE) } colnames(x) <- cn boxplot(x, ...) } ) setMethod('boxplot', signature(x='RasterLayer'), function(x, y=NULL, maxpixels=100000, ...) { if (is.null(y)) { cn <- names(x) if ( canProcessInMemory(x)) { x <- getValues(x) } else { warning('taking a sample of ', maxpixels, ' cells') x = sampleRegular(x, maxpixels, useGDAL=TRUE) } x <- matrix(x) colnames(x) <- cn boxplot(x, ...) } else { s <- stack(x, y) if ( canProcessInMemory(s)) { s <- getValues(s) } else { warning('taking a sample of ', maxpixels, ' cells') s <- sampleRegular(s, maxpixels, useGDAL=TRUE) } cn <- colnames(s) if (is.null(cn)) { #apparently this can happen. cn <- c('layer1', 'layer2') colnames(s) <- cn } f <- stats::as.formula(paste(cn[1], '~', cn[2])) boxplot(f, data=s, ...) } } ) raster/R/gridDistance2.R0000644000176200001440000000361214507510157014567 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 .gridDistance2 <- function(x, filename='', ...) { # currently only works for planar data! rs <- res(x) xdist <- rs[1] ydist <- rs[2] xydist <- sqrt(xdist^2 + ydist^2) z1 <- z2 <- raster(x) nc <- ncol(z1) filename <- trim(filename) if (canProcessInMemory(z1)) { f <- rep(Inf, nc) z1a <- z2a <- raster(x) x <- getValues(x) a <- as.integer(dim(z1)) b <- c(xdist, ydist, xydist) z1a[] <- .broom(x, f, a, b, TRUE) z2a[] <- .broom(x, f, a, b, FALSE) x <- min(z1a, z2a) if (filename != "") { x <- writeRaster(x, filename, ...) } } else { tr <- blockSize(z1) pb <- pbCreate(tr$n*2, ...) z1 <- writeStart(z1, rasterTmpFile()) i <- 1 v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) f <- rep(Inf, nc) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), TRUE) z1 <- writeValues(z1, z, tr$row[i]) f <- z[(length(z)-nc+1):length(z)] for (i in 2:tr$n) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), TRUE) z1 <- writeValues(z1, z, tr$row[i]) f <- z[(length(z)-nc+1):length(z)] pbStep(pb, i) } z1 <- writeStop(z1) z2 <- writeStart(z2, rasterTmpFile()) i <- tr$n v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) f <- rep(Inf, nc) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), TRUE) z2 <- writeValues(z2, z, tr$row[i]) f <- z[1:nc] for (i in (tr$n-1):1) { v <- getValues(x, row=tr$row[i], nrows=tr$nrows[i]) z <- .broom(v, f, as.integer(c(tr$nrows[i], nc)), c(xdist, ydist, xydist), FALSE) z2 <- writeValues(z2, z, tr$row[i]) f <- z[1:nc] pbStep(pb, i) } z2 <- writeStop(z2) x <- calc(stack(z1, z2), fun=min, filename=filename, ...) file.remove(filename(z1)) file.remove(filename(z2)) } return(x) } raster/R/distanceFromPoints.R0000644000176200001440000000232614507510157015721 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 distanceFromPoints <- function(object, xy, filename='', ...) { pts <- .pointsToMatrix(xy) filename <- trim(filename) if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE } out <- raster(object) a = 6378137.0 f = 1/298.257223563 if (canProcessInMemory(out, 4)) { xy <- xyFromCell(out, 1:ncell(out)) out <- setValues(out, .Call('_raster_distanceToNearestPoint', xy, pts, longlat, a, f , PACKAGE = 'raster')) if (filename != '') { out <- writeRaster(out, filename=filename, ...) } return(out) } out <- writeStart(out, filename=filename, ...) tr <- blockSize(out) pb <- pbCreate(tr$n, ...) xy <- cbind(rep(xFromCol(out, 1:ncol(out)), tr$nrows[1]), NA) for (i in 1:tr$n) { if (i == tr$n) { xy <- xy[1:(ncol(out)*tr$nrows[i]), ] } xy[,2] <- rep(yFromRow(out, tr$row[i]:(tr$row[i]+tr$nrows[i]-1)), each=ncol(out)) vals <- .Call('_raster_distanceToNearestPoint', xy, pts, longlat, a, f, PACKAGE='raster') out <- writeValues(out, vals, tr$row[i]) pbStep(pb) } pbClose(pb) out <- writeStop(out) return(out) } raster/R/distanceRows.R0000644000176200001440000000357214507510157014557 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2009 # Version 0.9 # Licence GPL v3 .distanceRows <- function(object, filename, progress='', ...) { filename <- trim(filename) overwrite <- .overwrite(...) if( (!overwrite) & file.exists(filename)) { stop('file exists; use overwrite=TRUE to overwrite it') } if (couldBeLonLat(object)) { longlat=TRUE } else { longlat=FALSE } e <- boundaries(object, classes=FALSE, type='inner', asNA=TRUE) r <- raster(object) tr <- blockSize(r, n=3) tmp = rasterTmpFile() extension(tmp) = '.tif' #.requireRgdal() r <- writeStart(r, filename=tmp, format='GTiff') pb <- pbCreate(tr$n, progress=progress) xx <- xFromCol( r, 1:ncol(r) ) hasWritten=FALSE for (i in 1:tr$n) { # get the from points for a block v <- getValuesBlock(e, row=tr$row[i], nrows=tr$nrows[i]) x <- rep(xx, tr$nrows[i]) y <- yFromRow(r, tr$row[i]) - (0:(tr$nrows[i]-1)) * yres(r) y <- rep(y, each=ncol(r)) xyv <- cbind(x,y,v) from <- stats::na.omit(xyv)[,1:2] if (isTRUE(nrow(from)==0)) { pbStep(pb, i) next } for (j in 1:tr$n) { # distance to these points for all blocks x <- rep(xx, tr$nrows[j]) y <- yFromRow(r, tr$row[j]) - (0:(tr$nrows[j]-1)) * yres(r) y <- rep(y, each=ncol(r)) v <- getValuesBlock(object, row=tr$row[j], nrows=tr$nrows[j]) xyv <- cbind(x,y,v) to <- xyv[is.na(xyv[,3]), 1:2] v[] = 0 if ( isTRUE(nrow(to) > 0) ) { v[is.na(xyv[,3])] <- .Call('_raster_distanceToNearestPoint', to, from, longlat, 6378137.0, 1/298.257223563, PACKAGE='raster') } if (hasWritten) { # after the first round, compare new values with previously written values v <- pmin(v, .getTransientRows(r, tr$row[j], n=tr$nrows[j])) } r <- writeValues(r, v, tr$row[j]) } hasWritten = TRUE pbStep(pb, i) } r <- writeStop(r) pbClose(pb) r <- writeRaster(r, filename=filename, ...) return(r) } raster/R/hdrBov.R0000644000176200001440000000204014507510157013323 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 0.9 # Licence GPL v3 .writeHdrBOV <- function(raster) { hdrfile <- filename(raster) extension(hdrfile) <- '.bov' thefile <- file(hdrfile, "w") # open an txt file connectionis cat("TIME: 1.23456", "\n", file = thefile) datf <- filename(raster) extension(datf) <- '.gri' cat("DATA_FILE:", datf, "\n", file = thefile) cat("DATA_SIZE:", nrow(raster), ncol(raster), nlayers(raster), "\n", file = thefile) dtype <- substr(raster@file@datanotation, 1, 3) if (dtype == 'INT' | dtype == 'LOG' ) { pixtype <- "INT" } else { pixtype <- "FLOAT" } cat("DATA_FORMAT:", pixtype, "\n", file = thefile) cat("VARIABLE: ", basename(filename(raster)), "\n", file = thefile) cat("BYTEORDER ", toupper(.Platform$endian), "\n", file = thefile) cat("CENTERING: zonal", "\n", file = thefile) cat("BRICK_ORIGIN:", xmin(raster), ymin(raster), "0.", "\n", file = thefile) cat("BRICK_SIZE:", xres(raster), yres(raster), "1.", "\n", file = thefile) close(thefile) return(invisible(TRUE)) } raster/R/cropSpatial.R0000644000176200001440000000632214507510157014367 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod('crop', signature(x='Spatial', y='ANY'), function(x, y, ...) { # warning("this method will be removed. You can use 'terra::crop' instead") if (inherits(y, "Extent")) { y = ext(y) } else { y <- extent(y) methods::validObject(y) y <- as(y, 'SpatialPolygons') y = vect(y) } x <- vect(x) z <- crop(x, y) return(as(z, "Spatial")) # if (! inherits(y, 'SpatialPolygons')) { # if (inherits(y, 'Extent')) { # y <- as(y, 'SpatialPolygons') # } else { # y <- extent(y) # methods::validObject(y) # y <- as(y, 'SpatialPolygons') # } # y@proj4string <- x@proj4string # } # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- sp::CRS(as.character(NA)) # y@proj4string <- sp::CRS(as.character(NA)) # if (inherits(y, 'SpatialPolygons')) { # y <- rgeos::gUnaryUnion(y) # row.names(y) <- '1' # y <- sp::geometry(y) # } # if (inherits(x, 'SpatialPolygons')) { # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # x <- .cropSpatialPolygons(x, y, ...) # } else if (inherits(x, 'SpatialLines')) { # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # x <- .cropSpatialLines(x, y, ...) # } else if (inherits(x, 'SpatialPoints')) { # x <- .cropSpatialPoints(x, y, ...) # } else { # x <- x[y] # } # if (inherits(x, "Spatial")) { x@proj4string <- prj } # x } ) # .cropSpatialPolygons <- function(x, y, ...) { # rnx <- row.names(x) # row.names(x) <- as.character(1:length(rnx)) # if (.hasSlot(x, 'data')) { # # to keep the correct IDs # # in future versions of rgeos, this intermediate step won't be necessary # i <- as.vector( rgeos::gIntersects(x, y, byid=TRUE) ) # if (sum(i) == 0) { # return(NULL) # } # y <- rgeos::gIntersection(x[i,], y, byid=TRUE, drop_lower_td=TRUE) # if (inherits(y, "SpatialCollections")) { # y <- y@polyobj # } # if (is.null(y)) { return(y) } # ids <- strsplit(row.names(y), ' ') # ids <- as.numeric(do.call(rbind, ids)[,1]) # row.names(y) <- as.character(rnx[ids]) # data <- x@data[ids, ,drop=FALSE] # rownames(data) <- rnx[ids] # return( sp::SpatialPolygonsDataFrame(y, data) ) # } else { # y <- rgeos::gIntersection(x, y, drop_lower_td=TRUE) # #if (inherits(y, "SpatialCollections")) { # # y <- y@polyobj # #} # return(y) # } # } # .cropSpatialLines <- function(x, y, ...) { # rnx <- row.names(x) # row.names(x) <- as.character(1:length(rnx)) # xy <- rgeos::gIntersection(x, y, byid=TRUE) # if (inherits(xy, "SpatialCollections")) { # xy <- xy@lineobj # } # if (.hasSlot(x, 'data')) { # ids <- strsplit(row.names(xy), ' ') # ids <- as.numeric(do.call(rbind, ids)[,1]) # #row.names(y) <- as.character(rnx[ids]) # data <- x@data[ids, ,drop=FALSE] # #rownames(data) <- rnx[ids] # xy <- sp::SpatialLinesDataFrame(xy, data, match.ID = FALSE) # } # return(xy) # } # .cropSpatialPoints <- function(x, y, ...) { # i <- which(!is.na(sp::over(x, y))) # if (length(i) > 0) { # x <- x[i,] # } else { # x <- NULL # } # x # } raster/R/animate.R0000644000176200001440000000121514507510157013520 0ustar liggesusers setMethod('animate', signature(x='RasterStackBrick'), function(x, pause=0.25, main, zlim, maxpixels=50000, n=10, ...) { nl <- nlayers(x) if (missing(main)) { main <- getZ(x) if (is.null(main)) { main <- names(x) } } x <- sampleRegular(x, size=maxpixels, asRaster=TRUE, useGDAL=TRUE) if (missing(zlim)) { zlim <- c(min(minValue(x)), max(maxValue(x))) } i <- 1 reps <- 0 while (reps < n) { plot(x[[i]], main = main[i], zlim=zlim, maxpixels=Inf, ...) grDevices::dev.flush() Sys.sleep(pause) i <- i + 1 if (i > nl) { i <- 1 reps <- reps+1 } } } ) #anim(st, tvals) raster/R/hdrWorldFile.R0000644000176200001440000000103114507510157014463 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .worldFile <- function(raster, extension=".wld") { hdrfile <- filename(raster) extension(hdrfile) <- extension thefile <- file(hdrfile, "w") cat(as.character(xres(raster)), "\n", file = thefile) cat("0\n", file = thefile) cat("0\n", file = thefile) cat(-1 * yres(raster), "\n", file = thefile) cat(xmin(raster) + 0.5 * xres(raster), "\n", file = thefile) cat(ymax(raster) - 0.5 * yres(raster), "\n", file = thefile) close(thefile) } raster/R/metadata.R0000644000176200001440000000134114507510157013662 0ustar liggesusers setMethod('metadata', signature(x='Raster'), function(x) { x@history } ) 'metadata<-' <- function(x, value) { stopifnot(is.list(value)) if (is.data.frame(values)) { values <- as.list(values) } if ( any(unlist(sapply(value, function(x)sapply(x, is.list)))) ) { stop('invalid metadata: list is nested too deeply') } nms <- c(names(value), unlist(sapply(value, names))) if (is.null(names) | any(nms == '')) { stop('invalid metadata: list elements without names') } if (any(unlist(sapply(value, is.data.frame)) )) { stop('invalid metadata: data.frames are not allowed') } type <- rapply(value, class) if (any(type == 'matrix')) { stop('invalid metadata: matrices are not allowed') } x@history <- value x } raster/R/writeStartStopGDAL.R0000644000176200001440000000654414507510740015560 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .rasterNodatavalue <- function(x){ if (x == 'FLT4S') return(-3.4E38) if (x == 'FLT8S') return(-1.7E308) if (x == 'INT4S') return(-2147483647) if (x == 'INT2S') return(-32768) if (x == 'INT1S') return(-128) if (x == 'INT1U') return(255) if (x == 'INT2U') return(65535) if (x == 'INT4U') return(2147483647) #(4294967295) <- not supported as integer in R NA } .startGDALwriting <- function(x, filename, gdal=NULL, setStatistics=TRUE, overwrite=FALSE, NAflag=NA, format="", datatype=NA, sources = "", ...) { #temp <- .getGDALtransient(x, filename=filename, options=options, ...) #attr(x@file, "transient") <- temp[[1]] #x@file@nodatavalue <- temp[[2]] #attr(x@file, "options") <- temp[[3]] #attr(x@file, "stats") <- setStatistics #x@data@min <- rep(Inf, nlayers(x)) #x@data@max <- rep(-Inf, nlayers(x)) #x@data@haveminmax <- FALSE #x@file@datanotation <- .getRasterDType(temp[[4]]) ct <- colortable(x) if (length(ct) > 0 ) { hasCT <- TRUE if (is.na(datatype)) { datatype <- 'INT1U' } else { datatype <- .datatype(datatype) } } else { hasCT <- FALSE datatype <- .datatype(datatype) } if (is.na(NAflag)) { NAflag <- .rasterNodatavalue(datatype) } if (nlayers(x) > 1) { rr <- brick(x, values=FALSE) } else { rr <- raster(x) } r <- as(rr, "SpatRaster") # raster does not write names names(r) <- rep("", nlyr(r)) # names(r) <- names(x) # nms <- paste0(extension(basename(filename), ""), "_") # names(r) <- paste0(nms, 1:nlyr(r)) # if (!isTRUE(setStatistics)) ops$statistics = 6 writeStart(r, filename, overwrite=overwrite, gdal=gdal, filetype=format, datatype=datatype, progress=0, NAflag=NAflag, progressbar=FALSE, sources=sources) if (inherits(x, "RasterStack")) { x <- brick(x, values=FALSE) } attr(x@file, "transient") <- r x@file@datanotation <- datatype x@file@driver <- 'gdal' x@data@fromdisk <- TRUE x@file@name <- filename return(x) } .stopGDALwriting <- function(x, stat=cbind(NA,NA)) { x <- attr(x@file, "transient") x <- writeStop(x) f <- sources(x) if (nlyr(x) == 1) { return(raster(f)) } else { return(brick(f)) } # statistics <- cbind(x@data@min, x@data@max) # if (substr(x@file@datanotation, 1, 1) != 'F') { # statistics <- round(statistics) # } # if (isTRUE( attr(x@file, "stats") ) ) { # statistics <- cbind(statistics, stat[,1], stat[,2]) # # could do wild guesses to avoid problems in other software # # but not sure if this cure would be worse. Could have an option to do this # #i <- is.na(statistics[,3]) # #if (sum(i) > 0) { # # statistics[i, 3] <- (statistics[i, 1] + statistics[i, 2]) / 2 # # statistics[i, 4] <- statistics[i, 3] * 0.2 # #} # for (i in 1:nl) { # b <- methods::new("GDALRasterBand", x@file@transient, i) # rgdal::GDALcall(b, "SetStatistics", as.double(statistics[i,])) # } # } # if(x@file@options[1] != "") { # rgdal::saveDataset(x@file@transient, x@file@name, options=x@file@options) # } else { # rgdal::saveDataset(x@file@transient, x@file@name) # } # rgdal::GDAL.close(x@file@transient) # if (nl > 1) { # out <- brick(x@file@name) # } else { # out <- raster(x@file@name) # } # if (! out@data@haveminmax ) { # out@data@min <- statistics[, 1] # out@data@max <- statistics[, 2] # out@data@haveminmax <- TRUE # } #return(out) } raster/R/gdalFormats.R0000644000176200001440000000571714507510157014360 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .isSupportedFormat <- function(dname) { #res <- dname %in% c(.nativeDrivers(), 'ascii', 'big.matrix', 'CDF') res <- dname %in% c(.nativeDrivers(), 'ascii', 'CDF') if (!res) { res <- .isSupportedGDALFormat(dname) } return(res) } .gdalWriteFormats <- function() { # .requireRgdal() # gd <- rgdal::gdalDrivers() # gd <- as.matrix( gd[gd[,3] == T, ] ) gd <- gdal(drivers=TRUE) gd$b <- TRUE gd <- gd[(gd$type=="raster") & (gd$can=="read/write"), c(1, 5, 6, 6, 2)] names(gd) <- c("name", "long_name", "create", "copy", "isRaster") 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 GDAL, changed to 4 byte integer values') } if (! dataSigned(dtype) ) { if (size == 8) { return('Byte') } else { type <- paste('U', type, sep='') } } } else { type <- 'Float' } return(paste(type, size, sep='')) } .getRasterDType <- function(dtype) { if (!(dtype %in% c('Byte', 'UInt16', 'Int16', 'UInt32','Int32', 'Float32', 'Float64', 'CInt16', 'CInt32', 'CFloat32', 'CFloat64'))) { return ('FLT4S') } else if (dtype == 'Byte') { return('INT1U') } else if (dtype == 'UInt16') { return('INT2U') } else if (dtype == 'Int16' | dtype == 'CInt16') { return('INT2S') } else if (dtype == 'UInt32') { return('INT4U') } else if (dtype == 'Int32' | dtype == 'CInt32') { return('INT4S') } else if (dtype == 'Float32' | dtype == 'CFloat32' ) { return('FLT4S') } else if (dtype == 'Float64' | dtype == 'CFloat64' ) { return('FLT8S') } else { return('FLT4S') } } raster/R/indexReplaceBrick.R0000644000176200001440000001422114507510157015461 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 setMethod("$", "Raster", function(x, name) { x[[name]] } ) setMethod("$<-", "Raster", function(x, name, value) { i <- which(name == names(x))[1] if (is.na(i)) { if (inherits(value, 'Raster')) { names(value) <- name x <- addLayer(x, value) return(x) } else { r <- raster(x) names(r) <- name r[] <- value x <- addLayer(x, r) return(x) } } else { if (inherits(value, 'Raster')) { if (inherits(x, 'RasterLayer')) { if (name == names(x)) { x <- value } else { x <- stack(x) x[[name]] <- value } } else { x[[name]] <- value } } else { r <- x[[name]] r[] <- value x[[name]] <- value } return(x) } } ) setMethod("[[", "Raster", function(x,i,j,...,drop=TRUE) { if ( missing(i)) { stop('you must provide an index') } if (! missing(j)) { warning('second index is ignored') } if (is.numeric(i)) { sgn <- sign(i) sgn[sgn==0] <- 1 if (! all(sgn == 1) ) { if (! all(sgn == -1) ) { stop("only 0's may be mixed with negative subscripts") } else { i <- (1:nlayers(x))[i] } } } subset(x, i, drop=drop) }) setReplaceMethod("[[", c("RasterStackBrick", "character", "missing"), function(x, i, j, value) { if (inherits(value, 'Raster')) { names(value) <- i } n <- which(i == names(x))[1] if (is.na(n)) { n <- nlayers(x) + 1 } x[[n]] <- value x } ) setReplaceMethod("[[", c("RasterLayer", "character", "missing"), function(x, i, j, value) { stopifnot(length(i) == 1) if (i[1] != names(x)) { x <- stack(x) x[[i]] <- value return(x) } if (inherits(value, 'RasterLayer')) { names(value) <- i return(value) } else if (inherits(value, 'Raster')) { if (nlayers(value) == 1) { value <- value[[1]] names(value) <- i return(value) } else { stop("too many layers") } } setValues(x, value) } ) setReplaceMethod("[[", c("RasterStack", "numeric", "missing"), function(x, i, j, value) { i <- round(i) if (i < 1) { stop('index should be > 0') } nl <- nlayers(x) if (i > nl + 1) { stop('index should be <= nlayers(x)+1') } if (!inherits(value, 'RasterLayer')) { val <- value if (i > nl) { value <- x[[nl]] } else { value <- x[[i]] } value[] <- val } else { compareRaster(x, value) } if (i > nl) { x <- addLayer(x, value) } else { x@layers[[i]] <- value } x } ) setReplaceMethod("[[", c("Raster", "numeric", "missing"), function(x, i, j, value) { i <- round(i) if (i < 1) { stop('index should be > 0') } nl <- nlayers(x) if (i > nl + 1) { stop('index should be <= nlayers(x)+1') } if (inherits(x, "RasterLayer")) { return(value) } if (canProcessInMemory(x)) { if (!inMemory(x)) { x <- readAll(x) } if (inherits(value, 'RasterLayer')) { compareRaster(x, value) x <- setValues(x, getValues(value), i) names(x)[i] <- names(value) } else { val <- value if (i > nl) { value <- getValues(x[[nl]]) } else { value <- getValues(x[[i]]) } # for recycling value[] <- val x <- setValues(x, value, i) } } else { x <- stack(x) x[[i]] <- value } return(x) } ) setReplaceMethod("[", c("RasterStackBrick", "Raster", "missing"), function(x, i, j, value) { nl <- nlayers(i) if (! hasValues(i) ) { i <- cellsFromExtent(x, i) } else if (compareRaster(x, i, stopiffalse=FALSE, showwarning=FALSE)) { dims <- dim(i) i <- as.logical(getValues(i)) dim(i) <- c(prod(dims[1:2]), dims[3]) } else { i <- cellsFromExtent(x, i) } if (nl < nlayers(x)) { .replace(x, i, value=value, recycle=nl) } else { .replace(x, i, value=value, recycle=0) } } ) setReplaceMethod("[", c("Raster", "Extent", "missing"), function(x, i, j, value) { i <- cellsFromExtent(x, i) .replace(x, i, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster", "Spatial", "missing"), function(x, i, j, value) { if (inherits(i, 'SpatialPolygons')) { v <- 1:length(i@polygons) v[] <- value return( .polygonsToRaster(i, x, field=v, fun='last', mask=FALSE, update=TRUE, updateValue="all", silent=TRUE) ) } else if (inherits(i, 'SpatialLines')) { v <- 1:length(i@lines) v[] <- value return( .linesToRaster(i, x, field=v, fun='last', mask=FALSE, update=TRUE, updateValue="all", silent=TRUE) ) } else { # if (inherits(i, 'SpatialPoints')) { i <- cellFromXY(x, sp::coordinates(i)[,1:2,drop=FALSE]) return( .replace(x, i, value=value, recycle=1) ) } } ) setReplaceMethod("[", c("RasterStackBrick","missing","missing"), function(x, i, j, value) { nl <- nlayers(x) if (inherits(x, 'RasterStack')) { x <- brick(x, values=FALSE) } if (is.matrix(value)) { if (all(dim(value) == c(ncell(x), nl))) { x <- try( setValues(x, value)) } else { stop('dimensions of the matrix do not match the Raster* object') } } else { v <- try( matrix(nrow=ncell(x), ncol=nl) ) if (! inherits(x, "try-error")) { v[] <- value x <- try( setValues(x, v) ) } } if (inherits(x, "try-error")) { stop('cannot set values on this raster (it is too large)') } return(x) } ) setReplaceMethod("[", c("Raster", "numeric", "numeric"), function(x, i, j, value) { i <- cellFromRowColCombine(x, i, j) .replace(x, i, value, recycle=1) } ) setReplaceMethod("[", c("Raster","missing", "numeric"), function(x, i, j, value) { j <- cellFromCol(x, j) .replace(x, j, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster","numeric", "missing"), function(x, i, j, value) { theCall <- sys.call(-1) narg <- length(theCall)-length(match.call(call=sys.call(-1))) if (narg > 0) { i <- cellFromRow(x, i) } .replace(x, i=i, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster", "matrix", "missing"), function(x, i, j, value) { if (ncol(i) == 2) { i <- cellFromRowCol(x, i[,1], i[,2]) } else { i <- as.vector(i) } .replace(x, i=i, value=value, recycle=1) } ) setReplaceMethod("[", c("Raster", "logical", "missing"), function(x, i, j, value) { .replace(x, i, value, recycle=1) } ) raster/R/setExtent.R0000644000176200001440000000254114507510157014070 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 1.0 # Licence GPL v3 'extent<-' <- function(x, value) { return(setExtent(x, value)) } setExtent <- function(x, ext, keepres=FALSE, snap=FALSE) { # oldbb <- extent(x) bb <- extent(ext) if (snap) { bb <- alignExtent(bb, x) } if (inherits(x, 'RasterStack')) { if (keepres) { stop('you cannot use keepres=TRUE with a RasterStack') } x@extent <- bb if (nlayers(x) > 0) { for (i in 1:nlayers(x)) { x@layers[[i]]@extent <- bb } } return(x) } if (keepres) { newobj <- clearValues(x) xrs <- xres(newobj) yrs <- yres(newobj) newobj@extent <- bb nc <- as.integer(round( (newobj@extent@xmax - newobj@extent@xmin) / xrs )) if (nc < 1) { stop( "xmin and xmax are less than one cell apart" ) } else { newobj@ncols <- nc } nr <- as.integer(round( (newobj@extent@ymax - newobj@extent@ymin) / yrs ) ) if (nr < 1) { stop( "ymin and ymax are less than one cell apart" ) } else { newobj@nrows <- nr } newobj@extent@xmax <- newobj@extent@xmin + newobj@ncols * xrs newobj@extent@ymax <- newobj@extent@ymin + newobj@nrows * yrs if ((x@ncols == newobj@ncols) & (x@nrows == newobj@nrows)) { x@extent <- newobj@extent return(x) } else { return(newobj) } } #else if (inherits(x, "Raster")) { x@extent <- bb return(x) #} } raster/R/quad.R0000644000176200001440000000225514507510157013041 0ustar liggesusers # if (!isGeneric(".quad")) { # setGeneric(".quad", function(x, ...) # standardGeneric(".quad")) # } # setMethod('.quad', signature(x='missing'), # function(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, levels=1, steps=1, crs) { # e <- extent(xmn, xmx, ymn, ymx) # if (missing(crs)) { # if (e@xmin > -400 & e@xmax < 400 & e@ymin > -90.1 & e@ymax < 90.1) { # crs <- "+proj=longlat +datum=WGS84" # } else { # crs <- "" # } # } # b <- .quad(e, nrows=nrows, ncols=ncols, crs=crs, levels=levels, steps=steps) # return(b) # } # ) # setMethod('.quad', signature(x='Extent'), # function(x, nrows=10, ncols=10, levels=1, steps=1, crs='') { # bb <- extent(x) # nr = as.integer(round(nrows)) # nc = as.integer(round(ncols)) # if (nc < 1) { stop("ncols should be > 0") } # if (nr < 1) { stop("nrows should be > 0") } # b <- methods::new("RasterQuadBrick", extent=bb, ncols=nc, nrows=nr) # projection(b) <- sp::CRS # levels <- as.integer(max(round(levels), 0)) # steps <- as.integer(max(round(steps), 0)) # nl <- levels * steps # b@nlevels <- levels # b@nsteps <- steps # b@data@nlayers <- as.integer(nl) # return(b) # } # ) raster/R/compare.R0000644000176200001440000001047714507510157013542 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 setMethod("all.equal", c("Raster", "Raster"), function(target, current, values=TRUE, stopiffalse=FALSE, showwarning=TRUE, ...) { compareRaster(target, current, ..., values=values, stopiffalse=stopiffalse, showwarning=showwarning) } ) compareRaster <- function(x, ..., extent=TRUE, rowcol=TRUE, crs=TRUE, res=FALSE, orig=FALSE, rotation=TRUE, values=FALSE, tolerance, stopiffalse=TRUE, showwarning=FALSE) { if (missing(tolerance)) { tol <- .tolerance() } else { tol <- tolerance } result <- TRUE objects <- c(x, list(...)) if (!isTRUE(length(objects) > 1)) { warning('There should be at least 2 Raster* objects to compare') return(result) } minres <- min(res(objects[[1]])) proj1 <- .getCRS(objects[[1]]) ext1 <- extent(objects[[1]]) ncol1 <- ncol(objects[[1]]) nrow1 <- nrow(objects[[1]]) res1 <- res(objects[[1]]) origin1 <- abs(origin(objects[[1]])) rot1 <- rotated(objects[[1]]) for (i in 2:length(objects)) { if (extent) { if (!(isTRUE(all.equal(ext1, extent(objects[[i]]), tolerance=tol, scale=minres )))) { result <- FALSE if (stopiffalse) { stop('different extent') } if (showwarning) { warning('different extent') } } } if (rowcol) { if ( !(identical(ncol1, ncol(objects[[i]]))) ) { result <- FALSE if (stopiffalse) { stop('different number or columns') } if (showwarning) { warning('different number or columns') } } if ( !(identical(nrow1, nrow(objects[[i]]))) ) { result <- FALSE if (stopiffalse) { stop('different number or rows') } if (showwarning) { warning('different number or rows') } } } if (crs) { thisproj <-.getCRS(objects[[i]]) if (is.na(proj1)) { proj1 <- thisproj } else { crs <- try (compareCRS(proj1, thisproj, unknown=TRUE), silent=TRUE) if (inherits(crs, "try-error")) { if (stopiffalse) { stop("invalid crs") } if (showwarning) { warning("invalid crs") } } else if (!crs) { result <- FALSE if (stopiffalse) { stop("different crs") } if (showwarning) { warning("different crs") } } } } # Can also check res through extent & rowcol if (res) { if (!(isTRUE(all.equal(res1, res(objects[[i]]), tolerance=tol, scale=minres)))) { result <- FALSE if (stopiffalse) { stop('different resolution') } if (showwarning) { warning('different resolution') } } } # Can also check orig through extent & rowcol, but orig is useful for e.g. Merge(raster, raster) if (orig) { dif <- origin1 - abs(origin(objects[[i]])) if (!(isTRUE(all.equal(dif, c(0,0), tolerance=tol, scale=minres)))) { result <- FALSE if (stopiffalse) { stop('different origin') } if (showwarning) { warning('different origin') } } } if (rotation) { rot2 <- rotated(objects[[i]]) if (rot1 | rot2) { if (rot1 != rot2) { if (stopiffalse) { stop('not all objects are rotated') } if (showwarning) { warning('not all objects are rotated') } result <- FALSE } else { test <- all(objects[[i]]@rotation@geotrans == objects[[1]]@rotation@geotrans) if (! test) { if (stopiffalse) { stop('rotations are different') } if (showwarning) { warning('rotations are different') } result <- FALSE } } } } if (values) { hv1 <- hasValues(objects[[1]]) hvi <- hasValues(objects[[i]]) if (hv1 != hvi) { if (stopiffalse) { stop('not all objects have values') } if (showwarning) { warning('not all objects have values') } result <- FALSE } else if (hv1 & hvi) { if (canProcessInMemory(objects[[1]])) { test <- isTRUE(all.equal(getValues(objects[[1]]), getValues(objects[[i]]))) if (! test) { if (stopiffalse) { stop('not all objects have the same values') } if (showwarning) { warning('not all objects have the same values') } result <- FALSE } } else { tr <- blockSize(objects[[1]]) for (j in 1:tr$n) { v1 <- getValues(objects[[1]], tr$row[j], tr$nrows[j]) v2 <- getValues(objects[[i]], tr$row[j], tr$nrows[j]) if (!isTRUE(all.equal(v1, v2))) { if (stopiffalse) { stop('not all objects have the same values') } if (showwarning) { warning('not all objects have the same values') } result <- FALSE break } } } } } } return(result) } raster/R/intersect.R0000644000176200001440000000202214507510157014077 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2011 # Version 1.0 # Licence GPL v3 setMethod('intersect', signature(x='Raster', y='ANY'), function(x, y) { y <- extent(y) crop(x, y) } ) setMethod('intersect', signature(x='Extent', y='ANY'), function(x, y) { y <- extent(y) x@xmin <- max(x@xmin, y@xmin) x@xmax <- min(x@xmax, y@xmax) x@ymin <- max(x@ymin, y@ymin) x@ymax <- min(x@ymax, y@ymax) if ((x@xmax <= x@xmin) | (x@ymax <= x@ymin) ) { #warning('Objects do not overlap') return(NULL) } return(x) } ) .intersectExtent <- function(x, ..., validate=TRUE) { objects <- c(x, list(...)) if (length(objects) == 1) { return(extent(x)) } e <- extent(objects[[1]]) for (i in 2:length(objects)) { e2 <- extent(objects[[i]]) e@xmin <- max(e@xmin, e2@xmin) e@xmax <- min(e@xmax, e2@xmax) e@ymin <- max(e@ymin, e2@ymin) e@ymax <- min(e@ymax, e2@ymax) } if ((e@xmax <= e@xmin) | (e@ymax <= e@ymin) ) { if (validate) { stop('Objects do not intersect') } else { return(NULL) } } return(e) } raster/R/cut.R0000644000176200001440000000434214507510157012701 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 setMethod('cut', signature(x='Raster'), function(x, breaks, ..., filename='', format, datatype='INT2S', overwrite, progress) { if (! hasValues(x) ) { warning('x has no values, nothing to do') return(x) } filename <- trim(filename) if (missing(format)) { format <- .filetype(format=format, filename=filename) } if (missing(overwrite)) { overwrite <- .overwrite() } if (missing(progress)) { progress <- .progress() } nl <- nlayers(x) if (nl == 1) { out <- raster(x) } else { out <- brick(x, values=FALSE) } if (canProcessInMemory(out, n=nl*2 + 2)) { if (nl > 1) { values(out) <- apply(getValues(x), 2, function(x) as.numeric(cut(x, breaks=breaks, labels=FALSE, ...))) } else { values(out) <- as.numeric(cut(getValues(x), breaks=breaks, labels=FALSE, ...)) } if ( filename != "" ) { out <- writeRaster(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) } return(out) } else { if (filename == '') { filename <- rasterTmpFile() } if (length(breaks) == 1) { breaks <- round(breaks) stopifnot(breaks > 1) probs <- c(0, 1:breaks * 1/breaks) breaks <- stats::na.omit(sampleRegular(x, 10000)) #, useGDAL=TRUE)) warning('breaks are approximate, based on a sample of ', length(breaks), ' cells that are not NA') breaks <- stats::quantile(breaks, probs, names=FALSE) breaks[1] <- -Inf breaks[length(breaks)] <- Inf } out <- writeStart(out, filename=filename, format=format, datatype=datatype, overwrite=overwrite, progress=progress ) tr <- blockSize(out) pb <- pbCreate(tr$n, progress=progress, label='cut') if (nl > 1) { for (i in 1:tr$n) { res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) res <- apply(res, 2, function(x) as.numeric(cut(x, breaks=breaks, labels=FALSE, ...))) out <- writeValues(out, res, tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { res <- getValues( x, row=tr$row[i], nrows=tr$nrows[i] ) res <- as.numeric(cut(res, breaks=breaks, labels=FALSE, ...)) out <- writeValues(out, res, tr$row[i]) pbStep(pb, i) } } out <- writeStop(out) pbClose(pb) return(out) } } ) raster/R/inifile.R0000644000176200001440000000450414507510157013525 0ustar liggesusers# Authors: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 .strSplitOnFirstToken <- function(s, token="=") { pos <- which(strsplit(s, '')[[1]]==token)[1] if (is.na(pos)) { return(c(trim(s), NA)) } else { first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } } .strSplitOnLastToken <- function(s, token="=") { # not used here pos <- unlist(strsplit(s, ''), use.names = FALSE) pos <- max(which(pos==token)) if (!is.finite(pos)) { return(c(s, NA)) } else { first <- substr(s, 1, (pos-1)) second <- substr(s, (pos+1), nchar(s)) return(trim(c(first, second))) } } readIniFile <- function(filename, token='=', commenttoken=';', aslist=FALSE, case) { stopifnot(file.exists(filename)) Lines <- trim(readLines(filename, warn = FALSE)) Lines <- Lines[Lines != ""] ini <- lapply(Lines, function(s){ ss <- isTRUE(strsplit(s, "=")[[1]][1] == "wkt") if (ss) { # if WKT2 do not split, no comment permitted res <- c(trim(s), NA) } else { res <- .strSplitOnFirstToken(s, token=commenttoken) } res } ) Lines <- matrix(unlist(ini), ncol=2, byrow=TRUE)[,1] ini <- lapply(Lines, function(s){ .strSplitOnFirstToken(s, token=token) }) ini <- matrix(unlist(ini), ncol=2, byrow=TRUE) ini <- ini[ ini[,1] != "", , drop=FALSE] ns <- length(which(is.na(ini[,2]))) if (ns > 0) { sections <- c(which(is.na(ini[,2])), length(ini[,2])) # here I should check whether the section text is enclosed in [ ]. If not, it is junk text that should be removed, rather than used as a section ini <- cbind("", ini) for (i in 1:(length(sections)-1)) { ini[sections[i]:(sections[i+1]), 1] <- ini[sections[i],2] } ini[,1] <- gsub("\\[", "", ini[,1]) ini[,1] <- gsub("\\]", "", ini[,1]) sections <- sections[1:(length(sections)-1)] ini <- ini[-sections,] } else { ini <- cbind("", ini) } if (!missing(case)) { ini <- case(ini) } colnames(ini) <- c("section", "name", "value") if (aslist) { iniToList <- function(ini) { un <- unique(ini[,1]) LST <- list() for (i in 1:length(un)) { sel <- ini[ini[,1] == un[i], 2:3, drop=FALSE] lst <- as.list(sel[,2]) names(lst) <- sel[,1] LST[[i]] <- lst } names(LST) <- un return(LST) } ini <- iniToList(ini) } return(ini) } raster/R/union_sp.R0000644000176200001440000000525714507510157013746 0ustar liggesusers# Author: Robert J. Hijmans # Date : November 2011 # Version 1.0 # Licence GPL v3 setMethod('union', signature(x='SpatialPolygons', y='SpatialPolygons'), function(x, y) { # warning("this method will be removed. You can use 'terra::union' instead") x <- vect(x) y <- vect(y) z <- union(x, y) as(z, "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # x <- sp::spChFIDs(x, as.character(1:length(x))) # y <- sp::spChFIDs(y, as.character(1:length(y))) # prj <- x@proj4string # if (is.na(prj)) prj <- y@proj4string # x@proj4string <- .spCRS(as.character(NA)) # y@proj4string <- .spCRS(as.character(NA)) # subs <- rgeos::gIntersects(x, y, byid=TRUE) # if (!any(subs)) { # x <- bind(x, y) # } else { # xdata <-.hasSlot(x, 'data') # ydata <-.hasSlot(y, 'data') # if (xdata & ydata) { # nms <- .goodNames(c(colnames(x@data), colnames(y@data))) # colnames(x@data) <- nms[1:ncol(x@data)] # colnames(y@data) <- nms[(ncol(x@data)+1):length(nms)] # } # dif1 <- erase(x, y) # dif2 <- erase(y, x) # x <- intersect(x, y) # x <- list(dif1, dif2, x) # x <- x[!sapply(x, is.null)] # i <- sapply(x, length) > 0 # x <- x[ i ] # if (length(x) > 1) { # x <- do.call(bind, x) # } else { # x <- x[[1]] # } # } # if (inherits(x, "Spatial")) { x@proj4string <- prj } # x } ) setMethod('union', signature(x='SpatialPolygons', y='missing'), function(x, y) { # warning("this method will be removed. You can use 'terra::union' instead") x <- vect(x) z <- union(x) names(z) <- gsub("_", ".", toupper(names(z))) z$count <- rowSums(data.frame(z)) if (nrow(z) == 3) { # for bcmaps test z <- z[c(3,1,2),] } as(z, "Spatial") # valgeos <- .checkGEOS(); on.exit(rgeos::set_RGEOS_CheckValidity(valgeos)) # n <- length(x) # if (n < 2) { # return(x) # } # prj <- x@proj4string # x@proj4string <- .spCRS(as.character(NA)) # #if (!rgeos::gIntersects(x)) { # # this is a useful test, but returned topologyerrors # # return(x) # #} # if (.hasSlot(x, 'data')) { # x <- as(x, 'SpatialPolygons') # } # x <- sp::spChFIDs(x, as.character(1:length(x))) # x <- sp::SpatialPolygonsDataFrame(x, data.frame(ID=1:n)) # u <- x[1,] # names(u) <- 'ID.1' # for (i in 2:n) { # z <- x[i, ] # names(z) <- paste('ID.', i, sep='') # u <- union(u, z) # } # u@data[!is.na(u@data)] <- 1 # u@data[is.na(u@data)] <- 0 # u$count <- rowSums(u@data) # u@proj4string <- prj # u } ) setMethod('union', signature(x='SpatialPoints', y='SpatialPoints'), function(x, y) { bind(x,y) }) setMethod('union', signature(x='SpatialLines', y='SpatialLines'), function(x, y) { bind(x,y) }) raster/R/merge.R0000644000176200001440000002751014507510157013207 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 # redesinged for multiple row processing # and arguments ext and overlap # October 2011 # version 1 setMethod('merge', signature(x='Extent', y='ANY'), function(x, y, ...) { x <- c(x, y, list(...)) x <- sapply(x, extent) x <- x[sapply(x, function(x) inherits(x, 'Extent'))] x <- lapply(x, function(e) t(bbox(e))) x <- do.call(rbind, x) x <- apply(x, 2, range) extent(as.vector(x)) } ) setMethod('merge', signature(x='RasterStackBrick', y='missing'), function(x, ..., tolerance=0.05, filename="", ext=NULL) { nl <- nlayers(x) if (nl < 2) { return(x) } else if (nl == 2) { merge(x[[1]], x[[2]], tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext) } else { do.call(merge, c(x=x[[1]], y=x[[2]], .makeRasterList(x[[3:nl]]), tolerance=tolerance, filename=filename, overlap=TRUE, ext=ext)) } } ) setMethod('merge', signature(x='Raster', y='Raster'), function(x, y, ..., tolerance=0.05, filename="", overlap=TRUE, ext=NULL) { x <- c(x, y, list(...)) isRast <- sapply(x, function(x) inherits(x, 'Raster')) dotargs <- x[ !isRast ] x <- x[ isRast ] compareRaster(x, extent=FALSE, rowcol=FALSE, orig=TRUE, res=TRUE, tolerance=tolerance) if (is.null(dotargs$datatype)) { dotargs$datatype <- .commonDataType(sapply(x, dataType)) } filename <- trim(filename) dotargs$filename <- filename nl <- max(unique(sapply(x, nlayers))) bb <- .unionExtent(x) if (nl > 1) { out <- brick(x[[1]], values=FALSE, nl=nl) } else { out <- raster(x[[1]]) } out <- setExtent(out, bb, keepres=TRUE, snap=FALSE) hasV <- sapply(x, hasValues) if (!any(hasV)) { return(out) } if (!is.null(ext)) { ext <- extent(ext) out1 <- extend(out, union(ext, extent(out))) out1 <- crop(out1, ext) test <- try( intersect(extent(out), extent(out1)) ) if (inherits(test, "try-error")) { stop('"ext" does not overlap with any of the input data') } out <- out1 ext <- extent(out) } if ( canProcessInMemory(out, 3) ) { if (!is.null(ext)) { if (overlap) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells, ] dat <- extract(x[[i]], ext) if (!is.matrix(dat)) { dat <- matrix(dat, ncol=1) } na <- ! rowSums(dat)==nl vv[na, ] <- dat[na, ] v[cells, ] <- vv } } } else { v <- rep(NA, ncell(out)) for (i in length(x):1) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) xy <- xyFromCell(out, cells) d <- extract(x[[i]], xy) j <- !is.na(d) v[cells[j]] <- d[j] } } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } else { # ignore overlap (if any) v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in length(x):1 ) { xy1 <- xyFromCell(x[[i]], 1) xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells, ] <- extract(x[[i]], ext) } } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } } else { if (overlap) { if (nl > 1) { v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells, ] dat <- getValues(x[[i]]) if (!is.matrix(dat)) { dat <- matrix(dat, ncol=1) } na <- ! rowSums(is.na(dat)) == nl vv[na, ] <- dat[na, ] v[cells, ] <- vv } } else { v <- rep(NA, ncell(out)) for (i in 1:length(x)) { cells <- cellsFromExtent( out, extent(x[[i]]) ) vv <- v[cells] vv[is.na(vv)] <- getValues(x[[i]])[is.na(vv)] v[cells] <- vv } } rm(vv) out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } else { # no overlap (or ignore overlap) v <- matrix(NA, nrow=ncell(out), ncol=nl) for (i in length(x):1) { cells <- cellsFromExtent( out, extent(x[[i]]) ) v[cells, ] <- getValues(x[[i]]) } out <- setValues(out, v) if (filename != '') { dotargs$x <- out out <- do.call(writeRaster, dotargs) } return(out) } } } if (is.null(ext)) { rowcol <- matrix(NA, ncol=6, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] rowcol[i,1] <- rowFromY(out, xy1[2]) # start row on new raster rowcol[i,2] <- rowFromY(out, xy2[2]) # end row rowcol[i,3] <- colFromX(out, xy1[1]) # start col rowcol[i,4] <- colFromX(out, xy2[1]) # end col rowcol[i,5] <- i # layer rowcol[i,6] <- nrow(x[[i]]) } tr <- blockSize(out) # tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1))) # tr$row <- subset(tr$row, tr$row <= nrow(out)) # tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row) # tr$n <- length(tr$row) pb <- pbCreate(tr$n, dotargs$progress, label='merge') dotargs$x <- out out <- do.call(writeStart, dotargs) if (overlap) { if (nl == 1) { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out)) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { #reverse order so that the first raster covers the second etc. vv[] <- NA r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValues(x[[ rc[j,5] ]], r1, nr), nrow=nr, byrow=TRUE) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, as.vector(t(v)), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { vv[] <- NA r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) vv[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { # not overlap for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { for (j in nrow(rc):1) { r1 <- tr$row[i]-rc[j,1]+1 r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,6], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, ] <- getValues(x[[ rc[j,5] ]], r1, nr) } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } } else { # ext is not null rowcol <- matrix(NA, ncol=10, nrow=length(x)) for (i in 1:length(x)) { xy1 <- xyFromCell(x[[i]], 1) # first row/col on old raster[[i]] xy2 <- xyFromCell(x[[i]], ncell(x[[i]]) ) # last row/col on old raster[[i]] xyout1 <- xyFromCell(out, 1) xyout2 <- xyFromCell(out, ncell(out)) if (xy1[2] > ymin(out) & xy2[2] < ymax(out) & xy1[1] < xmax(out) & xy2[1] > xmin(out)) { j <- rowFromY(out, xy1[2]) rowcol[i,1] <- ifelse(is.na(j), 1, j) # start row on new raster j <- rowFromY(out, xy2[2]) rowcol[i,2] <- ifelse(is.na(j), nrow(out), j) # end row j <- colFromX(out, xy1[1]) rowcol[i,3] <- ifelse(is.na(j), 1, j) # start col j <- colFromX(out, xy2[1]) rowcol[i,4] <- ifelse(is.na(j), ncol(out), j) # end col rowcol[i,5] <- nrow(x[[i]]) j <- rowFromY(x[[i]], xyout1[2]) rowcol[i,6] <- ifelse(is.na(j), 1, j) j <- rowFromY(x[[i]], xyout2[2]) rowcol[i,7] <- ifelse(is.na(j), nrow(x[[i]]), j) - rowcol[i,6] + 1 j <- colFromX(x[[i]], xyout1[1]) rowcol[i,8] <- ifelse(is.na(j), 1, j) j <- colFromX(x[[i]], xyout2[1]) rowcol[i,9] <- ifelse(is.na(j), ncol(x[[i]]), j) - rowcol[i,8] + 1 rowcol[i,10] <- i # layer } } rowcol <- subset(rowcol, !is.na(rowcol[,1])) tr <- blockSize(out) # tr$row <- sort(unique(c(tr$row, rowcol[,1], rowcol[,2]+1))) # tr$row <- subset(tr$row, tr$row <= nrow(out)) # tr$nrows <- c(tr$row[-1], nrow(out)+1) - c(tr$row) # tr$n <- length(tr$row) pb <- pbCreate(tr$n, dotargs$progress, label='merge') dotargs$x <- out out <- do.call(writeStart, dotargs) if (overlap) { if (nl == 1) { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i], ncol=ncol(out)) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { #reverse order so that the first raster covers the second etc. vv[] <- NA r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 vv[z1:z2, rc[j,3]:rc[j,4]] <- matrix(getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]), nrow=nr, byrow=TRUE) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, as.vector(t(v)), tr$row[i]) pbStep(pb, i) } } else { for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { vv <- v for (j in nrow(rc):1) { vv[] <- NA r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) vv[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]) v[!is.na(vv)] <- vv[!is.na(vv)] } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } else { # no overlap for (i in 1:tr$n) { v <- matrix(NA, nrow=tr$nrow[i]*ncol(out), ncol=nl) rc <- subset(rowcol, (tr$row[i]+tr$nrow[i]-1) > rowcol[,1] & tr$row[i] < rowcol[,2]) if (nrow(rc) > 0) { for (j in nrow(rc):1) { r1 <- tr$row[i]-rc[j,1]+rc[j,6] r2 <- r1 + tr$nrow[i]-1 z1 <- abs(min(1,r1)-1)+1 r1 <- max(1, r1) r2 <- min(rc[j,5], r2) nr <- r2 - r1 + 1 z2 <- z1 + nr - 1 cells <- cellFromRowColCombine(out, z1:z2, rc[j,3]:rc[j,4]) v[cells, ] <- getValuesBlock(x[[ rc[j,10] ]], r1, nr, rc[j,8], rc[j,9]) } } out <- writeValues(out, v, tr$row[i]) pbStep(pb, i) } } } pbClose(pb) writeStop(out) } ) raster/R/rasterFromXYZ.R0000644000176200001440000000432514507510157014646 0ustar liggesusers# Author: Robert J. Hijmans # Date : July 2010 # Version 1.0 # Licence GPL v3 rasterFromXYZ <- function(xyz, res=c(NA, NA), crs="", digits=5) { res = rep_len(res, 2) if (inherits(xyz, 'SpatialPoints')) { if (inherits(xyz, 'SpatialPointsDataFrame')) { xyz <- cbind(sp::coordinates(xyz)[,1:2,drop=FALSE], xyz@data[,1]) } else { xyz <- sp::coordinates(xyz)[,1:2,drop=FALSE] } } ln <- colnames(xyz) if (inherits(xyz, 'data.frame')) { xyz <- as.matrix(xyz) xyz <- matrix(as.numeric(xyz), ncol=ncol(xyz), nrow=nrow(xyz)) } xyz <- xyz[(!is.na(xyz[,1])) & (!is.na(xyz[,2])), ] x <- sort(unique(xyz[,1])) dx <- x[-1] - x[-length(x)] if (is.na(res[1])) { if (length(x) < 2) { stop("more than one unique x value needed") } rx <- min(dx) for (i in 1:5) { rx <- rx / i q <- sum(round(dx / rx, digits=digits) %% 1) if ( q == 0 ) { break } } if ( q > 0 ) { stop('x cell sizes are not regular') } } else { rx <- res[1] test <- sum(round(dx / rx, digits=digits) %% 1) if ( test > 0 ) { stop('x cell sizes are not regular') } } y <- sort(unique(xyz[,2])) dy <- y[-1] - y[-length(y)] # probably a mistake to use the line below # Gareth Davies suggested that it be removed # dy <- round(dy, digits) if (is.na(res[2])) { if (length(y) < 2) { stop("more than one unique y value needed") } ry <- min(dy) for (i in 1:5) { ry <- ry / i q <- sum(round(dy / ry, digits=digits) %% 1) if ( q == 0 ) { break } } if ( q > 0 ) { stop('y cell sizes are not regular') } } else { ry <- res[2] test <- sum(round(dy / ry, digits=digits) %% 1) if ( test > 0 ) { stop('y cell sizes are not regular') } } minx <- min(x) - 0.5 * rx maxx <- max(x) + 0.5 * rx miny <- min(y) - 0.5 * ry maxy <- max(y) + 0.5 * ry d <- dim(xyz) nl <- 1 if (d[2] <= 3) { r <- raster(xmn=minx, xmx=maxx, ymn=miny, ymx=maxy, crs=crs) } else { nl <- d[2]-2 r <- brick(xmn=minx, xmx=maxx, ymn=miny, ymx=maxy, crs=crs, nl=nl) } res(r) <- c(rx, ry) if (d[2] > 2) { names(r) <- ln[-c(1:2)] vals <- matrix(NA, nrow=ncell(r), ncol=nl) cells <- cellFromXY(r, xyz[,1:2]) vals[cells,] <- as.vector(xyz[,3:d[2]]) setValues(r, vals) } else { r } } raster/R/extent.R0000644000176200001440000001100314507510157013405 0ustar liggesusers# Author: Robert J. Hijmans # Date : January 2009 # Version 0.9 # Licence GPL v3 .ext2bb <- function(e) { matrix(as.vector(e), ncol=2, byrow=TRUE) } #setMethod("bbox", signature(obj="SpatRaster"), # function(obj){ # .ext2bb(ext(obj)) # } #) #setMethod("bbox", signature(obj="SpatVector"), # function(obj){ # .ext2bb(ext(obj)) # } #) setMethod('extent', signature(x='Extent'), function(x){ return(x) } ) setMethod('extent', signature(x='BasicRaster'), function(x, r1, r2, c1, c2){ e <- x@extent r <- res(x) if (! missing(c1) ) { xn <- xFromCol(x, c1) - 0.5 * r[1] if (is.na(xn)) { warning('invalid first colummn') xn <- e@xmin } } else { xn <- e@xmin } if (! missing(c2) ) { xx <- xFromCol(x, c2) + 0.5 * r[1] if (is.na(xx)) { warning('invalid second colummn') xx <- e@xmax } } else { xx <- e@xmax } if (! missing(r1) ) { yx <- yFromRow(x, r1) + 0.5 * r[2] if (is.na(yx)) { warning('invalid first row') yx <- e@ymax } } else { yx <- e@ymax } if (! missing(r2) ) { yn <- yFromRow(x, r2) - 0.5 * r[2] if (is.na(yn)) { warning('invalid second row') yn <- e@ymin } } else { yn <- e@ymin } if (xn == xx) { stop('min and max x are the same') } if (yn == yx) { stop('min and max y are the same') } if (xn > xx) { warning('min x larger than max x') } if (yn > yx) { warning('min y larger than max y') } e <- extent(sort(c(xn, xx)), sort(c(yn, yx))) if (methods::validObject(e)) { return(e) } } ) setMethod('extent', signature(x='Spatial'), function(x){ bndbox <- sp::bbox(x) e <- methods::new('Extent') e@xmin <- bndbox[1,1] e@xmax <- bndbox[1,2] e@ymin <- bndbox[2,1] e@ymax <- bndbox[2,2] return(e) } ) setMethod('extent', signature(x='bbox'), function(x){ e <- methods::new('Extent') e@xmin <- x[1] e@xmax <- x[3] e@ymin <- x[2] e@ymax <- x[4] return(e) } ) setMethod('extent', signature(x='sf'), function(x){ if (!requireNamespace("sf")) { stop('Cannot do this because sf is not available') } b <- sf::st_bbox(x) e <- methods::new('Extent') e@xmin <- b[1] e@xmax <- b[3] e@ymin <- b[2] e@ymax <- b[4] return(e) } ) setMethod('extent', signature(x='matrix'), function(x){ d <- dim(x) if (min(d) < 2) { stop('matrix should have dimensions of at least 2 by 2') } if (d[2] > 2) { stop('matrix should not have more than 2 columns') } e <- methods::new('Extent') if (nrow(x) == 2) { # assuming a 'sp' bbox object e@xmin <- min(x[1,]) e@xmax <- max(x[1,]) e@ymin <- min(x[2,]) e@ymax <- max(x[2,]) } else { a <- as.vector(apply(x, 2, range, na.rm=TRUE)) e@xmin <- a[1] e@xmax <- a[2] e@ymin <- a[3] e@ymax <- a[4] } if (validObject(e)) return(e) } ) setMethod('extent', signature(x='numeric'), function(x, ...){ dots <- unlist(list(...)) x <- c(x, dots) if (length(x) < 4) { stop('insufficient number of elements (should be 4)') } if (length(x) > 4) { warning('more elements than expected (should be 4)') } names(x) <- NULL e <- methods::new('Extent') e@xmin <- x[1] e@xmax <- x[2] e@ymin <- x[3] e@ymax <- x[4] if (validObject(e)) return(e) } ) # contributed by Etienne Racine setMethod('extent', signature(x='list'), function(x, ...) { stopifnot(c("x", "y") %in% names(x)) stopifnot(lapply(x[c("x", "y")], length) >= 2) lim <- c(range(x$x), (range(x$y))) return(extent(lim,...)) } ) setMethod('extent', signature(x='GridTopology'), # contributed by Michael Sumner function(x){ cco <- x@cellcentre.offset cs <- x@cellsize cdim <- x@cells.dim e <- methods::new('Extent') e@xmin <- cco[1] - cs[1]/2 e@xmax <- e@xmin + cs[1] * cdim[1] e@ymin <- cco[2] - cs[2]/2 e@ymax <- e@ymin + cs[2] * cdim[2] return(e) } ) setMethod("[", c("Extent", "numeric", "missing"), function(x, i, j, ... ,drop=TRUE) { x <- as.vector(x) i <- as.integer(i) i <- i[i %in% 1:4] x[i] }) setMethod("[", c("Extent", "missing", "missing"), function(x, i, j, ... ,drop=TRUE) { as.vector(x) }) setReplaceMethod("[", c("Extent","numeric","missing"), function(x, i, j, value) { i <- as.integer(i) i <- i[i %in% 1:4] if (length(i) == 0) { return(x) } y <- as.vector(x) y[i] <- value if (y[1] >= y[2]) { stop('invalid extent. xmin should be greater than xmax') } if (y[3] >= y[4]) { stop('invalid extent. ymin should be greater than ymax') } x@xmin <- y[1] x@xmax <- y[2] x@ymin <- y[3] x@ymax <- y[4] return(x) } ) raster/R/gdal.R0000644000176200001440000000211714507510157013013 0ustar liggesusers# Author: Robert J. Hijmans # Date : September 2012 # Version 1.0 # Licence GPL v3 # .requireRgdal <- function(stopIfAbsent=TRUE) { # y <- getOption('rasterGDALLoaded') # suppressWarnings(x <- isTRUE( try( requireNamespace("rgdal", quietly=TRUE ) ) )) # if (! isTRUE(y) ) { # if (x) { # #pkg.info <- utils::packageDescription('rgdal') # #test <- utils::compareVersion(pkg.info[["Version"]], "0.7-21") > 0 # #if (!test) { # # stop('you use rgdal version: ', pkg.info[["Version"]], '\nYou need version 0.7-22 or higher') # #} # options('rasterGDALLoaded'=TRUE) # return(TRUE) # } else if (stopIfAbsent) { # stop("package 'rgdal' is not available") # } else { # return(FALSE) # } # } # return(TRUE) # } .useproj6 <- function() { TRUE } # .useproj6 <- function() { # pkg.info <- utils::packageDescription('rgdal') # new_rgdal <- utils::compareVersion(pkg.info[["Version"]], "1.5-7") > 0 # if (new_rgdal) { # if (rgdal::new_proj_and_gdal()) { # return (TRUE) # } else { # return (FALSE) # } # } else { # return (FALSE) # } # } raster/R/trim.R0000644000176200001440000000623114507510157013060 0ustar liggesusers# Author: Robert J. Hijmans # Date : December 2009 # Version 1.0 # Licence GPL v3 setMethod("trim", signature(x="character"), function(x, internal=FALSE, ...) { if (internal) { gsub("^ *|(?<= ) | *$", "", x, perl=TRUE) } else { gsub("^\\s+|\\s+$", "", x) } } ) setMethod("trim", signature(x="data.frame"), function(x, ...) { for (i in 1:ncol(x)) { if (inherits(x[,i], "character")) { x[,i] <- trim(x[,i]) } else if (inherits(x[,i], "factor")) { x[,i] <- as.factor(trim(as.character(x[,i]))) } } return(x) } ) setMethod("trim", signature(x="matrix"), function(x, ...) { if (is.character(x)) { x[] = trim(as.vector(x)) } else { rows <- rowSums(is.na(x)) cols <- colSums(is.na(x)) rows <- which(rows != ncol(x)) cols <- which(cols != nrow(x)) if (length(rows)==0) { x <- matrix(ncol=0, nrow=0) } else { x <- x[min(rows):max(rows), min(cols):max(cols), drop=FALSE] } } return(x) } ) # June 2013, modification by Mike Sumner, added argument "value" .memtrimlayer <- function(r, padding=0, values=NA, filename="", ...) { x <- as.matrix(r) if (all(is.na(values))) { rows <- rowSums(is.na(x)) cols <- colSums(is.na(x)) } else { rows <- apply(x, 1, function(i) sum(i %in% values)) cols <- apply(x, 2, function(i) sum(i %in% values)) } rows <- which(rows != ncol(x)) if (length(rows)==0) { stop("only NA values found") } cols <- which(cols != nrow(x)) rows <- pmin(pmax(1, c(min(rows) - padding, max(rows + padding))), nrow(r)) cols <- pmin(pmax(1, c(min(cols) - padding, max(cols + padding))), ncol(r)) e <- extent(r, rows[1], rows[2], cols[1], cols[2]) crop(r, e, filename=filename, ...) } setMethod("trim", signature(x="Raster"), function(x, padding=0, values=NA, filename="", ...) { filename <- trim(filename) if (!hasValues(x)) { stop("The Raster object has no values") } if (nlayers(x) == 1 && canProcessInMemory(x)) { x <- .memtrimlayer(x, padding=padding, values=values, ...) if (filename != "") { x <- writeRaster(x, filename, ...) } return(x) } nr <- nrow(x) nc <- ncol(x) nrl <- nr * nlayers(x) ncl <- nc * nlayers(x) cnt <- 0 for (r in 1:nr) { v <- getValues(x, r) if (sum(v %in% values) < ncl) { break } cnt <- cnt + 1 } if ( cnt == nr) { stop("only NA values found") } firstrow <- min(max(r-padding, 1), nr) for (r in nr:firstrow) { v <- getValues(x, r) if (sum(v %in% values) < ncl) { break } } lastrow <- max(min(r+padding, nr), 1) if (lastrow < firstrow) { tmp <- firstrow firstrow <- lastrow lastrow <- tmp } for (c in 1:nc) { v <- getValuesBlock(x, 1 ,nrow(x), c, 1) if (sum(v %in% values) < nrl) { break } } firstcol <- min(max(c-padding, 1), nc) for (c in nc:firstcol) { v <- getValuesBlock(x, 1 ,nrow(x), c, 1) if (sum(v %in% values) < nrl) { break } } lastcol <- max(min(c+padding, nc), 1) if (lastcol < firstcol) { tmp <- firstcol firstcol <- lastcol lastcol <- tmp } xr <- xres(x) yr <- yres(x) e <- extent(xFromCol(x, firstcol)-0.5*xr, xFromCol(x, lastcol)+0.5*xr, yFromRow(x, lastrow)-0.5*yr, yFromRow(x, firstrow)+0.5*yr) return( crop(x, e, filename=filename, ...) ) } ) raster/R/validCell.R0000644000176200001440000000112014507510157013774 0ustar liggesusers# Author: Robert J. Hijmans # Date : October 2008 # Version 0.9 # Licence GPL v3 validCell <- function(object, cell) { cell <- round(cell) valid <- rep(FALSE, times=length(cell)) valid[cell > 0 & cell <= ncell(object)] <- TRUE return(valid) } validRow <- function(object, rownr) { rownr <- round(rownr) valid <- rep(FALSE, times=length(rownr)) valid[rownr > 0 & rownr <= object@nrows] <- TRUE return(valid) } validCol <- function(object, colnr) { colnr <- round(colnr) valid <- rep(FALSE, times=length(colnr)) valid[colnr > 0 & colnr <= object@ncols] <- TRUE return(valid) } raster/R/getValuesFocal.R0000644000176200001440000000516414507510157015015 0ustar liggesusers# Author: Robert J. Hijmans # Date : March 2012 # Version 1.0 # Licence GPL v3 if (!isGeneric("getValuesFocal")) { setGeneric("getValuesFocal", function(x, row, nrows, ngb, ...) standardGeneric("getValuesFocal")) } setMethod("getValuesFocal", signature(x='Raster', row='missing', nrows='missing', ngb='numeric'), function(x, ngb, names=FALSE, ...) { getValuesFocal(x, 1, nrow(x), ngb, names=names, ...) }) setMethod("getValuesFocal", signature(x='Raster', row='numeric', nrows='numeric', ngb='numeric'), function(x, row, nrows, ngb, names=FALSE, padValue=NA, array=FALSE, ...) { nl <- nlayers(x) if (nl == 0) { stop("x has no values") } else if (nl > 1) { mm <- list() } xx <- raster(x) nc <- ncol(xx) row <- round(row) nrows <- round(nrows) if (!validRow(xx, row)) { stop("Not a valid row number") } if ( (row+nrows-1) > nrow(xx) ) { stop("'nrows' is too high") } stopifnot(is.atomic(padValue)) geo <- couldBeLonLat(xx) mask <- FALSE if (is.matrix(ngb)) { w <- ngb ngb <- dim(w) w <- ! is.na(as.vector(t(w))) mask <- TRUE } ngb <- .checkngb(ngb, mustBeOdd=TRUE) ngbr <- floor(ngb[1]/2) ngbc <- floor(ngb[2]/2) startrow <- row-ngbr endrow <- row+nrows-1+ngbr sr <- max(1, startrow) # startrow er <- min(endrow, nrow(xx)) if (nl==1) { vv <- matrix(getValues(x, sr, (er-sr+1)), ncol=1) } else { vv <- getValues(x, sr, (er-sr+1)) } for (i in 1:nl) { v <- matrix(vv[,i], ncol=nc, byrow=TRUE) if (sr > startrow) { add <- sr - startrow v <- rbind(matrix(padValue, nrow=add, ncol=ncol(v)), v) } if (endrow > er) { add <- endrow - er v <- rbind(v, matrix(padValue, nrow=add, ncol=ncol(v))) } if (geo) { nv <- ncol(v) if (ngbc < nv) { v <- cbind(v[,(nv-ngbc+1):nv], v, v[,1:ngbc]) } else { stop('horizontal neighbourhood is too big') } } else { add <- matrix(padValue, ncol=ngbc, nrow=nrow(v)) v <- cbind(add, v, add) } v <- .focal_get(as.vector(t(v)), as.integer(dim(v)), as.integer(ngb)) m <- matrix(v, nrow=nrows*nc, byrow=TRUE) if (names) { rownames(m) <- cellFromRowCol(xx, row, 1):cellFromRowCol(xx, row+nrows-1,nc) colnames(m) <- paste('r', rep(1:ngb[1], each=ngb[2]), 'c', rep(1:ngb[2], ngb[1]), sep='') } if (mask) { m <- m[,mask,drop=FALSE] } if (nl == 1) { return(m) } else { mm[[i]] <- m } } if (array) { if (names) { dnms <- list(rownames(mm[[1]]), colnames(mm[[1]]), names(x)) } else { dnms <- list(NULL, NULL, names(x)) } mm <- array(unlist(mm, use.names = FALSE), c(nrow(mm[[1]]), ncol(mm[[1]]), length(mm)), dimnames=dnms ) } else { names(mm) <- names(x) } return(mm) } ) raster/R/progressBar.R0000644000176200001440000000321014507510157014370 0ustar liggesusers# Author: Robert J. Hijmans # Date: Sept 2008 # Version 0.9 # Licence GPL v3 pbCreate <- function(nsteps, progress, style=3, label='Progress', ...) { if (missing(progress)) { progress <- .progress() } if (is.null(progress)) { progress <- .progress() } if (progress=='text') { pb <- utils::txtProgressBar(min=0, max=nsteps, style=style) } else if (progress %in% c('window', 'tcltk', 'windows')) { tit <- paste(label, ' (', nsteps, ' steps)', sep='') #if (.Platform$OS.type == "windows" ) { # pb <- winProgressBar(title=tit, min=0 , max=nsteps, width = 300, label='starting') #} else { requireNamespace("tcltk") pb <- tcltk::tkProgressBar(title=tit, min=0, max=nsteps, width = 300, label='starting') #} } else { pb <- 'none' } attr(pb, "starttime") <- Sys.time() return(pb) } pbStep <- function(pb, step=NULL, label='') { if (inherits(pb, "txtProgressBar")) { if (is.null(step)) { step = pb$getVal() + 1 } utils::setTxtProgressBar(pb, step) } else if (inherits(pb, "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) { if (inherits(pb, "txtProgressBar")) { cat("\n\r") close(pb) } else if (inherits(pb, "tkProgressBar")) { close(pb) } if (missing(timer)) { timer <- .timer() } if (timer) { elapsed <- difftime(Sys.time(), attr(pb, "starttime"), units = "secs") cat(round(as.numeric(elapsed)), 'seconds\n') } } raster/R/writeStartStopRaster.R0000644000176200001440000000740314507510157016306 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 0.9 # Licence GPL v3 .startRasterWriting <- function(x, filename, NAflag, update=FALSE, ...) { filename <- trim(filename) if (filename == "") { stop('missing filename') } filetype <- .filetype(filename=filename, ...) filename <- .setFileExtensionHeader(filename, filetype) fnamevals <- .setFileExtensionValues(filename, filetype) if (length(colortable(x)) > 1) { if (is.null(list(...)$datatype)) { datatype <- 'INT1U' } else { datatype <- .datatype(...) } } else { datatype <- .datatype(...) } if (filetype %in% c('SAGA', 'IDRISI')) { if (datatype == 'FLT8S') { datatype = 'FLT4S' } else if (filetype == 'IDRISI') { if (datatype == 'INT2U') { datatype = 'INT2S' warning('IDRISI does not support INT2U. datatype changed to INT2S') } else if (datatype == 'INT4S') { datatype = 'INT2S' warning('IDRISI does not support INT4S. datatype changed to INT2S') } else if (datatype == 'INT1S') { datatype = 'INT1U' warning('IDRISI does not support INT1S. datatype changed to INT1U') } else if (datatype == 'LOG1S') { datatype = 'INT1U' warning('IDRISI does not support LOG1S. datatype changed to INT2S') } } if (filetype == 'SAGA') { resdif <- abs((yres(x) - xres(x)) / yres(x) ) if (resdif > 0.01) { stop( paste( "x has unequal horizontal and vertical resolutions. Such data cannot be stored in SAGA format" ) ) } } } dataType(x) <- datatype if (!missing(NAflag)) { x@file@nodatavalue <- NAflag } if (datatype == 'INT4U') { x@file@nodatavalue <- min(x@file@nodatavalue, 2147483647) # because as.integer returns SIGNED INT4s } overwrite <- .overwrite( ...) if (filetype == 'raster') { if (!overwrite & file.exists(filename)) { stop(paste(filename,"exists.","use 'overwrite=TRUE' if you want to overwrite it")) } } else { if (!overwrite & (file.exists(filename) | file.exists(fnamevals))) { stop(paste(filename,"or", fnamevals, "exists.","use 'overwrite=TRUE' if you want to overwrite it")) } } if (update) { attr(x@file, "con") <- file(fnamevals, "r+b") } else { attr(x@file, "con") <- file(fnamevals, "wb") } attr(x@file, "dsize") <- dataSize(x@file@datanotation) attr(x@file, "dtype") <- .shortDataType(x@file@datanotation) x@data@min <- rep(Inf, nlayers(x)) x@data@max <- rep(-Inf, nlayers(x)) x@data@haveminmax <- FALSE x@file@driver <- filetype x@file@name <- filename if ( filetype %in% c("BIL", "BSQ", "BIP") ) { bandorder <- filetype } else { bandorder <- 'BIL' if (nlayers(x) > 1) { bo <- list(...)$bandorder if (! is.null(bo)) { if (! bo %in% c('BIL', 'BIP', 'BSQ')) { warning('bandorder must be one of "BIL", "BSQ", or "BIP". Set to "BIL"') } else { bandorder <- bo } } } } x@file@bandorder <- bandorder x@file@byteorder <- .Platform$endian return(x) } .stopRasterWriting <- function(x) { close(x@file@con) # fnamevals <- .setFileExtensionValues(x@file@name) # attr(x@file, "con") <- file(fnamevals, "rb") x@data@haveminmax <- TRUE if (x@file@dtype == "INT") { x@data@min <- round(x@data@min) x@data@max <- round(x@data@max) } else if ( x@file@dtype =='LOG' ) { # x@data@min <- as.logical(x@data@min) # x@data@max <- as.logical(x@data@max) } #x@data@min[!is.finite(x@data@min)] <- NA #x@data@max[!is.finite(x@data@max)] <- NA hdr(x, .driver(x)) filename <- .setFileExtensionValues(filename(x), x@file@driver) if (inherits(x, 'RasterBrick')) { r <- brick(filename, native=TRUE) } else { r <- raster(filename, native=TRUE) } if (! r@data@haveminmax) { r@data@min <- x@data@min r@data@max <- x@data@max r@data@haveminmax <- TRUE } h <- .addHeader() if (h != '') { try( hdr(r, h), silent=TRUE ) } return(r) } raster/R/rasterFromGDAL.R0000644000176200001440000002375014533227614014670 0ustar liggesusers# Author: Robert J. Hijmans # Date : June 2008 # Version 1.0 # Licence GPL v3 # .gdFixGeoref <- function(mdata) { # gdversion <- getOption('rasterGDALVersion') # test <- gdversion < '1.8.0' # if (test) { # if (! is.null(mdata) ) { # for (i in 1:length(mdata)) { # if (mdata[i] == "AREA_OR_POINT=Area") { # return(FALSE) # } else if (mdata[i] == "AREA_OR_POINT=Point") { # return(TRUE) # } # } # } # } # return(FALSE) # } .rasterFromGDAL <- function(filename, band, type, sub=0, RAT=TRUE, silent=TRUE, warn=TRUE, crs="", ...) { x <- rast(filename, sub) if (crs != "") { crs(x) <- crs } r <- as(rast(x), "Raster") if (type == "RasterLayer") { r <- as(r, "RasterLayer") names(r) <- names(x)[1] } else { r <- as(r, "RasterBrick") names(r) <- names(x) } r@file@name <- filename r@file@driver <- 'gdal' r@data@fromdisk <- TRUE r@file@datanotation <- datatype(x)[1] if (any(hasMinMax(x))) { mnmx <- minmax(x) } else { mnmx <- matrix(NA, nrow=2, ncol=nlyr(x)) } minv <- mnmx[1,] maxv <- mnmx[2,] if ( all(c(is.finite(minv), is.finite(maxv)))) { r@data@haveminmax <- TRUE } r@file@nbands <- as.integer(nlyr(x)) bks <- terra::fileBlocksize(x) r@file@blockrows <- bks[,1] r@file@blockcols <- bks[,2] if (type == 'RasterLayer') { band <- as.integer(band) if ( band > nlyr(x) ) { stop(paste("band too high. Should be between 1 and", nlyr(x))) } if ( band < 1) { stop(paste("band should be 1 or higher")) } r@data@band <- band r@file@nbands <- as.integer(nlyr(x)) r@data@min <- minv[band] r@data@max <- maxv[band] sc <- scoff(x) r@data@gain <- sc[band,1] r@data@offset <- sc[band,2] if (is.factor(x)[1]) { cts <- cats(x)[[1]] if (!is.null(cts)) { colnames(cts)[1] <- "ID" levels(r) <- cts } } } else { r@data@min <- minv r@data@max <- maxv sc <- scoff(x) r@data@gain <- sc[,1] r@data@offset <- sc[,2] } return(r) # .requireRgdal() # if (sub > 0) { # gdalinfo <- rgdal::GDALinfo(filename, silent=TRUE, returnRAT=FALSE, returnCategoryNames=FALSE) # sub <- round(sub) # subdsmdata <- attr(gdalinfo, 'subdsmdata') # i <- grep(paste("SUBDATASET_", sub, "_NAME", sep=''), subdsmdata) # if (length(i) > 0) { # x <- subdsmdata[i[1]] # filename <- unlist(strsplit(x, '='))[2] # } else { # stop(paste('subdataset "sub=', sub, '" not available', sep='')) # } # } # suppressWarnings( # gdalinfo <- try ( rgdal::GDALinfo(filename, silent=silent, returnRAT=RAT, returnCategoryNames=RAT) ) # ) # if ( inherits(gdalinfo, "try-error")) { # gdalinfo <- rgdal::GDALinfo(filename, silent=silent, returnRAT=FALSE, returnCategoryNames=FALSE) # warning('Could not read RAT or Category names') # } # nc <- as.integer(gdalinfo[["columns"]]) # nr <- as.integer(gdalinfo[["rows"]]) # xn <- gdalinfo[["ll.x"]] # xn <- round(xn, digits=9) # xx <- xn + gdalinfo[["res.x"]] * nc # xx <- round(xx, digits=9) # yn <- gdalinfo[["ll.y"]] # yn <- round(yn, digits=9) # yx <- yn + gdalinfo[["res.y"]] * nr # yx <- round(yx, digits=9) # nbands <- as.integer(gdalinfo[["bands"]]) # if (isTRUE(attr(gdalinfo, "ysign") == 1)) { # warning("data seems flipped. Consider using: flip(x, direction='y')") # } # rotated <- FALSE # if (gdalinfo['oblique.x'] != 0 | gdalinfo['oblique.y'] != 0) { # rotated <- TRUE # ## adapted from rgdal::getGeoTransFunc # if (warn) { # warning('\n\n This file has a rotation\n Support for such files is limited and results of data processing might be wrong.\n Proceed with caution & consider using the "rectify" function\n') # } # rotMat <- matrix(gdalinfo[c('res.x', 'oblique.x', 'oblique.y', 'res.y')], 2) # ysign <- attr(gdalinfo, 'ysign') # rotMat[4] <- rotMat[4] * ysign # invMat <- solve(rotMat) # offset <- c(xn, yx) # trans <- function(x, inv=FALSE) { # if (inv) { # x <- t(t(x) - c(offset[1], offset[2])) # x <- round( x %*% invMat + 0.5 ) # x[x < 1] <- NA # x[x[,1] > nc | x[,2] > nr, ] <- NA # } else { # x <- (x - 0.5) %*% rotMat # x <- t(t(x) + c(offset[1], offset[2])) # } # return(x) # } # crd <- trans(cbind(c(0, 0, nc, nc), c(0, nr, 0, nr))+0.5) # rot <- methods::new(".Rotation") # gtr <- gdalinfo[c('ll.x', 'res.x', 'oblique.x', NA, 'oblique.y', 'res.y')] # gtr[4] <- yx # gtr[6] <- gtr[6] * ysign # rot@geotrans <- gtr # rot@transfun <- trans # xn <- min(crd[,1]) # xx <- max(crd[,1]) # yn <- min(crd[,2]) # yx <- max(crd[,2]) # } # mdata <- attr(gdalinfo, 'mdata') # fixGeoref <- FALSE # try( fixGeoref <- .gdFixGeoref(mdata), silent=TRUE ) # # for ENVI files # bnames <- unique(mdata[grep("Band_", mdata)]) # if (length(bnames) > 0) { # bn <- sapply(strsplit(bnames, '='), function(x) x[2]) # bi <- gsub("Band_", "", sapply(strsplit(bnames, '='), function(x) x[1])) # bnames <- try(bn[order(as.integer(bi))], silent=TRUE) # if ( inherits(bnames, "try-error") ) { # bnames <- NULL # } # } else { # gobj <- rgdal::GDAL.open(filename) # bnames <- rep("", nbands) # for (i in 1:nbands) { # objbnd <- rgdal::getRasterBand(gobj, i) # bnames[i] <- rgdal::getDescription(objbnd) # } # rgdal::GDAL.close(gobj) # } # if (type == 'RasterBrick') { # r <- brick(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs="") # r@file@nbands <- r@data@nlayers <- nbands # band <- 1:nbands # #RAT <- FALSE # } else { # r <- raster(ncols=nc, nrows=nr, xmn=xn, ymn=yn, xmx=xx, ymx=yx, crs="") # r@file@nbands <- as.integer(nbands) # band <- as.integer(band) # if ( band > nbands(r) ) { # stop(paste("band too high. Should be between 1 and", nbands)) # #if (warn) { # #stop("band too high. Set to nbands") # #} # #band <- nbands(r) # } # if ( band < 1) { # stop(paste("band should be 1 or higher")) # #if (warn) { # #stop("band too low. Set to 1") # #} # #band <- 1 # } # r@data@band <- as.integer(band) # nbands <-1 # } # if (rotated) { # r@rotated <- TRUE # r@rotation <- rot # } # prj <- attr(gdalinfo, 'projection') # if (!is.na(prj)) { # prjcom <- attr(prj, 'comment') # if ((!is.null(prjcom) && !is.na(prjcom))) { # prj <- prjcom # } # } # crs <- .getProj(prj, crs) # r@crs <- .spCRS(crs, TRUE) # #r@crs <- .spCRS(crs, FALSE) # # F to avoid warnings about other than WGS84 datums or ellipsoids # # r@history[[1]] <- mdata # bi <- attr(gdalinfo, 'df') # GDType <- as.character(bi[['GDType']]) # hasNoDataValues <- bi[['hasNoDataValue']] # NoDataValue <- bi[['NoDataValue']] # # if (getOption('rasterNewRGDALVersion')) { # # sbi <- attr(gdalinfo, 'sdf') # # Bmin <- sbi[['Bmin']] # # Bmax <- sbi[['Bmax']] # # } else { # Bmin <- bi[['Bmin']] # Bmax <- bi[['Bmax']] # # } # RATlist <- attr(gdalinfo, 'RATlist') # CATlist <- attr(gdalinfo, 'CATlist') # blockrows <- integer(nbands) # blockcols <- integer(nbands) # x <- rgdal::GDAL.open(filename, silent=TRUE) # ct <- rgdal::getColorTable( x ) # if (! is.null(ct)) { # r@legend@colortable <- ct # } # for (i in 1:nbands) { # bs <- rgdal::getRasterBlockSize( rgdal::getRasterBand(x, i) ) # blockrows[i] <- bs[1] # blockcols[i] <- bs[2] # } # rgdal::GDAL.close(x) # r@file@blockrows <- blockrows # r@file@blockcols <- blockcols # if (fixGeoref) { # message('Fixing "AREA_OR_POINT=Point" georeference') # rs <- res(r) # xmin(r) <- xmin(r) - 0.5 * rs[1] # xmax(r) <- xmax(r) - 0.5 * rs[1] # ymin(r) <- ymin(r) + 0.5 * rs[2] # ymax(r) <- ymax(r) + 0.5 * rs[2] # } # if (type == 'RasterBrick') { # ub <- unique(bnames) # if ((!all(ub == "")) && (length(ub) == nlayers(r))) { # names(r) <- bnames # } else { # names(r) <- rep(gsub(" ", "_", extension(basename(filename), "")), nbands) # } # } else { # lnames <- gsub(" ", "_", extension(basename(filename), "")) # if (nbands > 1) { # lnames <- paste0(lnames, '_', band) # } # names(r) <- lnames # } # r@file@name <- filename # r@file@driver <- 'gdal' # r@data@fromdisk <- TRUE # datatype <- "FLT4S" # minv <- rep(Inf, nlayers(r)) # maxv <- rep(-Inf, nlayers(r)) # try ( minv <- as.numeric( Bmin ) , silent=TRUE ) # try ( maxv <- as.numeric( Bmax ) , silent=TRUE ) # minv[minv == -4294967295] <- Inf # maxv[maxv == 4294967295] <- -Inf # try ( datatype <- .getRasterDType ( GDType[1] ), silent=TRUE ) # if ( all(c(is.finite(minv), is.finite(maxv)))) { # r@data@haveminmax <- TRUE # } # r@file@datanotation <- datatype # r@data@min <- minv[band] # r@data@max <- maxv[band] # rats <- ! sapply(RATlist, is.null) # if (any(rats)) { # att <- vector(length=nlayers(r), mode='list') # for (i in 1:length(RATlist)) { # if (! is.null(RATlist[[i]])) { # dr <- data.frame(RATlist[[i]], stringsAsFactors=TRUE) # wv <- which(colnames(dr)=='VALUE') # if (length(wv) > 0) { # if (wv != 1) { # dr <- data.frame(dr[,wv,drop=FALSE], dr[,-wv,drop=FALSE]) # } # colnames(dr)[1] <- 'ID' # } else { # if (all((colnames(dr) %in% c('Red', 'Green', 'Blue', 'Opacity', 'Histogram')))) { # # this is really a color table # rats[i] <- FALSE # if (is.null(ct)) { # r@legend@colortable <- grDevices::rgb(dr$Red, dr$Green, dr$Blue, dr$Opacity) # } # next # } else { # j <- which(colnames(dr) == 'Histogram') # if (isTRUE(j>0) & ncol(dr) > 1) { # dr <- data.frame(ID=0:(nrow(dr)-1), COUNT=dr[,j], dr[,-j,drop=FALSE]) # } else { # dr <- data.frame(ID=0:(nrow(dr)-1), dr) # } # } # } # att[[i]] <- dr # } # } # r@data@attributes <- att[band] # r@data@isfactor <- rats[band] # } else { # cats <- ! sapply(CATlist, is.null) # if (any(cats)) { # att <- vector(length=nlayers(r), mode='list') # for (i in 1:length(CATlist)) { # if (! is.null(CATlist[[i]])) { # att[[i]] <- data.frame(ID=(1:length(CATlist[[i]]))-1, category=CATlist[[i]], stringsAsFactors=TRUE) # } # } # r@data@attributes <- att[band] # r@data@isfactor <- cats[band] # } # } #return(r) } raster/NEWS0000644000176200001440000016454114723214717012274 0ustar liggesusers This package is no longer developed and only receives minimal maintenance. Please use the "terra" package instead. --- 18-September-2022, version 3.6-3 raster no longer uses rgdal --- 14-August-2022, version 3.5-29 raster no longer uses rgeos --- 5-October-2021, version 3.5-1 raster now imports terra (instead of the other way around) such that the two packages can be used together; and to allow replacing rgdal and rgeos functionality with functions from terra. --- 17-July-2020, version 3.3-13 overhaul of crs to be ready for PROJ6 several bug fixes (see https://github.com/rspatial/raster/issues?q=is%3Aissue+) --- 18-April-2020, version 3.1-5 improvements: new arguments "smin", "smax" and "samplesize" to "stretch"; and bug fixes. See https://github.com/rspatial/raster/issues/70 layer names in GTiff files are now read from file. Requested by Kyle Taylor https://github.com/rspatial/raster/issues/88 bug fixes: parallel version of extract with polygons and "fun" messed up the order of the values (reported by Jacory). https://github.com/rspatial/raster/issues/79 raster::predict bug when using factors (reported by vvirkki). https://github.com/rspatial/raster/issues/73 distanceFromPoints with large files: https://github.com/rspatial/raster/issues/103 colortable lost when cropping RasterBrick: https://github.com/rspatial/raster/issues/105 Error in stack() when providing both bands and varname: https://github.com/rspatial/raster/issues/97 rasterize and multi-polygon containing hole: https://github.com/rspatial/raster/issues/93 Upside down raster: https://github.com/rspatial/raster/issues/95 (a warning is given, not really fixed yet) Extract to data.frame bug: https://stackoverflow.com/questions/61174280/r-rasterextract-fails-to-create-data-frame --- 24-September-2019, version 3.0-7 Bug fixes: predict with character label factor variables returned NA only https://github.com/rspatial/raster/issues/68 cellFromPolygons now ignores possible incompatible (integer) user-specified default datatype (reported by John Baums, https://github.com/rspatial/raster/issues/69) --- 22-August-2019, version: 3.0-2 Bug fixes: calc failed when writing to disk if the supplied function returned multiple layers as a vector. Reported by Antoine Stevens reclassify bug reported by Jacub Nowasad. https://github.com/rspatial/raster/issues/62 extract failed for sf objects with a Z dimension. https://github.com/rspatial/raster/issues/64 More generics and namespace exports for compatibility with "terra" --- 10-July-2019, version: 2.9-22 New (hidden) function ".ifel", that is, ifelse for Raster objects (this is the R implementation of the arcpy "Con" method) Lots of namespace export additions for compatibility with "terra" Old .Call code replaced with Rcpp based code Bug fixes: netcdf writing for multi-layer objects was no working. Reported by Philipp Buehler https://github.com/rspatial/raster/issues/53 better handling of factor variables in raster::predict --- 14-May-2019, version: 2.9-5 new argument "margins" to plotRGB to allow plotting whitespace around images. The crs is now written to ncdf files, using proj4=" " reclassify now keeps the layer names (suggested by Matthieu Stigler) modal of a single layer now returns that layer with a warning instead of throwing an error (suggested by Ben Tupper) Bug fixes: writing very large Raster objects that were entirely in memory could fail with a "long vectors not supported yet". https://github.com/rspatial/raster/issues/33 When creating a RasterLayer from an ascii file using the native driver and the file specifies xllcenter. Problem reported by Ram: https://stackoverflow.com/questions/54373701/error-in-if-xn-xx-missing-value-where-true-false-needed Error coercing raster with one non-NA value to SpatialPixelsDataFrame (ickf.se) https://gis.stackexchange.com/questions/314472/error-coercing-raster-with-one-non-na-value-to-spatialpixelsdataframe/ mask with sf object ignored other arguments (Jakub Nowasad) improved handling of factors in "predict". Fixed a bug with gbm models (dismo) reported by Jane Elith. Also removes factor levels that are not in model for GLM (predictions become NA). show(Spatial*) could have the order of the min max values wrong on linux due to prepended spaces by as.matrix in apply(x, 2, range). Reported by Barry Rowlingson. Fixed bug in rasterFromXYZ (if multiple layers and writing to disk) reported by Mike Nosal https://github.com/rspatial/raster/issues/49 --- 29-Jan-2019, version: 2.8-19 higher precision extract with weights for small polygons. See https://stackoverflow.com/questions/53854910/issue-with-estimating-weighted-mean-from-raster-for-a-polygon-shape-in-r/ fixed error with rasterize when counting overlapping polygons with holes, reported by Boris Leroy. See: https://gis.stackexchange.com/questions/307770/inconsistencies-in-r-rasterize-polygons-packages-raster-and-sf fixed sf to sp coercion problem for degenerate Spatial*DataFrame with zero variables. Problem reported by Jakub Nowasad https://github.com/rspatial/raster/issues/29 fixed SRTM download in getData (new URL) and uppercase issue reported by tatianic https://github.com/rspatial/raster/issues/34 raster::isLonLat("+init=epsg:4326") now returns TRUE. Suggested by Mike Sumner https://github.com/rspatial/raster/issues/32 faster rasterization of polygons (introduced in previous versions, but, by mistake, was not used in most cases) faster handling of GMT ncdf files by Mike Sumner new argument "na.last" to "unique" suggsted by Marco Sciaini. https://github.com/rspatial/raster/issues/23 crosstab for small objects returned a data.frame instead of a table with long=FALSE. Reported by Jakub Nowosad Refined matching CF crs descriptions (in climate ncdf files) with proj, with suggestions from Paul Newell Improvement to raster::predict suggested by Roeland Kindt --- 2-Nov-2018, version: 2.8-4 Improved estimation of available RAM with contributions by Lorenzo Busetto. RAM available is now computed on windows, linux and mac. No more that 60% of available RAM is used (if the estimated RAM needed is not too low). Not more than raster:::.maxmemory() is used; but it should now be safe to set this to Inf. If canProcessInMemory() returns FALSE, chunksize is set 25% of available RAM, or raster:::.chunksize(), whichever is lower. (set options via rasterOptions()) testthat unit tests introduced by Mike Sumner and Jakub Nowosad as.character() for Raster objects to create the R code to re-create the Raster skeleton in examples. Reading point values via GDAL has become slower in 2.7-15, reverted to previous function. Thanks to Andrew Brown and Dylan Beaudette for identifying the problem. Bare negate with a Raster* (e.g. -r) now works. https://github.com/rspatial/raster/issues/21 Bug fixes: fixed the link for GADM countries download. Bug reported by Loic Dutrieux fixed corner-case bug in alignExtent (for a small extent, touching a grid cell), affecting crop; reported by Judith Mourant and Paul Fenimore fixed problem with subs reported by Andy Craig https://github.com/rspatial/raster/issues/17 Previous version had a maxmemory value that was too high (reported by Lorenzo Busetto) --- 16-Oct-2018, version: 2.7-15 faster extraction for points via GDAL (reverted to previous code in version 2.8-4) Bug fixes: buffer did not work with values in memory. Bug reported and solution proposed by Carlos Alberto Arnillas extract with point and smaller single cell buffer failed when an aggregation function was provided. Reported by Lucas https://stackoverflow.com/questions/52335522/r-why-does-raster-extract-give-dim-error/52338639#52338639 --- 11-Nov-2017, version: 2.6-6 New: new extent objects created from a vector of coordinates are now checked for being valid. Suggested by Mike Sumner buffer for lon/lat points erase for SpatialLines with Polygons kernelDensity function (hidden) output from freq is always ordered (whether computed from disk or from in memory values). Requested by Benjamin Leutner Bug fixes: as.data.frame from file based rasters ingored na.rm=TRUE (unless xy=TRUE). Reported by Jean-Gabriel Elie getValuesBlock with lyrs argument. Reported by Antoine Stevens In approxNA with large files NAs were ignored and the NArule was ignored. Reported by Pablo Timoner isValid(raster()) failed. Reported by dww on http://stackoverflow.com/questions/37869271/how-to-dput-a-raster/37871930 zapply passes on ... arguments to stackApply res() for rotated rasters was wrong https://gis.stackexchange.com/questions/259321/opening-rotated-raster-in-r (fix suggested by Spacedman) cover with RasterStackBrick objects could not write to file (reported by L. Wasser https://stackoverflow.com/questions/44295842/r-raster-cover-function-error-with-landsat-stacks Raster Attribute Tables with labels with a colon it could not be written because the colon was used as delimiter in the grd file. https://stackoverflow.com/questions/46832976/why-is-crop-sometimes-introducing-nas-on-a-categorical-raster An error was thrown if "rasterToPoints" returned no points, and "spatial=TRUE". Instead an empty SpatialPointsDataFrame is now returned (reported and suggested by Arnaud Mosnier) Another error when rasterToPoints was used on a single-pixel multi-layer raster object (reported by Daniele Baisero) rasterize polygons bugged in some cases if a polygon node was exactly in the center of a cell. Reported by Marco Sciaini https://gis.stackexchange.com/questions/252210/rasterize-a-spatialpolygonsdataframe-error-in-if-x2a-rxmn bug in projectRaster related to dateline: https://stackoverflow.com/questions/47047623/projectraster-raster-projection-of-bathymetry-data-noaa-nc-in-the-pacific raster::pring of a SpatialPointsDataFrame showed an error message if the data.frame had zero columns (reported by Bart Branstauber) Really bad bug: for Raster 'r', 'r < 50' was not equivalent to '50 > r' (the latter being wrong!). Reported by Jonathan Proctor Error in the correction for the standard deviation with asSample=FALSE. Reported and fix provided by Benjamin Leutner raster::colSums gave false results when !canProcessInMemory(x). Reported and fix provided by Peter Kullberg zonal( ,stat='sd') did not work. Reported by Matt Biber --- 31-May-2016, version: 2.5-8 new functions for Raster objects: as.integer, as.list new functions whiches.min and whiches.max (to get all layers that are which.min/max) added 'forcefun' argument to overlay atan2 now available for all Raster objects several minor fixes --- 19-December-2015, version: 2.5-2 Bug fixes: The order of the layers returned by stackApply was only as expected of the indices were sorted from 1 to n. Reported by Mark Payne rasterize(..., getCover=TRUE) again did not work properly. Reported by Pascal Title as.vector gave trouble on different version (R-devel vs. R-current). Work around implemented. --- 10-December-2015, version: 2.4-30 package ncdf is now obsolete and no longer supported (use ncdf4 instead) Major bug fixes: Extraction of values with xy or cellnumber from a ncdf file where 'level' is the fourth variable (and time third, in stead of the other way around) did not work correctly. Reported by John Gross rasterize(..., getCover=TRUE) did not work properly. Reported by Sam Tomlinso Minor bug fixes: in rasterFromXYZ (by Gareth Davies) in crop (by Florian Detsch) in stack (http://stackoverflow.com/questions/32564932/r-import-two-or-more-selected-bands-from-an-image-stack) in sampleStratified (by Antoine Stevens) --- 8-September-2015, version: 2.4-20 Andrei Mirt send a bug fix for corLocal namespace now captures all functions from other packages .nchar to replace nchar to avoid R version problem Sebastian Bock reported a bug in raster:::.circular.weight various minor fixes --- 2-July-2015, version: 2.4-15 Improved geodesic algorithm (GeograhicLib by C.F.F. Karney) for pointDistance and other lon/lat distance computations, and to compute the area of an ellipsoidal polygon significant speed improvement for bilinear resample / projection (by Joe Cheng) new functions colSums and rowSums fixed colnames for extract(s, points, df = TRUE, cellnumbers = TRUE). Reported by Loic Dutrieux fixes to avoid errors thrown by current PROJ.4 (crs must have ellipsoid or datum) bug fix: writeRaster did not write names of in memory RasterLayers. Reported by Toph Allen temp files were not removed. Fixed by Samuel Bosch image failed for a raster with a single row. Patched by Daniel Schlaepfer --- 11-April-2015, version: 2.3-40 Category names are now written to file via rgdal or native format color tables are now written to file via rgdal or native format bug fixes: Creating a brick from RasterLayers with a filename argument did not deal with 'overwrite=TRUE'. Reported by Tom Philippi boxplot with two raster wasn't going right (reported by Stefan Schlaffer) native format can now write/read POSIXct z-values (patch provided by Stefan Schlaffer) error in rasterize/mask with SpatialPolygons that go outside the raster --- 12-March-2015, version: 2.3-33 bug fix in extract(Raster, SpatialPolygons, na.rm=TRUE); na.rm=T was ignored in some cases. (reported by Lewis Hagedorn) bug fix in union(SpatialPolygons,missing) added extraction of layer names for .img files from gdal metadata new unit option ('tangent') to compute slopes (terrain function) transparency (in plot) can now be set using another RasterLayer --- 25-January-2015, version: 2.3-24 removed several checks for 'minor' R version that were no longer necessary and wrong since major version 3 (reported by Edzer Pebesma) normalizeWeights argument to extract with polygon. Default is TRUE such that weights add up to 1. Setting it to FALSE allows to get the same numbers as in earlier versions (in response to query by Nick Bond) bug fixes: overlay did not check if rasters have the same structure if only two objects were used. Reported by 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 calendar in netcdf files --- 1-September-2012, version 2.0-12 fixed bug in summary reported by Agustin Lobo fixed bug in terrain/flowdir reported by Marie Morfin zlim (argument to plot) did not function properly when used to extend the values range (reported by Bart) writeRaster now honours the value of the NAvalue argument when writing a ncdf file (requested by Thiago Veloso) added support for the ncdf4 library fixed many spelling mistakes in the documentation reported by Phil Heilman function fourCellsFromXY is now visible. method 'freq' implemented for 'RasterStackBrick' new function 'layerize' function 'reclassify' replaces identical 'reclass' (still available but with deprecation warning) to avoid hiding by xts::reclass added arguments to writeRaster to allow for writing layers to individual files --- 27-June-2012, version 2.0-08 bug fixes (both introduced in version 2.0-04): multilayer files of the 'raster' format have a corrupt header file (reported by Jonathan Greenberg) subset with a RasterBrick fails because of an error when accessing the z slot (reported by Matt Fischer) crop with a RasterStack failed new option 'tmptime' to set after how many hours temp files may be deleted. Suggested by Shannon Albeke --- 17-June-2012, version 2.0-04 More support for factors and (related) Raster Attribute Tables (functions ratify, deratify) z-values are saved to file (native format only) Old slot @zvalue removed (in favor of slot @z) New function 'names' to (eventually) replace 'layerNames', for compatibility with sp. New function 'proj4string' (equivalent to 'projection') for compatibility with sp. New function 'sampleStratified' Improved speed for creating a RasterStack from a list of RasterLayer objects (thanks to report by Jonathan Kennel), and for rasterToPoints setValues(brick, values) now also works if the existing values (on disk) cannot be all loaded into memory (suggested by Jonathan Greenberg). bug fixes: rasterize with polygons ignores the 'field' argument (bug introduced in previous version) log failed when writing to disk (reported by Jochen Albrecht) sampleRegular failed in some cases for a RasterStack (affecting spplot). Reported by Matthew Landis) --- 1-May-2012, version 1.9-82 New features, improvements: New function weighted.mean New function layerStats to compute the correlation, covariance and weighted covariance matrix across layers (by Jonathan Greenberg) crosstab can now also process multi-layer objects, suggested by Neil Best Improved speed of getValuesBlock for RasterBrick using suggestion by Stefan Schlaffer print method for Spatial* objects similar to that for Raster* objects bug fixes: 'overlay' ignored the writeRaster arguments. Reported by Oliver Soong The 'buffer' argument in extract (with points) was lost in the previous version. It has been restored. In extract with polygons failed with "getCover=TRUE". Reported by Ariel Ortiz-Bobea 'predict' now also works when using a single predictor raster layer. Reported by Ben Weinstein 'crop' now accepts a 'datatype' argument. Reported by Jonathan Greenberg --- 5-April-2012, version 1.9-82 New function 'getValuesFocal' to get focal values (a cell and its neighborhood) Added .tmpdir function, provided by Shaun Walbridge, to make the name of the folder used to store temporary files user-specific to avoid collisions on multi-user platforms such as cluster computers. Improved support for accessing subdatasets (in gdal provided raster data). Non-standard names like "subdatset:filename" should now work (previously some were normalized to (invalid) path names). There is also an argument "sub" in raster(). Bug fixes: disaggregate sometimes failed for large files, patched by Jim Regetz. It was not possible to make a RasterStack from a single-layer RasterBrick (reported by Julian Zeidler). The 'slope' returned by 'terrain' was not correct when used together with 'tri', 'tpi', or 'roughness', and when you use unit = 'degrees' (reported by Forrest Stevens) predict / randomForest failed with more than one factor variable, reported by Xiong Xiong Fixed bug when writing to EHdr files, reported by Elena It is now assured that the filename returned by rasterTmpFile() does not exist (avoiding "overwrite" problems, reported by Diann Prosser). --- 27-February-2012, version 1.9-70 Removed function 'polygonFromExtent' (in favor of as(x, 'SpatialPolygons') ) In 'compare', the name of argument 'prj' was changed to 'crs' Fixed bug in srtm download limits. Reported by Stefan Schlaffer Fixed bug that made init fail for large rasters. Reported by Oscar 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 (later moved to RasterVis) new slot 'z' in Raster* objects to (somewhat) formalize management of time series. Is to replace the 'zvalue' slot new function zApply (by Oscar 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 simplifications for 'raster', 'stack', and 'brick' functions raster no longer has the "values" argument (use setValues) When adding layers to a RasterBrick, a RasterStack will be returned. Fixed calc for regression functions Fixed data handling error causing full memory in extract(points, buffer) (reported by Steve Mosher) Fixed bug in projectRaster when projecting a raster from a regional crs to a global crs that caused the values to duplicate (reported by Bart Kranstauber) crosstab can now return results in 'long' format more complete and flexible recycling in overlay and Arith Added boxplot function for Raster* objects New version of alignExtent (bug reported by Keven Ummel) overlay now allows for RasterStackBrick / RasterLayer combination (bug reported by Keven Ummel) cluster object stored as 'option' --- 17-Nov-2010, version 1.6-22 NAflag honored when writing ascii file. multicore support for resample Bug fix in pairs (David Ramsey) Bug fix in rasterize with lines (Julian Burgos) --- 14-Nov-2010, version 1.6-19 Fixed bug in .stopGDALwrting (reported by Kevin Ummel and Lyndon Estes) Experimental support for multicore in functions projectRaster and distance Started support for multi-core/cluster processing (together with Matteo Mattiuzzi) Fixed bug in aggregate with unequal x and y fact (thanks to Kevin Ummel for reporting) Added drop=FALSE to "[" methods, to return a Raster*. [[ method to extract layers from multi-layer Raster objects Writing cdf files now uses the CF standard 'degrees_east' and 'degrees_north' as variable names in lon/lat data (suggested by Kevin Ummel) fixed bug when using se.fit=TRUE in predict (it did not respond to it). Reported by Eliane Meier. Also changed the above that when se.fit=T, both the prediction AND the s.e. are returned (as a RasterBrick) changed NAvalue argument in writeRaster to NAflag to avoid confusion with NAvalue function fixed backwards compatability by replacing packageVersion('rgdal') to packageDescription('rgdal')$Version --- 5-Nov-2010, version 1.6-15 'unique' now also works for multi-layer objects Using new features in GDAL 0.6-29: set statistics and capture raster attributes Replacing pointsToRater, linesToRaster and polygonsToRaster with single generic function 'rasterize' Introduces support for netcdf files with 4 dimensions (lon, lat, level, time), because of a problem reported by Kevin Ummel --- 30-Oct-2010, version 1.6-10 Improved [ and [<- methods. Removed [[ methods Introduced sub-setting of Raster* objects with Spatial* objects Additional options to linesToRaster (to match polygonsToRaster) as.matrix implemented for Raster* objects (suggested by Michael Sumner) writeRaster now takes optional arguments varname, varunit, longname, xname, yname, zname, zunit, for writing netcdf files (requested by Mario Frasca). Merged 'focalValues' into 'extract' Removed 'getValuesExtent', it was a synonym to 'extract(x=Raster, y=extent)' Temporary files are now only deleted (at startup of raster) if they are at least 24 hrs old Generic function 'cut' implemented for Raster objects (suggested by Steven Mosher) Bug fix in addLayer with RasterBrick (reported by Steven Mosher) Fixed bug in reading values from a 2-dimensional netcdf file (no 'time') (reported by Steven Mosher) Fixed bug in reading cell values from netcdf file that can not be read into memory (reported by Steven Mosher) New generic function 'extract', to replace xyValues, cellValues, lineValues, polygonValues Improvements to rasterFromXYZ (thanks to Thiago Veloso). writeHdr can now write VRT (GDAL virtual raster) header files to accompany .gri files such that these can be viewed in e.g. ArcGIS and QGIS. Adjustments to calc to allow it to return any number of layers from a computation on a multiple layer object --- 11-Oct-2010, version 1.5-16 netcdf files writing in chunks. netcdf create a RasterLayer from a RasterBrick no longer goes to disk (copy parameters in memory) raster() now also takes an "image" (a list with x, y and z) argument and coerces it to a RasterLayer bug fixes in .readRowsAscii (reported by Manuel 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@gain and @data@offset slots to Raster* objects and use these when reading values from file v = v * gain + offset (suggestion by Jonathan Greenberg) It is now possible to do Arith (e.g. addition, multiplication) with a RasterStack or Brick using a vector argument of lenght that equals nlayers(object). E.g. you can mutliply a RasterStack with 5 layers with vector c(1,3,5,3,1), where indices are matched to layers. It is also possible to do Arith & Math with mutliple RasterStackBrick objects (as long as nlayers is the same) and with a RasterStack/Brick and a RasterLayer objects. --- 12-Aug-2010, version 1.3-11 Expanded sampleRandom by adding a 'cells' and 'extent' argument; Switched from RNetCDF to ncdf package for netcdf file support Added three slots to class BasicRaster unit='vector' ; to store the unit of the layer(s), e.g. "kg m-2 s-1" zname='character' ; to store the name of the z (layers) variable, e.g. "time" zvalue='vector' ; to store the values of the z variable, e.g. the dates corresponding to each later These slots are now filled for values from netcdf files with "CF" type convention (e.g. cmip), with an attempt to covert "days since" to a Date (coverted to string). Not yet used in writing, or with other formats New clump function, now always using igraph (also for large rasters) & minor bug fix Fixes to subs function (needs more checking) To allow for better behaviour when using objects derived from Raster* objects (perhaps in other packages), replaced code like "if (class(x) == 'RasterLayer')" with "if (inherits(x, 'RasterLayer'))" Bug fix: error when indexing a RasterStack as in s[1] (as reported by Kevin Ummel) --- 27-July-2010, version 1.3-4 Starting this log raster/src/0000755000176200001440000000000014742230324012342 5ustar liggesusersraster/src/RasterModule.cpp0000644000176200001440000000335414507510157015465 0ustar liggesusers#include #include "spat.h" using namespace Rcpp; RCPP_EXPOSED_CLASS(SpExtent) RCPP_EXPOSED_CLASS(SpPolyPart) RCPP_EXPOSED_CLASS(SpPoly) RCPP_EXPOSED_CLASS(SpPolygons) RCPP_MODULE(spmod){ using namespace Rcpp; class_("SpPolyPart") .constructor() .field_readonly("x", &SpPolyPart::x ) .field_readonly("y", &SpPolyPart::y ) .field_readonly("extent", &SpPolyPart::extent ) .method("set", &SpPolyPart::set, "set") .method("setHole", &SpPolyPart::setHole, "setHole") .method("getHoleX", &SpPolyPart::getHoleX, "getHoleX") .method("getHoleY", &SpPolyPart::getHoleY, "getHoleY") .method("nHoles", &SpPolyPart::nHoles, "nHoles") .method("hasHoles", &SpPolyPart::hasHoles, "hasHoles") ; class_("SpPoly") .constructor() .field_readonly("extent", &SpPoly::extent ) .method("getPart", &SpPoly::getPart, "getPart") .method("addPart", &SpPoly::addPart, "addPart") .method("size", &SpPoly::size, "size") ; class_("SpPolygons") // .field("polygons", &SpPolygons::polys ) .field_readonly("extent", &SpPolygons::extent ) .field("attr", &SpPolygons::attr ) .field("crs", &SpPolygons::crs ) .constructor() .method("getPoly", &SpPolygons::getPoly, "getPoly") .method("addPoly", &SpPolygons::addPoly, "addPoly") .method("size", &SpPolygons::size, "size") .method("getAtt", &SpPolygons::getAtt, "getAtt") .method("setAtt", &SpPolygons::setAtt, "setAtt") .method("rasterize", &SpPolygons::rasterize, "rasterize") .method("subset", &SpPolygons::subset, "subset") ; class_("SpExtent") .constructor() .constructor() .property("vector", &SpExtent::asVector) .property("valid", &SpExtent::valid) ; } raster/src/RcppExports.cpp0000644000176200001440000005543414507510157015356 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include using namespace Rcpp; // doBilinear NumericVector doBilinear(NumericMatrix xy, NumericMatrix x, NumericMatrix y, NumericMatrix v); RcppExport SEXP _raster_doBilinear(SEXP xySEXP, SEXP xSEXP, SEXP ySEXP, SEXP vSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type xy(xySEXP); Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type y(ySEXP); Rcpp::traits::input_parameter< NumericMatrix >::type v(vSEXP); rcpp_result_gen = Rcpp::wrap(doBilinear(xy, x, y, v)); return rcpp_result_gen; END_RCPP } // broom std::vector broom(std::vector d, std::vector f, std::vector dm, std::vector dist, bool down); RcppExport SEXP _raster_broom(SEXP dSEXP, SEXP fSEXP, SEXP dmSEXP, SEXP distSEXP, SEXP downSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type f(fSEXP); Rcpp::traits::input_parameter< std::vector >::type dm(dmSEXP); Rcpp::traits::input_parameter< std::vector >::type dist(distSEXP); Rcpp::traits::input_parameter< bool >::type down(downSEXP); rcpp_result_gen = Rcpp::wrap(broom(d, f, dm, dist, down)); return rcpp_result_gen; END_RCPP } // doCellFromRowCol NumericVector doCellFromRowCol(IntegerVector nrow, IntegerVector ncol, IntegerVector rownr, IntegerVector colnr); RcppExport SEXP _raster_doCellFromRowCol(SEXP nrowSEXP, SEXP ncolSEXP, SEXP rownrSEXP, SEXP colnrSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< IntegerVector >::type nrow(nrowSEXP); Rcpp::traits::input_parameter< IntegerVector >::type ncol(ncolSEXP); Rcpp::traits::input_parameter< IntegerVector >::type rownr(rownrSEXP); Rcpp::traits::input_parameter< IntegerVector >::type colnr(colnrSEXP); rcpp_result_gen = Rcpp::wrap(doCellFromRowCol(nrow, ncol, rownr, colnr)); return rcpp_result_gen; END_RCPP } // do_clamp Rcpp::NumericVector do_clamp(std::vector d, std::vector r, bool usevals); RcppExport SEXP _raster_do_clamp(SEXP dSEXP, SEXP rSEXP, SEXP usevalsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type r(rSEXP); Rcpp::traits::input_parameter< bool >::type usevals(usevalsSEXP); rcpp_result_gen = Rcpp::wrap(do_clamp(d, r, usevals)); return rcpp_result_gen; END_RCPP } // do_edge std::vector do_edge(std::vector d, std::vector dim, bool classes, bool edgetype, unsigned dirs); RcppExport SEXP _raster_do_edge(SEXP dSEXP, SEXP dimSEXP, SEXP classesSEXP, SEXP edgetypeSEXP, SEXP dirsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< bool >::type classes(classesSEXP); Rcpp::traits::input_parameter< bool >::type edgetype(edgetypeSEXP); Rcpp::traits::input_parameter< unsigned >::type dirs(dirsSEXP); rcpp_result_gen = Rcpp::wrap(do_edge(d, dim, classes, edgetype, dirs)); return rcpp_result_gen; END_RCPP } // do_focal_fun std::vector do_focal_fun(std::vector d, Rcpp::NumericMatrix w, std::vector dim, Rcpp::Function fun, bool naonly); RcppExport SEXP _raster_do_focal_fun(SEXP dSEXP, SEXP wSEXP, SEXP dimSEXP, SEXP funSEXP, SEXP naonlySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type w(wSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< Rcpp::Function >::type fun(funSEXP); Rcpp::traits::input_parameter< bool >::type naonly(naonlySEXP); rcpp_result_gen = Rcpp::wrap(do_focal_fun(d, w, dim, fun, naonly)); return rcpp_result_gen; END_RCPP } // do_focal_get std::vector do_focal_get(std::vector d, std::vector dim, std::vector ngb); RcppExport SEXP _raster_do_focal_get(SEXP dSEXP, SEXP dimSEXP, SEXP ngbSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< std::vector >::type ngb(ngbSEXP); rcpp_result_gen = Rcpp::wrap(do_focal_get(d, dim, ngb)); return rcpp_result_gen; END_RCPP } // do_focal_sum std::vector do_focal_sum(std::vector d, Rcpp::NumericMatrix w, std::vector dim, bool narm, bool naonly, bool bemean); RcppExport SEXP _raster_do_focal_sum(SEXP dSEXP, SEXP wSEXP, SEXP dimSEXP, SEXP narmSEXP, SEXP naonlySEXP, SEXP bemeanSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type w(wSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); Rcpp::traits::input_parameter< bool >::type naonly(naonlySEXP); Rcpp::traits::input_parameter< bool >::type bemean(bemeanSEXP); rcpp_result_gen = Rcpp::wrap(do_focal_sum(d, w, dim, narm, naonly, bemean)); return rcpp_result_gen; END_RCPP } // getPolygons NumericMatrix getPolygons(NumericMatrix xyv, NumericVector res, int nodes); RcppExport SEXP _raster_getPolygons(SEXP xyvSEXP, SEXP resSEXP, SEXP nodesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type xyv(xyvSEXP); Rcpp::traits::input_parameter< NumericVector >::type res(resSEXP); Rcpp::traits::input_parameter< int >::type nodes(nodesSEXP); rcpp_result_gen = Rcpp::wrap(getPolygons(xyv, res, nodes)); return rcpp_result_gen; END_RCPP } // layerize Rcpp::NumericVector layerize(std::vector d, std::vector cls, bool falsena); RcppExport SEXP _raster_layerize(SEXP dSEXP, SEXP clsSEXP, SEXP falsenaSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type cls(clsSEXP); Rcpp::traits::input_parameter< bool >::type falsena(falsenaSEXP); rcpp_result_gen = Rcpp::wrap(layerize(d, cls, falsena)); return rcpp_result_gen; END_RCPP } // availableRAM double availableRAM(double ram); RcppExport SEXP _raster_availableRAM(SEXP ramSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< double >::type ram(ramSEXP); rcpp_result_gen = Rcpp::wrap(availableRAM(ram)); return rcpp_result_gen; END_RCPP } // getMode double getMode(NumericVector values, int ties); RcppExport SEXP _raster_getMode(SEXP valuesSEXP, SEXP tiesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type values(valuesSEXP); Rcpp::traits::input_parameter< int >::type ties(tiesSEXP); rcpp_result_gen = Rcpp::wrap(getMode(values, ties)); return rcpp_result_gen; END_RCPP } // doSpmin NumericVector doSpmin(NumericVector x, NumericVector y); RcppExport SEXP _raster_doSpmin(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(doSpmin(x, y)); return rcpp_result_gen; END_RCPP } // doSpmax NumericVector doSpmax(NumericVector x, NumericVector y); RcppExport SEXP _raster_doSpmax(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(doSpmax(x, y)); return rcpp_result_gen; END_RCPP } // ppmin NumericVector ppmin(NumericVector x, NumericVector y, bool narm); RcppExport SEXP _raster_ppmin(SEXP xSEXP, SEXP ySEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(ppmin(x, y, narm)); return rcpp_result_gen; END_RCPP } // ppmax NumericVector ppmax(NumericVector x, NumericVector y, bool narm); RcppExport SEXP _raster_ppmax(SEXP xSEXP, SEXP ySEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(ppmax(x, y, narm)); return rcpp_result_gen; END_RCPP } // doRowMin NumericVector doRowMin(NumericMatrix x, bool narm); RcppExport SEXP _raster_doRowMin(SEXP xSEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(doRowMin(x, narm)); return rcpp_result_gen; END_RCPP } // doRowMax NumericVector doRowMax(NumericMatrix x, bool narm); RcppExport SEXP _raster_doRowMax(SEXP xSEXP, SEXP narmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); rcpp_result_gen = Rcpp::wrap(doRowMax(x, narm)); return rcpp_result_gen; END_RCPP } // aggregate_get Rcpp::NumericMatrix aggregate_get(Rcpp::NumericMatrix d, Rcpp::NumericVector dims); RcppExport SEXP _raster_aggregate_get(SEXP dSEXP, SEXP dimsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericVector >::type dims(dimsSEXP); rcpp_result_gen = Rcpp::wrap(aggregate_get(d, dims)); return rcpp_result_gen; END_RCPP } // aggregate_fun Rcpp::NumericMatrix aggregate_fun(Rcpp::NumericMatrix d, Rcpp::NumericVector dims, bool narm, int fun); RcppExport SEXP _raster_aggregate_fun(SEXP dSEXP, SEXP dimsSEXP, SEXP narmSEXP, SEXP funSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericVector >::type dims(dimsSEXP); Rcpp::traits::input_parameter< bool >::type narm(narmSEXP); Rcpp::traits::input_parameter< int >::type fun(funSEXP); rcpp_result_gen = Rcpp::wrap(aggregate_fun(d, dims, narm, fun)); return rcpp_result_gen; END_RCPP } // get_area_polygon Rcpp::NumericVector get_area_polygon(Rcpp::NumericMatrix d, bool lonlat); RcppExport SEXP _raster_get_area_polygon(SEXP dSEXP, SEXP lonlatSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); rcpp_result_gen = Rcpp::wrap(get_area_polygon(d, lonlat)); return rcpp_result_gen; END_RCPP } // point_distance Rcpp::NumericVector point_distance(Rcpp::NumericMatrix p1, Rcpp::NumericMatrix p2, bool lonlat, double a, double f); RcppExport SEXP _raster_point_distance(SEXP p1SEXP, SEXP p2SEXP, SEXP lonlatSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p1(p1SEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p2(p2SEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(point_distance(p1, p2, lonlat, a, f)); return rcpp_result_gen; END_RCPP } // distanceToNearestPoint Rcpp::NumericVector distanceToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, double a, double f); RcppExport SEXP _raster_distanceToNearestPoint(SEXP dSEXP, SEXP pSEXP, SEXP lonlatSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p(pSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(distanceToNearestPoint(d, p, lonlat, a, f)); return rcpp_result_gen; END_RCPP } // directionToNearestPoint Rcpp::NumericVector directionToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, bool degrees, bool from, double a, double f); RcppExport SEXP _raster_directionToNearestPoint(SEXP dSEXP, SEXP pSEXP, SEXP lonlatSEXP, SEXP degreesSEXP, SEXP fromSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type p(pSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< bool >::type degrees(degreesSEXP); Rcpp::traits::input_parameter< bool >::type from(fromSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(directionToNearestPoint(d, p, lonlat, degrees, from, a, f)); return rcpp_result_gen; END_RCPP } // dest_point Rcpp::NumericMatrix dest_point(Rcpp::NumericMatrix xybd, bool lonlat, double a, double f); RcppExport SEXP _raster_dest_point(SEXP xybdSEXP, SEXP lonlatSEXP, SEXP aSEXP, SEXP fSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type xybd(xybdSEXP); Rcpp::traits::input_parameter< bool >::type lonlat(lonlatSEXP); Rcpp::traits::input_parameter< double >::type a(aSEXP); Rcpp::traits::input_parameter< double >::type f(fSEXP); rcpp_result_gen = Rcpp::wrap(dest_point(xybd, lonlat, a, f)); return rcpp_result_gen; END_RCPP } // reclassify Rcpp::NumericVector reclassify(Rcpp::NumericVector d, Rcpp::NumericMatrix rcl, bool dolowest, bool doright, bool doleftright, bool NAonly, double NAval); RcppExport SEXP _raster_reclassify(SEXP dSEXP, SEXP rclSEXP, SEXP dolowestSEXP, SEXP dorightSEXP, SEXP doleftrightSEXP, SEXP NAonlySEXP, SEXP NAvalSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type d(dSEXP); Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type rcl(rclSEXP); Rcpp::traits::input_parameter< bool >::type dolowest(dolowestSEXP); Rcpp::traits::input_parameter< bool >::type doright(dorightSEXP); Rcpp::traits::input_parameter< bool >::type doleftright(doleftrightSEXP); Rcpp::traits::input_parameter< bool >::type NAonly(NAonlySEXP); Rcpp::traits::input_parameter< double >::type NAval(NAvalSEXP); rcpp_result_gen = Rcpp::wrap(reclassify(d, rcl, dolowest, doright, doleftright, NAonly, NAval)); return rcpp_result_gen; END_RCPP } // do_terrains std::vector do_terrains(std::vector d, std::vector dim, std::vector res, int unit, std::vector option, bool geo, std::vector gy); RcppExport SEXP _raster_do_terrains(SEXP dSEXP, SEXP dimSEXP, SEXP resSEXP, SEXP unitSEXP, SEXP optionSEXP, SEXP geoSEXP, SEXP gySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< std::vector >::type d(dSEXP); Rcpp::traits::input_parameter< std::vector >::type dim(dimSEXP); Rcpp::traits::input_parameter< std::vector >::type res(resSEXP); Rcpp::traits::input_parameter< int >::type unit(unitSEXP); Rcpp::traits::input_parameter< std::vector >::type option(optionSEXP); Rcpp::traits::input_parameter< bool >::type geo(geoSEXP); Rcpp::traits::input_parameter< std::vector >::type gy(gySEXP); rcpp_result_gen = Rcpp::wrap(do_terrains(d, dim, res, unit, option, geo, gy)); return rcpp_result_gen; END_RCPP } // doCellFromXY NumericVector doCellFromXY(int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericVector x, NumericVector y); RcppExport SEXP _raster_doCellFromXY(SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP xminSEXP, SEXP xmaxSEXP, SEXP yminSEXP, SEXP ymaxSEXP, SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< int >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< int >::type nrows(nrowsSEXP); Rcpp::traits::input_parameter< double >::type xmin(xminSEXP); Rcpp::traits::input_parameter< double >::type xmax(xmaxSEXP); Rcpp::traits::input_parameter< double >::type ymin(yminSEXP); Rcpp::traits::input_parameter< double >::type ymax(ymaxSEXP); Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(doCellFromXY(ncols, nrows, xmin, xmax, ymin, ymax, x, y)); return rcpp_result_gen; END_RCPP } // doXYFromCell NumericMatrix doXYFromCell(unsigned ncols, unsigned nrows, double xmin, double xmax, double ymin, double ymax, NumericVector cell); RcppExport SEXP _raster_doXYFromCell(SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP xminSEXP, SEXP xmaxSEXP, SEXP yminSEXP, SEXP ymaxSEXP, SEXP cellSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< unsigned >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< unsigned >::type nrows(nrowsSEXP); Rcpp::traits::input_parameter< double >::type xmin(xminSEXP); Rcpp::traits::input_parameter< double >::type xmax(xmaxSEXP); Rcpp::traits::input_parameter< double >::type ymin(yminSEXP); Rcpp::traits::input_parameter< double >::type ymax(ymaxSEXP); Rcpp::traits::input_parameter< NumericVector >::type cell(cellSEXP); rcpp_result_gen = Rcpp::wrap(doXYFromCell(ncols, nrows, xmin, xmax, ymin, ymax, cell)); return rcpp_result_gen; END_RCPP } // doFourCellsFromXY NumericMatrix doFourCellsFromXY(int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericMatrix xy, bool duplicates, bool isGlobalLonLat); RcppExport SEXP _raster_doFourCellsFromXY(SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP xminSEXP, SEXP xmaxSEXP, SEXP yminSEXP, SEXP ymaxSEXP, SEXP xySEXP, SEXP duplicatesSEXP, SEXP isGlobalLonLatSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< int >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< int >::type nrows(nrowsSEXP); Rcpp::traits::input_parameter< double >::type xmin(xminSEXP); Rcpp::traits::input_parameter< double >::type xmax(xmaxSEXP); Rcpp::traits::input_parameter< double >::type ymin(yminSEXP); Rcpp::traits::input_parameter< double >::type ymax(ymaxSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type xy(xySEXP); Rcpp::traits::input_parameter< bool >::type duplicates(duplicatesSEXP); Rcpp::traits::input_parameter< bool >::type isGlobalLonLat(isGlobalLonLatSEXP); rcpp_result_gen = Rcpp::wrap(doFourCellsFromXY(ncols, nrows, xmin, xmax, ymin, ymax, xy, duplicates, isGlobalLonLat)); return rcpp_result_gen; END_RCPP } RcppExport SEXP _rcpp_module_boot_spmod(); static const R_CallMethodDef CallEntries[] = { {"_raster_doBilinear", (DL_FUNC) &_raster_doBilinear, 4}, {"_raster_broom", (DL_FUNC) &_raster_broom, 5}, {"_raster_doCellFromRowCol", (DL_FUNC) &_raster_doCellFromRowCol, 4}, {"_raster_do_clamp", (DL_FUNC) &_raster_do_clamp, 3}, {"_raster_do_edge", (DL_FUNC) &_raster_do_edge, 5}, {"_raster_do_focal_fun", (DL_FUNC) &_raster_do_focal_fun, 5}, {"_raster_do_focal_get", (DL_FUNC) &_raster_do_focal_get, 3}, {"_raster_do_focal_sum", (DL_FUNC) &_raster_do_focal_sum, 6}, {"_raster_getPolygons", (DL_FUNC) &_raster_getPolygons, 3}, {"_raster_layerize", (DL_FUNC) &_raster_layerize, 3}, {"_raster_availableRAM", (DL_FUNC) &_raster_availableRAM, 1}, {"_raster_getMode", (DL_FUNC) &_raster_getMode, 2}, {"_raster_doSpmin", (DL_FUNC) &_raster_doSpmin, 2}, {"_raster_doSpmax", (DL_FUNC) &_raster_doSpmax, 2}, {"_raster_ppmin", (DL_FUNC) &_raster_ppmin, 3}, {"_raster_ppmax", (DL_FUNC) &_raster_ppmax, 3}, {"_raster_doRowMin", (DL_FUNC) &_raster_doRowMin, 2}, {"_raster_doRowMax", (DL_FUNC) &_raster_doRowMax, 2}, {"_raster_aggregate_get", (DL_FUNC) &_raster_aggregate_get, 2}, {"_raster_aggregate_fun", (DL_FUNC) &_raster_aggregate_fun, 4}, {"_raster_get_area_polygon", (DL_FUNC) &_raster_get_area_polygon, 2}, {"_raster_point_distance", (DL_FUNC) &_raster_point_distance, 5}, {"_raster_distanceToNearestPoint", (DL_FUNC) &_raster_distanceToNearestPoint, 5}, {"_raster_directionToNearestPoint", (DL_FUNC) &_raster_directionToNearestPoint, 7}, {"_raster_dest_point", (DL_FUNC) &_raster_dest_point, 4}, {"_raster_reclassify", (DL_FUNC) &_raster_reclassify, 7}, {"_raster_do_terrains", (DL_FUNC) &_raster_do_terrains, 7}, {"_raster_doCellFromXY", (DL_FUNC) &_raster_doCellFromXY, 8}, {"_raster_doXYFromCell", (DL_FUNC) &_raster_doXYFromCell, 7}, {"_raster_doFourCellsFromXY", (DL_FUNC) &_raster_doFourCellsFromXY, 9}, {"_rcpp_module_boot_spmod", (DL_FUNC) &_rcpp_module_boot_spmod, 0}, {NULL, NULL, 0} }; RcppExport void R_init_raster(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } raster/src/util.cpp0000644000176200001440000000105714507510157014032 0ustar liggesusers #ifndef RASTERUTIL_GUARD #define RASTERUTIL_GUARD #include #include "Rmath.h" #ifndef M_PI #define M_PI (3.14159265358979323846) #endif double mod(double x, double n) { return(x - n * floor(x/n)); } double normalizeLonDeg(double lon) { return( mod( (lon + 180), 360 ) - 180 ); } double normalizeLonRad(double lon) { return( mod( (lon + M_PI), M_2PI) - M_PI); } /* Convert degrees to radians */ double toRad(double deg) { return( deg * 0.0174532925199433 ); } double toDeg(double rad) { return( rad * 57.2957795130823 ); } #endif raster/src/focal_fun.cpp0000644000176200001440000000420414507510157015006 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".focal_fun")]] std::vector do_focal_fun(std::vector d, Rcpp::NumericMatrix w, std::vector dim, Rcpp::Function fun, bool naonly) { int nrow = dim[0]; int ncol = dim[1]; int n = nrow * ncol; int wrows = w.nrow(); int wcols = w.ncol(); size_t wn = wrows * wcols; std::vector ans(n); std::vector x; if ((wrows % 2 == 0) | (wcols % 2 == 0)){ Rcpp::Rcerr << "weights matrix must have uneven sides\n"; return(ans); } int wr = wrows / 2; int wc = wcols / 2; wr = std::min(wr, nrow); wc = std::min(wc, ncol); int nwc = ncol - wc - 1; int col = 0; if (naonly) { // first rows for (int i = 0; i < ncol*wr; i++) { ans[i] = d[i]; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { if (!std::isnan(d[i])) { ans[i] = d[i]; } else { col = i % ncol; if ((col < wc) | (col > nwc)) { ans[i] = d[i]; } else { size_t q = 0; x.resize(0); x.reserve(wn); for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { x.push_back( d[j * ncol + k + i] * w[q] ); } q++; } } Rcpp::NumericVector out = fun(x); ans[i] = out[0]; if (std::isnan(ans[i])) { ans[i] = NAN; } } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { ans[i] = d[i]; } } else { // first rows for (int i = 0; i < ncol*wr; i++) { ans[i] = NAN; } for (int i = ncol*wr; i < (ncol * (nrow-wr)); i++) { col = i % ncol; if ((col < wc) | (col > nwc)) { ans[i] = NAN; } else { size_t q = 0; x.resize(0); x.reserve(wn); for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { x.push_back( d[j * ncol + k + i] * w[q] ); } q++; } } Rcpp::NumericVector out = fun(x); ans[i] = out[0]; if (std::isnan(ans[i])) { ans[i] = NAN; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { ans[i] = NAN; } } return(ans); } raster/src/focal_sum.cpp0000644000176200001440000001001214507510157015014 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".focal_sum")]] std::vector do_focal_sum(std::vector d, Rcpp::NumericMatrix w, std::vector dim, bool narm, bool naonly, bool bemean) { int wrows = w.nrow(); int wcols = w.ncol(); int nrow = dim[0]; int ncol = dim[1]; int n = nrow * ncol; std::vector val(n); if ((wrows % 2 == 0) | (wcols % 2 == 0)){ Rcpp::Rcerr << wrows << " " << wcols << "\n"; Rcpp::Rcerr << "weights matrix must have uneven sides\n"; return(val); } int wr = wrows / 2; int wc = wcols / 2; wr = std::min(wr, nrow); wc = std::min(wc, ncol); int nwc = ncol - wc - 1; int col = 0; if (narm) { if (naonly) { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = d[i]; } for (int i = ncol*wr; i < ncol*(nrow-wr); i++) { if (! std::isnan(d[i])) { val[i] = d[i]; } else { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = d[i]; } else { val[i] = 0; size_t q = 0; size_t p = 0; for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { double a = d[j * ncol + k + i]; if ( !std::isnan(a) ) { val[i] += a * w[q]; p++; } q++; } } } if (p==0) { val[i] = NAN; } else if (bemean) { val[i] = val[i] / p; } } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = d[i]; } } else { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = NAN; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = NAN; } else { size_t q = 0; size_t p = 0; val[i] = 0; for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { double a = d[j * ncol + k + i]; if ( !std::isnan(a) ) { val[i] += a * w[q]; p++; } } q++; } } if (p==0) { val[i] = NAN; } else if (bemean) { val[i] = val[i] / p; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = NAN; } } } else { if (naonly) { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = d[i]; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { bool disnan = std::isnan(d[i]); if (!disnan) { val[i] = d[i]; } else { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = NAN; } else { val[i] = 0; size_t q = 0; if (disnan) { for (int j = -wr; j <= wr; j++) { bool jnot0 = j != 0; for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { if (jnot0 && (k != 0)) { val[i] += d[j * ncol + k + i] * w[q]; } q++; } } } } else { for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { val[i] += d[j * ncol + k + i] * w[q]; } q++; } } } if (bemean) { val[i] = val[i] / q; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = d[i]; } } } else { // first rows for (int i = 0; i < ncol*wr; i++) { val[i] = NAN; } for (int i = ncol*wr; i < ncol * (nrow-wr); i++) { col = i % ncol; if ((col < wc) | (col > nwc)) { val[i] = NAN; } else { val[i] = 0; size_t q = 0; for (int j = -wr; j <= wr; j++) { for (int k = -wc; k <= wc; k++) { if (!std::isnan(w[q])) { val[i] += d[j * ncol + k + i] * w[q]; } q++; } } if (bemean) { val[i] = val[i] / q; } } } // last rows for (int i = ncol * (nrow-wr); i < n; i++) { val[i] = NAN; } } } return(val); } raster/src/bilinear.cpp0000644000176200001440000000201014507510157014630 0ustar liggesusers#include using namespace std; using namespace Rcpp; // xy: num[1:n, 1:2] // x: num[1:2, 1:n] // y: num[1:2, 1:n] // v: num[1:n, 1:4] // columns are: bottom-left, top-left, top-right, bottom-right // [[Rcpp::export(name = ".doBilinear")]] NumericVector doBilinear(NumericMatrix xy, NumericMatrix x, NumericMatrix y, NumericMatrix v) { size_t len = v.nrow(); NumericVector result(len); for (size_t i = 0; i < len; i++) { double left = x(0,i); double right = x(1,i); double top = y(1,i); double bottom = y(0,i); double horiz = xy(i,0); double vert = xy(i,1); double denom = (right - left) * (top - bottom); double bottomLeftValue = v(i,0) / denom; double topLeftValue = v(i,1) / denom; double topRightValue = v(i,3) / denom; double bottomRightValue = v(i,2) / denom; result[i] = bottomLeftValue*(right-horiz)*(top-vert) + bottomRightValue*(horiz-left)*(top-vert) + topLeftValue*(right-horiz)*(vert-bottom) + topRightValue*(horiz-left)*(vert-bottom); } return result; } raster/src/util.h0000644000176200001440000000054014507510157013473 0ustar liggesusers/* modulo */ double mod(double x, double n) ; /* Convert degrees to radians */ double toRad(double deg) ; /* Convert radians to degrees */ double toDeg(double rad) ; /* normatlize longitude between -180 .. 180 degrees*/ double normalizeLonDeg(double lon); /* normatlize longitude between -pi .. p1 radians*/ double normalizeLonRad(double lon); raster/src/clamp.cpp0000644000176200001440000000111514507510157014144 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".clamp")]] Rcpp::NumericVector do_clamp(std::vector d, std::vector r, bool usevals) { size_t n = d.size(); Rcpp::NumericVector val(n); if (usevals) { for (size_t i=0; i r[1] ) { val[i] = r[1]; } else { val[i] = d[i]; } } } else { for (size_t i=0; i r[1])) { val[i] = NAN; } else { val[i] = d[i]; } } } return(val); } raster/src/layerize.cpp0000644000176200001440000000074514507510157014704 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".layerize")]] Rcpp::NumericVector layerize(std::vector d, std::vector cls, bool falsena) { int vna = falsena ? R_NaInt : 0; size_t m = d.size(); size_t n = cls.size(); Rcpp::NumericVector v(m * n, vna); for (size_t i=0; i #include #include std::vector get_dims( std::vector dim) { dim.resize(9); for (int i=0; i < 3; i++) { dim[i+6] = std::ceil(dim[i] / double(dim[i+3])); } return(dim); /* // raster dimensions int nr = dim[0], nc = dim[1], nl =dim[2]; // aggregation factors in the three dimensions int dy = dim[3], dx = dim[4], dz = dim[5]; // new dimensions: rows, cols, lays dim[6] = std::ceil(nr / double(dy)); dim[7] = std::ceil(nc / double(dx)); dim[8] = std::ceil(nl / double(dz)); */ } std::vector > get_aggregates(std::vector > data, std::vector dim) { // raster nrow, ncol, nlay int nr = dim[0], nc = dim[1], nl =dim[2]; // nl == data.size(); // data[0].size() == nr * nc == ncell; // aggregation factor in three dimensions int dy = dim[3], dx = dim[4], dz = dim[5]; // blocks per row (=ncol), col (=nrow) int bpC = dim[6], bpR = dim[7]; // blocks per layer int bpL = bpR * bpC; // new number of layers int newNL = dim[8]; // new number of rows, adjusted for additional (expansion) rows int adjnr = bpC * dy; // number of aggregates int nblocks = (bpR * bpC * newNL); // cells per aggregate int blockcells = dx * dy * dz; // output: each row is a block std::vector< std::vector > a(nblocks, std::vector(blockcells, std::numeric_limits::quiet_NaN())); for (int b = 0; b < nblocks; b++) { int lstart = dz * (b / bpL); int rstart = (dy * (b / bpR)) % adjnr; int cstart = dx * (b % bpR); int lmax = std::min(nl, (lstart + dz)); int rmax = std::min(nr, (rstart + dy)); int cmax = std::min(nc, (cstart + dx)); // Rcout << b << ", " << lstart << ", " << rstart << ", " << cstart << "\n"; int f = 0; for (int j = lstart; j < lmax; j++) { for (int r = rstart; r < rmax; r++) { int cell = r * nc; for (int c = cstart; c < cmax; c++) { //Rcout << "cell : " << cell + c << "\n"; a[b][f] = data[cell + c][j]; f++; } } } } return(a); } std::vector > aggregate(std::vector > data, std::vector dim, bool narm, int fun) { // fun = 'sum', 'mean', 'min', 'max' // 0, 1, 2, 3 int mean = 0; if (fun==1) { fun = 0; mean = 1; } // blocks per row (=ncol), col (=nrow) int ncol = dim[6], nrow = dim[7]; // new number of layers int nl = dim[8]; // output: each row is a new cell double NA = std::numeric_limits::quiet_NaN(); std::vector< std::vector > v(nrow*ncol, std::vector(nl, NA)); // get the aggregates std::vector > a = get_aggregates(data, dim); int nblocks = a.size(); int naggs = a[0].size(); // Rcout << nblocks << ", " << naggs << "\n"; for (int i = 0; i < nblocks; i++) { int row = (i / ncol) % nrow; int col = i % ncol; int cell = row * ncol + col; int lyr = std::floor(i / (nrow * ncol)); // Rcout << row << ", " << col << ", " << lyr << "\n"; double x = 0; if (fun==2) { // min x = std::numeric_limits::infinity(); } else if (fun==3) { // max x = - std::numeric_limits::infinity() ; } double cnt = 0; for (int j = 0; j < naggs; j++) { //Rcout << x << ", " << a[i][j] << "\n"; if (std::isnan(a[i][j])) { if (!narm) { x = NA; goto breakout; } } else { if (fun==2) { // min x = std::min(x, a[i][j]); } else if (fun==3) { // max x = std::max(x, a[i][j]); } else { // sum or mean x += a[i][j]; } cnt++; } } if (cnt > 0) { if (mean) { x = x / cnt; } } else { x = NA; } breakout: v[cell][lyr] = x; } return(v); } raster/src/cellRowCol.cpp0000644000176200001440000000156514507510157015126 0ustar liggesusers#include using namespace Rcpp; // [[Rcpp::export(name = ".doCellFromRowCol")]] NumericVector doCellFromRowCol(IntegerVector nrow, IntegerVector ncol, IntegerVector rownr, IntegerVector colnr) { int nr = nrow[0]; int nc = ncol[0]; size_t rownr_size = rownr.size(); size_t colnr_size = colnr.size(); NumericVector result(std::max(rownr_size, colnr_size)); // Manually recycle the shorter of rownr/colnr to match the other size_t len = std::max(rownr.size(), colnr.size()); for (size_t i = 0; i < len; i++) { // The % is to recycle elements if they're not the same length double r = rownr[i < rownr_size ? i : i % rownr_size]; double c = colnr[i < colnr_size ? i : i % colnr_size]; // Detect out-of-bounds rows/cols and use NA for those result[i] = (r<1 || r>nr || c<1 || c>nc) ? NA_REAL : (r-1) * nc + c; } return result; } raster/src/broom.cpp0000644000176200001440000000774014507510157014200 0ustar liggesusers/* Robert Hijmans, October 2011 This is an implementation of J. Ronald Eastman's pushbroom algorithm */ #include #include #define min( a, b ) ( ((a) < (b)) ? (a) : (b) ) // [[Rcpp::export(name = ".broom")]] std::vector broom(std::vector d, std::vector f, std::vector dm, std::vector dist, bool down) { double dx = dist[0]; double dy = dist[1]; double dxy = dist[2]; int leftright = 2; //INTEGER(lr)[0]; size_t nr = dm[0]; size_t nc = dm[1]; size_t n = nr * nc; // Rprintf ("n = %i \n", n); std::vector dis(n); for (size_t i=0; i::infinity(); } if (down) { //left to right //r = 0; first row, no row above it, use 'f' if (leftright >= 1) { //i = 0; first cell, no cell left of it if ( std::isnan(d[0])) { dis[0] = f[0] + dy; } else { dis[0] = 0; } // other cells for (size_t i=1; i 1)) { if ( std::isnan(d[nc-1])) { dis[nc-1] = min(dis[nc-1], f[nc-1] + dy); } else { dis[nc-1] = 0; } // other cells for (int i=(nc-2); i > -1; i--) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], f[i] + dy), f[i+1] + dxy), dis[i+1] + dx); } else { dis[i] = 0; } } // other rows for (size_t r=1; r(r*nc-1); i--) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], dis[i+1] + dx), dis[i-nc] + dy), dis[i-nc+1] + dxy); } else { dis[i] = 0; } } } } } else { // bottom to top // left to right // first (last) row if (leftright >= 1) { size_t r = nr-1; // first cell size_t i = r*nc; if (std::isnan(d[i])) { dis[i] = min(dis[i], f[0] + dy); } else { dis[i] = 0; } // other cells for (size_t i=(r*nc+1); i= 0; r--) { i=r*nc; if (std::isnan(d[i])) { dis[i] = min(dis[i], dis[i+nc] + dy); } else { dis[i] = 0; } for (size_t i=(r*nc+1); i<((r+1)*nc); i++) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], dis[i-1] + dx), dis[i+nc] + dy), dis[i+nc-1] + dxy); } else { dis[i] = 0; } } } } if ((leftright == 0) | (leftright > 1)) { // right to left // first row // first cell if (std::isnan(d[n-1])) { dis[n-1] = min(dis[n-1], f[nc-1] + dy); } else { dis[n-1] = 0; } // other cells size_t r = nr-1; for (size_t i=n-2; i > (r*nc-1); i--) { if (std::isnan(d[i])) { size_t j = i - r*nc; dis[i] = min(min(min(dis[i], f[j] + dx), f[j+1] + dxy), dis[i+1] + dx); } else { dis[i] = 0; } } // other rows for (size_t r=nr-2; r >= 0; r--) { size_t i = (r+1)*nc-1; if (std::isnan(d[i])) { dis[i] = min(dis[i], dis[i+nc] + dy); } else { dis[i] = 0; } for (size_t i=(r+1)*nc-2; i>(r*nc-1); i--) { if (std::isnan(d[i])) { dis[i] = min(min(min(dis[i], dis[i+1] + dx), dis[i+nc] + dy), dis[i+nc+1] + dxy); } else { dis[i] = 0; } } } } } return(dis); } raster/src/memory.h0000644000176200001440000000002714507510157014026 0ustar liggesusersdouble availableRAM(); raster/src/spat.h0000644000176200001440000002140014507510157013463 0ustar liggesusersusing namespace std; #include #include #include #include class SpExtent { public: virtual ~SpExtent(){} double xmin, xmax, ymin, ymax; SpExtent() {xmin = -180; xmax = 180; ymin = -90; ymax = 90;} SpExtent(double _xmin, double _xmax, double _ymin, double _ymax) {xmin = _xmin; xmax = _xmax; ymin = _ymin; ymax = _ymax;} void intersect(SpExtent e) { xmin = std::max(xmin, e.xmin); xmax = std::min(xmax, e.xmax); ymin = std::max(ymin, e.ymin); ymax = std::min(ymax, e.ymax); } std::vector asVector() { std::vector e(4); e[0] = xmin; e[1] = xmax; e[2] = ymin; e[3] = ymax; return(e); } bool valid() { return ((xmax > xmin) && (ymax > ymin)); } }; class SpPolyPart { public: virtual ~SpPolyPart(){} std::vector x, y; std::vector< std::vector> xHole, yHole; SpExtent extent; bool hasHoles() { return xHole.size() > 0;} unsigned nHoles() { return xHole.size();} bool set(std::vector X, std::vector Y) { x = X; y = Y; extent.xmin = *std::min_element(X.begin(), X.end()); extent.xmax = *std::max_element(X.begin(), X.end()); extent.ymin = *std::min_element(Y.begin(), Y.end()); extent.ymax = *std::max_element(Y.begin(), Y.end()); return true; } bool setHole(std::vector X, std::vector Y) { xHole.push_back(X); yHole.push_back(Y); return true; } std::vector getHoleX(unsigned i) { return( xHole[i] ) ; } std::vector getHoleY(unsigned i) { return( yHole[i] ) ; } }; class SpPoly { public: virtual ~SpPoly(){} std::vector parts; SpExtent extent; unsigned size() { return parts.size(); }; SpPolyPart getPart(unsigned i) { return parts[i]; } bool addPart(SpPolyPart p) { parts.push_back(p); if (parts.size() > 1) { extent.xmin = std::min(extent.xmin, p.extent.xmin); extent.xmax = std::max(extent.xmax, p.extent.xmax); extent.ymin = std::min(extent.ymin, p.extent.ymin); extent.ymax = std::max(extent.ymax, p.extent.ymax); } else { extent = p.extent; } return true; } }; class SpPolygons { public: virtual ~SpPolygons(){} std::vector polys; SpExtent extent; std::string crs; std::vector attr; unsigned size() { return polys.size(); }; SpPoly getPoly(unsigned i) { return polys[i]; }; bool addPoly(SpPoly p) { polys.push_back(p); if (polys.size() > 1) { extent.xmin = std::min(extent.xmin, p.extent.xmin); extent.xmax = std::max(extent.xmax, p.extent.xmax); extent.ymin = std::min(extent.ymin, p.extent.ymin); extent.ymax = std::max(extent.ymax, p.extent.ymax); } else { extent = p.extent; } attr.push_back(NAN); return true; } double getAtt(unsigned i) { return attr[i]; }; bool setAtt(unsigned i, double a) { attr[i] = a; return true; }; std::vector rasterize(unsigned nrow, unsigned ncol, std::vector extent, std::vector values, double background); SpPolygons subset(std::vector range) { SpPolygons out; for (size_t i=0; i < range.size(); i++) { out.addPoly( polys[range[i]] ); out.attr.push_back(attr[i]); } out.crs = crs; return out; }; }; class RasterSource { public: virtual ~RasterSource(){} std::vector memory; std::vector filename; std::vector driver; std::vector nlayers; std::vector > layers; std::vector datatype; std::vector NAflag; }; class BlockSize { public: virtual ~BlockSize(){} std::vector row; std::vector nrows; unsigned n; }; class SpRaster { private: std::string msg; fstream* fs; protected: SpExtent extent; std::string crs ="+proj=longlat +datum=WGS84"; void setnlyr() { nlyr = std::accumulate(source.nlayers.begin(), source.nlayers.end(), 0); } BlockSize getBlockSize(); public: virtual ~SpRaster(){} //double NA = std::numeric_limits::quiet_NaN(); RasterSource source; std::vector getnlayers() { return source.nlayers; } unsigned nrow, ncol, nlyr; unsigned size() { return ncol * nrow * nlyr ; } bool hasValues; BlockSize bs; std::vector values; std::vector hasRange; std::vector range_min; std::vector range_max; std::vector names; std::vector inMemory() { return source.memory; } // constructors SpRaster(std::string fname); SpRaster(); SpRaster(std::vector rcl, std::vector ext, std::string _crs); SpRaster(unsigned _nrow, unsigned _ncol, unsigned _nlyr, SpExtent ext, std::string _crs); double ncell() { return nrow * ncol; } // void setExtent(std::vector e) { extent.xmin = e[0]; extent.xmax = e[1]; extent.ymin = e[2]; extent.ymax = e[3]; } SpExtent getExtent() { return extent; } void setExtent(SpExtent e) { extent = e ; } void setExtent(SpExtent ext, bool keepRes=false, std::string snap=""); std::string getCRS() { return(crs); } void setCRS(std::string _crs) { crs = _crs; } std::vector getNames() { if (names.size() < 1) { return std::vector {"layer"}; // rep for each layer } return(names); } void setNames(std::vector _names) { names = _names; } std::vector resolution() { return std::vector { (extent.xmax - extent.xmin) / ncol, (extent.ymax - extent.ymin) / nrow };} double xres() { return (extent.xmax - extent.xmin) / ncol ;} double yres() { return (extent.ymax - extent.ymin) / nrow ;} std::vector origin(); //std::vector filenames() { return source.filename; } bool compare(unsigned nrows, unsigned ncols, SpExtent e ); std::vector getValues(); void setValues(std::vector _values); bool constructFromFile(std::string fname); std::vector cellFromXY (std::vector x, std::vector y); double cellFromXY(double x, double y); std::vector cellFromRowCol(std::vector rownr, std::vector colnr); double cellFromRowCol(unsigned rownr, unsigned colnr); std::vector yFromRow(std::vector rownr); double yFromRow(unsigned rownr); std::vector xFromCol(std::vector colnr); double xFromCol(unsigned colnr); std::vector colFromX(std::vector x); double colFromX(double x); std::vector rowFromY(std::vector y); double rowFromY(double y); std::vector< std::vector > xyFromCell( std::vector cell ); std::vector< std::vector > xyFromCell( double cell ); std::vector< std::vector > rowColFromCell(std::vector cell); double valuesCell(double); double valuesCell(int, int); std::vector valuesCell(std::vector); std::vector valuesRow(int); void setRange(); bool readStart(); bool readStop(); std::vector readValues(unsigned row, unsigned nrows, unsigned col, unsigned ncols); bool writeStart(std::string filename, bool overwrite); bool writeStartFs(std::string filename, bool overwrite, fstream& f); bool writeValues(std::vector vals, unsigned row); bool writeStop(); bool writeHDR(); void openFS(string const &filename); SpRaster writeRaster(std::string filename, bool overwrite); SpExtent align(SpExtent e, string snap="near"); SpRaster test(string filename); SpRaster crop(SpExtent e, string filename="", string snap="near", bool overwrite=false); SpRaster trim(unsigned padding=0, std::string filename="", bool overwrite=false); SpRaster mask(SpRaster mask, string filename="", bool overwrite=false); SpRaster focal(std::vector w, double fillvalue, bool narm, unsigned fun, std::string filename, bool overwrite); SpRaster rasterizePolygons(SpPolygons p, double background, string filename, bool overwrite); std::vector focal_values(std::vector w, double fillvalue, unsigned row, unsigned nrows); SpRaster aggregate(std::vector fact, string fun, bool narm, string filename="", bool overwrite=false); //std::vector aggregate(std::vector fact, bool narm, string fun, string filename=""); std::vector get_aggregate_dims( std::vector fact ); std::vector > get_aggregates(std::vector dim); std::vector sampleRegular(unsigned size, bool cells, bool asRaster); }; /* SpRaster SQRT() { SpRaster r = *this; std::transform(r.values.begin(), r.values.end(), r.values.begin(), (double(*)(double)) sqrt); return r; } SpRaster SQRTfree(SpRaster* g) { SpRaster r = *g; std::transform(r.values.begin(), r.values.end(), r.values.begin(), (double(*)(double)) sqrt); return r; } */ raster/src/geodesic.h0000644000176200001440000011632014507510157014304 0ustar liggesusers/** * \file geodesic.h * \brief API for the geodesic routines in C * * These routines are a simple transcription of the corresponding C++ classes * in GeographicLib. The * "class data" is represented by the structs geod_geodesic, geod_geodesicline, * geod_polygon and pointers to these objects are passed as initial arguments * to the member functions. Most of the internal comments have been retained. * However, in the process of transcription some documentation has been lost * and the documentation for the C++ classes, GeographicLib::Geodesic, * GeographicLib::GeodesicLine, and GeographicLib::PolygonAreaT, should be * consulted. The C++ code remains the "reference implementation". Think * twice about restructuring the internals of the C code since this may make * porting fixes from the C++ code more difficult. * * Copyright (c) Charles Karney (2012-2022) and licensed * under the MIT/X11 License. For more information, see * https://geographiclib.sourceforge.io/ **********************************************************************/ #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 2 /** * The minor version of the geodesic library. (This tracks the version of * GeographicLib.) **********************************************************************/ #define GEODESIC_VERSION_MINOR 0 /** * 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{.c} #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(GEOD_DLL) #if defined(_MSC_VER) && defined(PROJ_MSVC_DLL_EXPORT) #define GEOD_DLL __declspec(dllexport) #elif defined(__GNUC__) #define GEOD_DLL __attribute__ ((visibility("default"))) #else #define GEOD_DLL #endif #endif #if defined(PROJ_RENAME_SYMBOLS) #include "proj_symbol_rename.h" #endif #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(), geod_directline(), geod_gendirectline(), * or geod_inverseline() 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 */ double salp1; /**< sine of \e azi1 */ double calp1; /**< cosine of \e azi1 */ double a13; /**< arc length to reference point */ double s13; /**< distance to reference point */ /**< @cond SKIP */ double b, c2, f1, salp0, calp0, k2, 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_DLL geod_init(struct geod_geodesic* g, double a, double f); /** * 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 from point 1 to 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°]. 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{.c} 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_DLL geod_direct(const struct geod_geodesic* g, double lat1, double lon1, double azi1, 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_UNROLL "unrolls" \e lon2. * @param[in] s12_a12 if \e flags & ::GEOD_ARCMODE is 0, this is the distance * from point 1 to point 2 (meters); otherwise it is the arc length * from point 1 to 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 from point 1 to point 2 * (meters). * @param[out] pm12 pointer to the reduced length of geodesic (meters). * @param[out] pM12 pointer to the geodesic scale of point 2 relative to * point 1 (dimensionless). * @param[out] pM21 pointer to the geodesic scale of point 1 relative to * point 2 (dimensionless). * @param[out] pS12 pointer to the area under the geodesic * (meters2). * @return \e a12 arc length from point 1 to point 2 (degrees). * * \e g must have been initialized with a call to geod_init(). \e lat1 * should be in the range [−90°, 90°]. 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_UNROLL bit set, the longitude is "unrolled" so * that the quantity \e lon2 − \e lon1 indicates how many times and in * what sense the geodesic encircles the ellipsoid. **********************************************************************/ double GEOD_DLL 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); /** * 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 from point 1 to 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°]. 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{.c} 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_DLL geod_inverse(const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, double* ps12, double* pazi1, double* pazi2); /** * 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 from point 1 to point 2 * (meters). * @param[out] pazi1 pointer to the azimuth at point 1 (degrees). * @param[out] pazi2 pointer to the (forward) azimuth at point 2 (degrees). * @param[out] pm12 pointer to the reduced length of geodesic (meters). * @param[out] pM12 pointer to the geodesic scale of point 2 relative to * point 1 (dimensionless). * @param[out] pM21 pointer to the geodesic scale of point 1 relative to * point 2 (dimensionless). * @param[out] pS12 pointer to the area under the geodesic * (meters2). * @return \e a12 arc length from point 1 to 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°]. Any of the * "return" arguments \e ps12, etc., may be replaced by 0, if you do not need * some quantities computed. **********************************************************************/ double GEOD_DLL 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); /** * 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°]. * * The ::geod_mask values are: * - \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). * * When initialized by this function, point 3 is undefined (l->s13 = l->a13 = * NaN). **********************************************************************/ void GEOD_DLL geod_lineinit(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, unsigned caps); /** * Initialize a geod_geodesicline object in terms of the direct geodesic * problem. * * @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] s12 distance from point 1 to point 2 (meters); it can be * negative. * @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(). * * This function sets point 3 of the geod_geodesicline to correspond to point * 2 of the direct geodesic problem. See geod_lineinit() for more * information. **********************************************************************/ void GEOD_DLL geod_directline(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, double s12, unsigned caps); /** * Initialize a geod_geodesicline object in terms of the direct geodesic * problem specified in terms of either distance or arc length. * * @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] flags either ::GEOD_NOFLAGS or ::GEOD_ARCMODE to determining * the meaning of the \e s12_a12. * @param[in] s12_a12 if \e flags = ::GEOD_NOFLAGS, this is the distance * from point 1 to point 2 (meters); if \e flags = ::GEOD_ARCMODE, it is * the arc length from point 1 to point 2 (degrees); it can be * negative. * @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(). * * This function sets point 3 of the geod_geodesicline to correspond to point * 2 of the direct geodesic problem. See geod_lineinit() for more * information. **********************************************************************/ void GEOD_DLL geod_gendirectline(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, unsigned flags, double s12_a12, unsigned caps); /** * Initialize a geod_geodesicline object in terms of the inverse geodesic * problem. * * @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] lat2 latitude of point 2 (degrees). * @param[in] lon2 longitude of point 2 (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(). * * This function sets point 3 of the geod_geodesicline to correspond to point * 2 of the inverse geodesic problem. See geod_lineinit() for more * information. **********************************************************************/ void GEOD_DLL geod_inverseline(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, unsigned caps); /** * 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 from point 1 to 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, e.g., to geod_lineinit(), * with \e caps |= ::GEOD_DISTANCE_IN (or \e caps = 0). 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{.c} 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{.c} struct geod_geodesic g; struct geod_geodesicline l; double lat[101], lon[101]; int i; geod_init(&g, 6378137, 1/298.257223563); geod_inverseline(&l, &g, 40.64, -73.78, 1.36, 103.99, 0); for (i = 0; i <= 100; ++i) { geod_position(&l, i * l.s13 * 0.01, lat + i, lon + i, 0); printf("%.5f %.5f\n", lat[i], lon[i]); } @endcode **********************************************************************/ void GEOD_DLL geod_position(const struct geod_geodesicline* l, double s12, double* plat2, double* plon2, double* pazi2); /** * 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_UNROLL "unrolls" \e lon2; 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 from point 1 to point 2 (meters); otherwise it is the * arc length from point 1 to 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 from point 1 to point 2 * (meters); requires that \e l was initialized with \e caps |= * ::GEOD_DISTANCE. * @param[out] pm12 pointer to the reduced length of geodesic (meters); * requires that \e l was initialized with \e caps |= ::GEOD_REDUCEDLENGTH. * @param[out] pM12 pointer to the geodesic scale of point 2 relative to * point 1 (dimensionless); requires that \e l was initialized with \e caps * |= ::GEOD_GEODESICSCALE. * @param[out] pM21 pointer to the geodesic scale of point 1 relative to * point 2 (dimensionless); requires that \e l was initialized with \e caps * |= ::GEOD_GEODESICSCALE. * @param[out] pS12 pointer to the area under the geodesic * (meters2); requires that \e l was initialized with \e caps |= * ::GEOD_AREA. * @return \e a12 arc length from point 1 to 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_UNROLL bit set, the longitude is "unrolled" so * that the quantity \e lon2 − \e lon1 indicates how many times and in * what sense the geodesic encircles the ellipsoid. * * Example, compute way points between JFK and Singapore Changi Airport using * geod_genposition(). In this example, the points are evenly spaced in arc * length (and so only approximately equally spaced in distance). This is * faster than using geod_position() and would be appropriate if drawing the * path on a map. @code{.c} struct geod_geodesic g; struct geod_geodesicline l; double lat[101], lon[101]; int i; geod_init(&g, 6378137, 1/298.257223563); geod_inverseline(&l, &g, 40.64, -73.78, 1.36, 103.99, GEOD_LATITUDE | GEOD_LONGITUDE); for (i = 0; i <= 100; ++i) { geod_genposition(&l, GEOD_ARCMODE, i * l.a13 * 0.01, lat + i, lon + i, 0, 0, 0, 0, 0, 0); printf("%.5f %.5f\n", lat[i], lon[i]); } @endcode **********************************************************************/ double GEOD_DLL 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); /** * Specify position of point 3 in terms of distance. * * @param[in,out] l a pointer to the geod_geodesicline object. * @param[in] s13 the distance from point 1 to point 3 (meters); it * can be negative. * * This is only useful if the geod_geodesicline object has been constructed * with \e caps |= ::GEOD_DISTANCE_IN. **********************************************************************/ void GEOD_DLL geod_setdistance(struct geod_geodesicline* l, double s13); /** * Specify position of point 3 in terms of either distance or arc length. * * @param[in,out] l a pointer to the geod_geodesicline object. * @param[in] flags either ::GEOD_NOFLAGS or ::GEOD_ARCMODE to determining * the meaning of the \e s13_a13. * @param[in] s13_a13 if \e flags = ::GEOD_NOFLAGS, this is the distance * from point 1 to point 3 (meters); if \e flags = ::GEOD_ARCMODE, it is * the arc length from point 1 to point 3 (degrees); it can be * negative. * * If flags = ::GEOD_NOFLAGS, this calls geod_setdistance(). If flags = * ::GEOD_ARCMODE, the \e s13 is only set if the geod_geodesicline object has * been constructed with \e caps |= ::GEOD_DISTANCE. **********************************************************************/ void GEOD_DLL geod_gensetdistance(struct geod_geodesicline* l, unsigned flags, double s13_a13); /** * 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_DLL geod_polygon_init(struct geod_polygon* p, int polylinep); /** * Clear the polygon, allowing a new polygon to be started. * * @param[in,out] p a pointer to the object to be cleared. **********************************************************************/ void GEOD_DLL geod_polygon_clear(struct geod_polygon* p); /** * 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°]. * * An example of the use of this function is given in the documentation for * geod_polygon_compute(). **********************************************************************/ void GEOD_DLL 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. 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_DLL geod_polygon_addedge(const struct geod_geodesic* g, struct geod_polygon* p, double azi, double s); /** * Return the results for a polygon. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] p a pointer to the geod_polygon object specifying the polygon. * @param[in] reverse if non-zero then clockwise (instead of * counter-clockwise) traversal counts as a positive area. * @param[in] sign if non-zero then return a signed result for the area if * the polygon is traversed in the "wrong" direction instead of returning * the area for the rest of the earth. * @param[out] pA pointer to the area of the polygon (meters2); * only set if \e polyline is non-zero in the call to geod_polygon_init(). * @param[out] pP pointer to the perimeter of the polygon or length of the * polyline (meters). * @return the number of points. * * The area and perimeter are accumulated at two times the standard floating * point precision to guard against the loss of accuracy with many-sided * polygons. Arbitrarily complex polygons are allowed. In the case of * self-intersecting polygons the area is accumulated "algebraically", e.g., * the areas of the 2 loops in a figure-8 polygon will partially cancel. * 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. * * More points can be added to the polygon after this call. * * 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{.c} 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_DLL geod_polygon_compute(const struct geod_geodesic* g, const struct geod_polygon* p, int reverse, int sign, double* pA, double* pP); /** * Return the results assuming a tentative final test point is added; * however, the data for the test point is not saved. This lets you report a * running result for the perimeter and area as the user moves the mouse * cursor. Ordinary floating point arithmetic is used to accumulate the data * for the test point; thus the area and perimeter returned are less accurate * than if geod_polygon_addpoint() and geod_polygon_compute() are used. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] p a pointer to the geod_polygon object specifying the polygon. * @param[in] lat the latitude of the test point (degrees). * @param[in] lon the longitude of the test point (degrees). * @param[in] reverse if non-zero then clockwise (instead of * counter-clockwise) traversal counts as a positive area. * @param[in] sign if non-zero then return a signed result for the area if * the polygon is traversed in the "wrong" direction instead of returning * the area for the rest of the earth. * @param[out] pA pointer to the area of the polygon (meters2); * only set if \e polyline is non-zero in the call to geod_polygon_init(). * @param[out] pP pointer to the perimeter of the polygon or length of the * polyline (meters). * @return the number of points. * * \e lat should be in the range [−90°, 90°]. **********************************************************************/ unsigned GEOD_DLL geod_polygon_testpoint(const struct geod_geodesic* g, const struct geod_polygon* p, double lat, double lon, int reverse, int sign, double* pA, double* pP); /** * Return the results assuming a tentative final test point is added via an * azimuth and distance; however, the data for the test point is not saved. * This lets you report a running result for the perimeter and area as the * user moves the mouse cursor. Ordinary floating point arithmetic is used * to accumulate the data for the test point; thus the area and perimeter * returned are less accurate than if geod_polygon_addedge() and * geod_polygon_compute() are used. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] p a pointer to the geod_polygon object specifying the polygon. * @param[in] azi azimuth at current point (degrees). * @param[in] s distance from current point to final test point (meters). * @param[in] reverse if non-zero then clockwise (instead of * counter-clockwise) traversal counts as a positive area. * @param[in] sign if non-zero then return a signed result for the area if * the polygon is traversed in the "wrong" direction instead of returning * the area for the rest of the earth. * @param[out] pA pointer to the area of the polygon (meters2); * only set if \e polyline is non-zero in the call to geod_polygon_init(). * @param[out] pP pointer to the perimeter of the polygon or length of the * polyline (meters). * @return the number of points. **********************************************************************/ unsigned GEOD_DLL geod_polygon_testedge(const struct geod_geodesic* g, const struct geod_polygon* p, double azi, double s, int reverse, int sign, double* pA, double* pP); /** * A simple interface for computing the area of a geodesic polygon. * * @param[in] g a pointer to the geod_geodesic object specifying the * ellipsoid. * @param[in] lats an array of latitudes of the polygon vertices (degrees). * @param[in] lons an array of longitudes of the polygon vertices (degrees). * @param[in] n the number of vertices. * @param[out] pA pointer to the area of the polygon (meters2). * @param[out] pP pointer to the perimeter of the polygon (meters). * * \e lats should be in the range [−90°, 90°]. * * Arbitrarily complex polygons are allowed. In the case self-intersecting * of polygons the area is accumulated "algebraically", e.g., the areas of * the 2 loops in a figure-8 polygon will partially cancel. 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{.c} 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_DLL 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_UNROLL = 1U<<15 /**< Unroll the longitude */ }; #if defined(__cplusplus) } #endif #endif raster/src/xyCell.cpp0000644000176200001440000001070514507510157014315 0ustar liggesusers#include using namespace Rcpp; //IntegerVector doCellFromXY( // integer can fail in R when .Machine$integer.max < ncell // [[Rcpp::export(name = ".doCellFromXY")]] NumericVector doCellFromXY( int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericVector x, NumericVector y) { size_t len = x.size(); double yres_inv = nrows / (ymax - ymin); double xres_inv = ncols / (xmax - xmin); //IntegerVector result(len); NumericVector result(len); for (size_t i = 0; i < len; i++) { // cannot use trunc here because trunc(-0.1) == 0 double row = floor((ymax - y[i]) * yres_inv); // points in between rows go to the row below // except for the last row, when they must go up if (y[i] == ymin) { row = nrows-1 ; } double col = floor((x[i] - xmin) * xres_inv); // as for rows above. Go right, except for last column if (x[i] == xmax) { col = ncols-1 ; } if (row < 0 || row >= nrows || col < 0 || col >= ncols) { result[i] = NA_REAL; } else { // result[i] = static_cast(row) * ncols + static_cast(col) + 1; result[i] = row * ncols + col + 1 ; } } return result; } // [[Rcpp::export(name = ".doXYFromCell")]] NumericMatrix doXYFromCell( unsigned ncols, unsigned nrows, double xmin, double xmax, double ymin, double ymax, NumericVector cell // IntegerVector cell ) { size_t len = cell.size(); double yres = (ymax - ymin) / nrows; double xres = (xmax - xmin) / ncols; NumericMatrix result(len, 2); for (size_t i = 0; i < len; i++) { // double in stead of int double c = cell[i] - 1; double row = floor(c / ncols); double col = c - row * ncols; result(i,0) = (col + 0.5) * xres + xmin; result(i,1) = ymax - (row + 0.5) * yres; } return result; } double oneBasedRowColToCellNum(int ncols, int row, int col) { return (row-1) * ncols + col; } // [[Rcpp::export(name = ".doFourCellsFromXY")]] NumericMatrix doFourCellsFromXY( int ncols, int nrows, double xmin, double xmax, double ymin, double ymax, NumericMatrix xy, bool duplicates, bool isGlobalLonLat ) { size_t len = xy.nrow(); double yres_inv = nrows / (ymax - ymin); double xres_inv = ncols / (xmax - xmin); NumericMatrix result(len, 4); for (size_t i = 0; i < len; i++) { // 1-based row and col. The 0.5 is because rows/cells are addressed by their // centers, not by their bottom/left edges. double row = (ymax - xy(i,1)) * yres_inv + 0.5; double col = (xy(i,0) - xmin) * xres_inv + 0.5; double roundRow = round(row); double roundCol = round(col); // Check for out-of-bounds. if (roundRow < 1 || roundRow > nrows || roundCol < 1 || roundCol > ncols) { result(i,0) = NA_REAL; result(i,1) = NA_REAL; result(i,2) = NA_REAL; result(i,3) = NA_REAL; continue; } // roundRow and roundCol are now the nearest row/col to x/y. // That gives us one corner. We will find the other corner by starting // at roundRow/roundCol and moving in the direction of row/col, stopping // at the next integral values. // >0 if row is greater than the nearest round row, 0 if equal double vertDir = row - roundRow; // >0 if col is greater than the nearest round col, 0 if equal double horizDir = col - roundCol; // If duplicates are not allowed, make sure vertDir and horizDir // are not 0 if (!duplicates) { if (vertDir == 0) vertDir = 1; if (horizDir == 0) horizDir = 1; } // roundRow and roundCol will be one corner; posRow and posCol will be // the other corner. Start out by moving left/right or up/down relative // to roundRow/roundCol. double posRow = roundRow + (vertDir > 0 ? 1 : vertDir < 0 ? -1 : 0); double posCol = roundCol + (horizDir > 0 ? 1 : horizDir < 0 ? -1 : 0); // Now, some fixups in case posCol/posRow go off the edge of the raster. if (isGlobalLonLat) { if (posCol < 1) { posCol = ncols; } else if (posCol > ncols) { posCol = 1; } } else { if (posCol < 1) { posCol = 2; } else if (posCol > ncols) { posCol = ncols - 1; } } if (posRow < 1) { posRow = 2; } else if (posRow > nrows) { posRow = nrows - 1; } // Fixups done--just store the results. result(i,0) = oneBasedRowColToCellNum(ncols, roundRow, roundCol); result(i,1) = oneBasedRowColToCellNum(ncols, posRow, roundCol); result(i,2) = oneBasedRowColToCellNum(ncols, posRow, posCol); result(i,3) = oneBasedRowColToCellNum(ncols, roundRow, posCol); } return result; } raster/src/rasterize.cpp0000644000176200001440000000473214507510157015070 0ustar liggesusers/* Robert Hijmans, June 2011, July 2016 // Based on public-domain code by Darel Rex Finley, 2007 // http://alienryderflex.com/polygon_fill/ */ #include using namespace Rcpp; using namespace std; #include #include "spat.h" std::vector rasterize_polygon(std::vector r, double value, std::vector pX, std::vector pY, unsigned nrows, unsigned ncols, double xmin, double ymax, double rx, double ry) { unsigned n = pX.size(); std::vector nCol(n); for (size_t row=0; row= y)) || ((pY[j] < y) && (pY[i] >= y))) { double nds = ((pX[i] - xmin + (y-pY[i])/(pY[j]-pY[i]) * (pX[j]-pX[i])) + 0.5 * rx ) / rx; nds = nds < 0 ? 0 : nds; nds = nds > ncols ? ncols : nds; nCol[nodes] = (unsigned) nds; nodes++; } j = i; } std::sort(nCol.begin(), nCol.begin()+nodes); unsigned ncell = ncols * row; // Fill the cells between node pairs. for (size_t i=0; i < nodes; i+=2) { if (nCol[i+1] > 0 && nCol[i] < ncols) { //if (nCol[i] >= ncols || nCol[i+1] <= 0) break; for (size_t col = nCol[i]; col < nCol[i+1]; col++) { r[col + ncell] = value; } } } } return(r); } std::vector SpPolygons::rasterize(unsigned nrow, unsigned ncol, std::vector extent, std::vector values, double background) { unsigned n = size(); std::vector v(nrow*ncol, background); double resx = (extent[1] - extent[0]) / ncol; double resy = (extent[3] - extent[2]) / nrow; for (size_t j = 0; j < n; j++) { SpPoly poly = getPoly(j); double value = values[j]; unsigned np = poly.size(); for (size_t k = 0; k < np; k++) { SpPolyPart part = poly.getPart(k); if (part.hasHoles()) { std::vector vv = rasterize_polygon(v, value, part.x, part.y, nrow, ncol, extent[0], extent[3], resx, resy); for (size_t h=0; h < part.nHoles(); h++) { vv = rasterize_polygon(vv, background, part.xHole[h], part.yHole[h], nrow, ncol, extent[0], extent[3], resx, resy); } for (size_t q=0; q < vv.size(); q++) { if ((vv[q] != background) && (!std::isnan(vv[q]))) { //if (vv[q] != background) { v[q] = vv[q]; } } } else { v = rasterize_polygon(v, value, part.x, part.y, nrow, ncol, extent[0], extent[3], resx, resy); } } } return(v); } raster/src/ppmin.cpp0000644000176200001440000000602514507510157014200 0ustar liggesusers#include using namespace Rcpp; // Simple & fast pmin & pmax with no checking for NA values! // [[Rcpp::export(name = ".doSpmin")]] NumericVector doSpmin(NumericVector x, NumericVector y) { int n = x.length(); // NumericVector out = clone(x); for (int i = 0; i < n; ++i) { if (x[i] > y[i]) { x[i] = y[i]; } } return x; } // [[Rcpp::export(name = ".doSpmax")]] NumericVector doSpmax(NumericVector x, NumericVector y) { int n = x.length(); //NumericVector out = clone(x); for (int i = 0; i < n; ++i) { if (x[i] < y[i]) { x[i] = y[i]; } } return x; } // These functions check for NA, but are not that much faster than pmin // [[Rcpp::export(name = ".ppmin")]] NumericVector ppmin(NumericVector x, NumericVector y, bool narm) { int n = x.length(); //NumericVector out = clone(x); if (narm) { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(x[i])) { x[i] = y[i]; } else if (x[i] > y[i]) { x[i] = y[i]; } } } else { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(y[i])) { x[i] = y[i]; } else if (x[i] > y[i]) { x[i] = y[i]; } } } return x; } // [[Rcpp::export(name = ".ppmax")]] NumericVector ppmax(NumericVector x, NumericVector y, bool narm) { int n = x.length(); //NumericVector out = clone(x); if (narm) { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(x[i])) { x[i] = y[i]; } else if (x[i] < y[i]) { x[i] = y[i]; } } } else { for (int i = 0; i < n; ++i) { if (NumericVector::is_na(y[i])) { x[i] = y[i]; } else if (x[i] < y[i]) { x[i] = y[i]; } } } return x; } // fast rowMin and rowMax // [[Rcpp::export(name = ".doRowMin")]] NumericVector doRowMin(NumericMatrix x, bool narm) { int nrow = x.nrow(), ncol = x.ncol(); NumericVector out(nrow); if (narm) { for (int i = 0; i < nrow; i++) { out[i] = INFINITY; for (int j = 0; j < ncol; j++) { if (x(i,j) < out[i]) { out[i] = x(i,j); } } if (out[i] == INFINITY) { out[i] = NA_REAL; } } } else { for (int i = 0; i < nrow; i++) { out[i] = INFINITY; for (int j = 0; j < ncol; j++) { if (NumericVector::is_na(x(i,j))) { out[i] = NA_REAL; break; } if (x(i,j) < out[i]) { out[i] = x(i,j); } } if (out[i] == INFINITY) { out[i] = NA_REAL; } } } return out; } // [[Rcpp::export(name = ".doRowMax")]] NumericVector doRowMax(NumericMatrix x, bool narm) { int nrow = x.nrow(), ncol = x.ncol(); NumericVector out(nrow); if (narm) { for (int i = 0; i < nrow; i++) { out[i] = -INFINITY; for (int j = 0; j < ncol; j++) { if (x(i,j) > out[i]) { out[i] = x(i,j); } } if (out[i] == -INFINITY) { out[i] = NA_REAL; } } } else { for (int i = 0; i < nrow; i++) { out[i] = -INFINITY; for (int j = 0; j < ncol; j++) { if (NumericVector::is_na(x(i,j))) { out[i] = NA_REAL; break; } if (x(i,j) > out[i]) { out[i] = x(i,j); } } if (out[i] == -INFINITY) { out[i] = NA_REAL; } } } return out; } raster/src/aggregate.h0000644000176200001440000000045314507510157014447 0ustar liggesusersstd::vector get_dims( std::vector dim); std::vector > get_aggregates(std::vector > data, std::vector dim); std::vector > aggregate(std::vector > data, std::vector dim, bool narm, int fun); raster/src/terrain.cpp0000644000176200001440000002354114507510157014523 0ustar liggesusers #include #include "util.h" #include double dmod(double x, double n) { return(x - n * floor(x/n)); } double distPlane(double x1, double y1, double x2, double y2) { return( sqrt(pow((x2-x1),2) + pow((y2-y1), 2)) ); } double distHav(double lon1, double lat1, double lon2, double lat2, double r) { double dLat, dLon, a; lon1 = toRad(lon1); lon2 = toRad(lon2); lat1 = toRad(lat1); lat2 = toRad(lat2); dLat = lat2-lat1; dLon = lon2-lon1; a = sin(dLat/2.) * sin(dLat/2.) + cos(lat1) * cos(lat2) * sin(dLon/2.) * sin(dLon/2.); return 2. * atan2(sqrt(a), sqrt(1.-a)) * r; } // [[Rcpp::export(name = ".terrain")]] std::vector do_terrains(std::vector d, std::vector dim, std::vector res, int unit, std::vector option, bool geo, std::vector gy) { double zy, zx; size_t nrow = dim[0]; size_t ncol = dim[1]; size_t n = nrow * ncol; double dx = res[0]; double dy = res[1]; int nopt = 0; for (size_t i =0; i<8; i++) { nopt += option[i]; } std::vector ddx; if (geo) { double r = 6378137; ddx.resize(nrow); for (size_t i=0; i val(n*nopt); size_t add=0; int addn=0; if (option[0]) { // terrain ruggedness for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i] = (fabs(d[i-1-ncol]-d[i]) + fabs(d[i-1]-d[i]) + fabs(d[i-1+ncol]-d[i]) + fabs(d[i-ncol]-d[i]) + fabs(d[i+ncol]-d[i]) + fabs(d[i+1-ncol]-d[i]) + fabs(d[i+1]-d[i]) + fabs(d[i+1+ncol]-d[i])) / 8; } add++; } if (option[1]) { addn = add * n; // topograhic position for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = d[i] - (d[i-1-ncol] + d[i-1] + d[i-1+ncol] + d[i-ncol] + d[i+ncol] + d[i+1-ncol] + d[i+1] + d[i+1+ncol]) / 8; } add++; } if (option[2]) { // roughness addn = add * n; int incol = ncol; int a[9] = { -1-incol, -1, -1+incol, -incol, 0, incol, 1-incol, 1, 1+incol }; double min, max, v; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { min = d[i + a[0]]; max = d[i + a[0]]; for (size_t j = 1; j < 9; j++) { v = d[i + a[j]]; if (v > max) { max = v; } else if (v < min) { min = v; } } val[i+addn] = max - min; } add++; } if (option[3]) { // slope 4 neighbors addn = add * n; if (geo) { int q; double xwi[2] = {-1,1}; double xw[2] = {0,0}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<2; k++) { xw[k] = xwi[k] / (-2 * ddx[q]); } } zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ) ; } } else { double xw[2] = {-1,1}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { xw[i] = xw[i] / (-2 * dx); yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ); } } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]) * adj; } } else if (unit == 1) { for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]); } } add++; } if (option[4]) { // aspect 4 neighbors addn = add * n; if (geo) { int q; double xwi[2] = {-1,1}; double xw[2] = {0,0}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<2; k++) { xw[k] = xwi[k] / (-2 * ddx[q]); } } zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 - zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } else { double xw[2] = {-1,1}; double yw[2] = {-1,1}; for (size_t i=0; i<2; i++) { xw[i] = xw[i] / (-2 * dx); yw[i] = yw[i] / (2 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1] * xw[0] + d[i+1] * xw[1]; zy = d[i-ncol] * yw[0] + d[i+ncol] * yw[1]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 -zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } add++; } if (option[5]) { // slope 8 neighbors addn = add * n; if (geo) { int q; double xwi[6] = {-1,-2,-1,1,2,1}; double xw[6] = {0,0,0,0,0,0}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { yw[i] = yw[i] / (8 * dy); xw[i] = xwi[i] / (-8 * ddx[1]); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<6; k++) { xw[k] = xwi[k] / (8 * ddx[q]); } } zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ); } } else { double xw[6] = {-1,-2,-1,1,2,1}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { xw[i] = xw[i] / (-8 * dx); yw[i] = yw[i] / (8 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; val[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ); } } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]) * adj; } } else if (unit == 1) { for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = atan(val[i+addn]); } } add++; } if (option[6]) { // aspect 8 neighbors addn = add * n; if (geo) { int q; double xwi[6] = {-1,-2,-1,1,2,1}; double xw[6] = {0,0,0,0,0,0}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { yw[i] = yw[i] / (8 * dy); xw[i] = xwi[i] / (-8 * ddx[1]); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { if (i % ncol == 0) { q = i / ncol; for (size_t k=0; k<6; k++) { xw[k] = xwi[k] / (-8 * ddx[q]); } } zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 -zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } else { double xw[6] = {-1,-2,-1,1,2,1}; double yw[6] = {-1,1,-2,2,-1,1}; for (size_t i=0; i<6; i++) { xw[i] = xw[i] / (-8 * dx); yw[i] = yw[i] / (8 * dy); } for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { zx = d[i-1-ncol] * xw[0] + d[i-1] * xw[1] + d[i-1+ncol] * xw[2] + d[i+1-ncol] * xw[3] + d[i+1] * xw[4] + d[i+1+ncol] * xw[5]; zy = d[i-1-ncol] * yw[0] + d[i-1+ncol] * yw[1] + d[i-ncol] * yw[2] + d[i+ncol] * yw[3] + d[i+1-ncol] * yw[4] + d[i+1+ncol] * yw[5]; zx = atan2(zy, zx); val[i+addn] = dmod( M_PI_2 -zx, M_2PI); } if (unit == 0) { double adj = 180 / M_PI; for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { val[i+addn] = val[i+addn] * adj; } } } add++; } if (option[7]) { // flow direction std::default_random_engine generator(std::random_device{}()); //generator.seed(seed); std::uniform_int_distribution<> distrib(0, 1); //auto gen = std::bind(std::uniform_int_distribution<>(0,1),std::default_random_engine()); addn = add * n; double r[8] = {0,0,0,0,0,0,0,0}; double p[8] = {1,2,4,8,16,32,64,128}; // pow(2, j) double dxy = sqrt(dx * dx + dy * dy); for (size_t i = ncol+1; i < (ncol * (nrow-1)-1); i++) { if (std::isnan(d[i])) { val[i+addn] = NAN; } else { r[0] = (d[i] - d[i+1]) / dx; r[1] = (d[i] - d[i+1+ncol]) / dxy; r[2] = (d[i] - d[i+ncol]) / dy; r[3] = (d[i] - d[i-1+ncol]) / dxy; r[4] = (d[i] - d[i-1]) / dx; r[5] = (d[i] - d[i-1-ncol]) / dxy; r[6] = (d[i] - d[i-ncol]) / dy; r[7] = (d[i] - d[i+1-ncol]) / dxy; // using the lowest neighbor, even if it is higher than the focal cell. double dmin = r[0]; int k = 0; for (size_t j=1; j<8; j++) { if (r[j] > dmin) { dmin = r[j]; k = j; } else if (r[j] == dmin) { bool b = distrib(generator); if (b) { dmin = r[j]; k = j; } } } val[i+addn] = p[k]; } } add++; } // Set edges to NA // first row for (size_t j=0; j // [[Rcpp::export(name = ".reclassify")]] Rcpp::NumericVector reclassify(Rcpp::NumericVector d, Rcpp::NumericMatrix rcl, bool dolowest, bool doright, bool doleftright, bool NAonly, double NAval) { double lowval, lowres; size_t a = rcl.nrow(); size_t nc = rcl.ncol(); size_t b = a * 2; size_t n = d.size(); Rcpp::NumericVector val(n); if (NAonly) { // only change NA values for (size_t i=0; i= rcl[j]) && (d[i] <= rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } else if (doright) { // interval closed at right if (dolowest) { // include lowest value (left) of interval lowval = rcl[0]; lowres = rcl[b]; for (size_t j=1; j rcl[j]) && (d[i] <= rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } else { // !dolowest for (size_t i=0; i rcl[j]) && (d[i] <= rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } } else { // !doright if (dolowest) { // which here means highest because right=FALSE lowval = rcl[a]; lowres = rcl[b]; for (size_t j=a+1; j lowval) { lowval = rcl[j]; lowres = rcl[a+j]; } } for (size_t i=0; i= rcl[j]) && (d[i] < rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } else { //!dolowest for (size_t i=0; i= rcl[j]) && (d[i] < rcl[j+a])) { val[i] = rcl[j+b]; break; } } } } } } } return(val); } raster/src/raster_aggregate.cpp0000644000176200001440000000245614507510157016367 0ustar liggesusers#include #include "aggregate.h" Rcpp::NumericMatrix std2rcp( std::vector > x) { int nr = x.size(), nc = x[0].size() ; Rcpp::NumericMatrix m( nr, nc ) ; for( int i=0; i > rcp2std( Rcpp::NumericMatrix x) { size_t nr = x.nrow(), nc = x.ncol(); std::vector< std::vector > m(nr, std::vector(nc)); for( size_t i=0; i > x = rcp2std(d); std::vector y = Rcpp::as >(dims); y = get_dims(y); x = get_aggregates(x, y); Rcpp::NumericMatrix z = std2rcp(x); return(z); } // [[Rcpp::export(name = ".aggregate_fun")]] Rcpp::NumericMatrix aggregate_fun(Rcpp::NumericMatrix d, Rcpp::NumericVector dims, bool narm, int fun) { std::vector > x = rcp2std(d); std::vector y = Rcpp::as >(dims); y = get_dims(y); x = aggregate(x, y, narm, fun); Rcpp::NumericMatrix z = std2rcp(x); return(z); } raster/src/focal_get.cpp0000644000176200001440000000154714507510157015004 0ustar liggesusers/* Robert Hijmans, October 2011 */ #include // [[Rcpp::export(name = ".focal_get")]] std::vector do_focal_get(std::vector d, std::vector dim, std::vector ngb) { int nrow = dim[0]; int ncol = dim[1]; int wrows = ngb[0]; int wcols = ngb[1]; size_t n = (nrow-wrows+1) * (ncol-wcols+1) * wrows * wcols; std::vector val(n); if ((wrows % 2 == 0) | (wcols % 2 == 0)) { Rcpp::Rcerr << "weights matrix must have uneven sides"; return(val); } int wr = wrows / 2; int wc = wcols / 2; wr = std::min(wr, nrow); wc = std::min(wc, ncol); int f = 0; for (int i = 0+wr; i < nrow-wr; i++) { for (int j = 0+wc; j < ncol-wc; j++) { for (int a=-wr; a <= wr ; a++) { int aa = (i+a) * ncol; for (int b=-wc; b <= wc ; b++) { val[f] = d[aa+j+b]; f++; } } } } return(val); } raster/src/distance.cpp0000644000176200001440000002523314507510157014651 0ustar liggesusers/* Robert Hijmans, June 2011, July 2016 */ #include using namespace Rcpp; using namespace std; #include #include "geodesic.h" #include #include "util.h" double distance_lonlat(double lon1, double lat1, double lon2, double lat2, double a, double f) { double s12, azi1, azi2; struct geod_geodesic g; geod_init(&g, a, f); geod_inverse(&g, lat1, lon1, lat2, lon2, &s12, &azi1, &azi2); return s12; } std::vector distance_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f) { // lonlat1 and lonlat2 should have the same length std::vector r (lon1.size()); double azi1, azi2; struct geod_geodesic g; geod_init(&g, a, f); int n = lat1.size(); for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &r[i], &azi1, &azi2); } return r; } std::vector distanceToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f) { double azi1, azi2, s12; int n = lon1.size(); int m = lon2.size(); std::vector r(n); struct geod_geodesic g; geod_init(&g, a, f); for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[0], lon2[0], &r[i], &azi1, &azi2); for (int j=1; j distance_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2) { // xy1 and xy2 should have the same length std::vector r (x1.size()); int n = x1.size(); for (int i=0; i < n; i++) { r[i] = sqrt(pow((x2[i]-x1[i]),2) + pow((y2[i]-y1[i]), 2)); } return r; } std::vector distanceToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2) { int n = x1.size(); int m = x2.size(); std::vector r(n); double d; for (int i=0; i < n; i++) { r[i] = sqrt(pow((x2[0]-x1[i]),2) + pow((y2[0]-y1[i]), 2)); for (int j=1; j < m; j++) { d = sqrt(pow((x2[j]-x1[i]),2) + pow((y2[j]-y1[i]), 2)); if (d < r[i]) { r[i] = d; } } } return r; } double direction_lonlat(double lon1, double lat1, double lon2, double lat2, bool degrees, double a, double f) { double s12, azi1, azi2; struct geod_geodesic g; geod_init(&g, a, f); geod_inverse(&g, lat1, lon1, lat2, lon2, &s12, &azi1, &azi2); if (!degrees) { return(toRad(azi1)); } return( azi1) ; } std::vector direction_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, double a, double f) { // lonlat1 and lonlat2 should have the same length std::vector azi1(lon1.size()); double s12, azi2; struct geod_geodesic g; geod_init(&g, a, f); int n = lat1.size(); if (degrees) { for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &s12, &azi1[i], &azi2); } } else { for (int i=0; i < n; i++) { geod_inverse(&g, lat1[i], lon1[i], lat2[i], lon2[i], &s12, &azi1[i], &azi2); azi1[i] = toRad(azi1[i]); } } return azi1; } std::vector directionToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, bool from, double a, double f) { double azi1, azi2, s12, dist; int n = lon1.size(); int m = lon2.size(); std::vector azi(n); struct geod_geodesic g; geod_init(&g, a, f); if (from) { for (int i=0; i < n; i++) { geod_inverse(&g, lat2[0], lon2[0], lat1[i], lon1[i], &dist, &azi1, &azi2); azi[i] = azi1; for (int j=1; j direction_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees) { // xy1 and xy2 should have the same length std::vector r (x1.size()); //double a; int n = x1.size(); for (int i=0; i < n; i++) { r[i] = direction_plane(x1[i], y1[i], x2[i], y2[i], degrees); } return r; } std::vector directionToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees, bool from) { int n = x1.size(); int m = x2.size(); std::vector r(n); double d, mind; int minj; if (from) { for (int i = 0; i < n; i++) { mind = distance_plane(x1[i], y1[i], x2[0], y2[0]); minj = 0; for (int j = 1; j < m; j++) { d = distance_plane(x1[i], y1[i], x2[j], y2[j]); if (d < mind) { mind = d; minj = j; } } r[i] = direction_plane(x2[minj], y2[minj], x1[i], y1[i], degrees); } } else { for (int i = 0; i < n; i++) { mind = distance_plane(x1[i], y1[i], x2[0], y2[0]); minj = 0; for (int j = 1; j < m; j++) { d = distance_plane(x1[i], y1[i], x2[j], y2[j]); if (d < mind) { mind = d; minj = j; } } r[i] = direction_plane(x1[i], y1[i], x2[minj], y2[minj], degrees); } } return r; } std::vector destpoint_lonlat(double longitude, double latitude, double bearing, double distance, double a, double f) { struct geod_geodesic g; geod_init(&g, a, f); double lat2, lon2, azi2; geod_direct(&g, latitude, longitude, bearing, distance, &lat2, &lon2, &azi2); std::vector out = {lon2, lat2, azi2 }; return out; } std::vector > destpoint_lonlat(std::vector longitude, std::vector latitude, std::vector bearing, std::vector distance, double a, double f) { struct geod_geodesic g; geod_init(&g, a, f); int n = longitude.size(); std::vector > out; double lat2, lon2, azi2; for (int i=0; i < n; i++) { geod_direct(&g, latitude[i], longitude[i], bearing[i], distance[i], &lat2, &lon2, &azi2); out.push_back( {lon2, lat2, azi2 }); } return out; } std::vector destpoint_plane(double x, double y, double bearing, double distance) { bearing = bearing * M_PI / 180; x += distance * cos(bearing); y += distance * sin(bearing); std::vector out = {x, y}; return(out); } std::vector > destpoint_plane(std::vector x, std::vector y, std::vector bearing, std::vector distance) { int n = x.size(); std::vector > out(n, std::vector(3)); double xd, yd, b; for (int i=0; i < n; i++) { b = bearing[i] * M_PI / 180; xd = x[i] + distance[i] * cos(b); yd = y[i] + distance[i] * sin(b); out.push_back( {xd, yd }); } return(out); } double area_polygon_lonlat(std::vector lon, std::vector lat, double a, double f) { struct geod_geodesic g; struct geod_polygon p; geod_init(&g, a, f); geod_polygon_init(&p, 0); int n = lat.size(); for (int i=0; i < n; i++) { geod_polygon_addpoint(&g, &p, lat[i], lon[i]); } double area, P; geod_polygon_compute(&g, &p, 0, 1, &area, &P); return(area < 0 ? -area : area); } std::vector area_polygon_lonlat(std::vector lon, std::vector lat, std::vector pols, std::vector parts, std::vector holes, double a, double f) { std::vector out; struct geod_geodesic g; struct geod_polygon p; geod_init(&g, a, f); geod_polygon_init(&p, 0); double area, P, pa, tota; int pol = 1; int part = 1; int n = lon.size(); tota = 0; for (int i=0; i < n; i++) { if (parts[i] != part || pols[i] != pol) { geod_polygon_compute(&g, &p, 0, 1, &area, &P); pa = fabs(area); tota += (holes[i-1] > 0 ? -pa : pa); // hole part = parts[i]; if (pols[i] != pol) { out.push_back(tota); tota = 0; pol = pols[i]; } geod_polygon_init(&p, 0); } geod_polygon_addpoint(&g, &p, lat[i], lon[i]); } geod_polygon_compute(&g, &p, 0, 1, &area, &P); pa = fabs(area); tota += (holes[n-1] > 0 ? -pa : pa); // hole out.push_back(tota); return(out); } double area_polygon_plane(std::vector x, std::vector y) { // based on http://paulbourke.net/geometry/polygonmesh/source1.c int n = x.size(); double area = x[n-1] * y[0]; area -= y[n-1] * x[0]; for (int i=0; i < (n-1); i++) { area += x[i] * y[i+1]; area -= x[i+1] * y[i]; } area /= 2; return(area < 0 ? -area : area); } /* std::vector area_polygon_plane(std::vector x, std::vector y, std::vector pols, std::vector parts, std::vector holes) { std::vector out; std::vector px; std::vector py; int pol = 1; int part = 1; int n = x.size(); double tota = 0; double pa; for (int i=0; i < n; i++) { if (parts[i] != part || pols[i] != pol) { pa = area_polygon_plane(px, py); tota += (holes[i-1] > 0 ? -pa : pa); part = parts[i]; if (pols[i] != pol) { out.push_back(tota); tota = 0; pol = pols[i]; } px.resize(0); py.resize(0); } px.push_back(x[i]); py.push_back(y[i]); } pa = area_polygon_plane(px, py); tota += (holes[n-1] > 0 ? -pa : pa); out.push_back(tota); return(out); } */ std::vector area_polygon_plane(std::vector x, std::vector y, std::vector pols, std::vector parts, std::vector holes) { std::vector out; int pol = 1; int part = 1; int n = x.size(); double tota = 0; double pa; int ps = 0; for (int i=0; i < n; i++) { if (parts[i] != part || pols[i] != pol) { pa = area_polygon_plane(std::vector (x.begin() + ps, x.begin() + i - 1), std::vector (y.begin() + ps, y.begin() + i - 1)); tota += (holes[i-1] > 0 ? -pa : pa); part = parts[i]; ps = i; if (pols[i] != pol) { out.push_back(tota); tota = 0; pol = pols[i]; } } } pa = area_polygon_plane(std::vector (x.begin() + ps, x.end()), std::vector (y.begin() + ps, y.end())); tota += (holes[n-1] > 0 ? -pa : pa); out.push_back(tota); return(out); } raster/src/raster_distance.cpp0000644000176200001440000000674114507510157016234 0ustar liggesusers/* Robert Hijmans, October 2011 July 2016 */ #include #include "distance.h" // [[Rcpp::export(name = ".get_area_polygon")]] Rcpp::NumericVector get_area_polygon(Rcpp::NumericMatrix d, bool lonlat) { std::vector pols(d(Rcpp::_,0).begin(), d(Rcpp::_,0).end()); std::vector parts(d(Rcpp::_,1).begin(), d(Rcpp::_,1).end()); std::vector holes(d(Rcpp::_,3).begin(), d(Rcpp::_,3).end()); std::vector x(d(Rcpp::_,4).begin(), d(Rcpp::_,4).end()); std::vector y(d(Rcpp::_,5).begin(), d(Rcpp::_,5).end()); std::vector out; if (lonlat) { // wgs84 double a = 6378137; double f = 1/298.257223563; out = area_polygon_lonlat(x, y, pols, parts, holes, a, f); } else { out = area_polygon_plane(x, y, pols, parts, holes); } Rcpp::NumericVector r( out.begin(), out.end() ); return( r ); } // [[Rcpp::export(name = ".point_distance")]] Rcpp::NumericVector point_distance(Rcpp::NumericMatrix p1, Rcpp::NumericMatrix p2, bool lonlat, double a, double f) { std::vector px1(p1(Rcpp::_,0).begin(), p1(Rcpp::_,0).end()); std::vector py1(p1(Rcpp::_,1).begin(), p1(Rcpp::_,1).end()); std::vector px2(p2(Rcpp::_,0).begin(), p2(Rcpp::_,0).end()); std::vector py2(p2(Rcpp::_,1).begin(), p2(Rcpp::_,1).end()); Rcpp::NumericVector res; if (lonlat) { res = distance_lonlat(px1, py1, px2, py2, a, f); } else { res = distance_plane(px1, py1, px2, py2); } return(res); } // [[Rcpp::export(name = ".distanceToNearestPoint")]] Rcpp::NumericVector distanceToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, double a, double f) { std::vector dx(d(Rcpp::_,0).begin(), d(Rcpp::_,0).end()); std::vector dy(d(Rcpp::_,1).begin(), d(Rcpp::_,1).end()); std::vector px(p(Rcpp::_,0).begin(), p(Rcpp::_,0).end()); std::vector py(p(Rcpp::_,1).begin(), p(Rcpp::_,1).end()); Rcpp::NumericVector res; if (lonlat) { res = distanceToNearest_lonlat(dx, dy, px, py, a, f); } else { res = distanceToNearest_plane(dx, dy, px, py); } return(res) ; } // [[Rcpp::export(name = ".directionToNearestPoint")]] Rcpp::NumericVector directionToNearestPoint(Rcpp::NumericMatrix d, Rcpp::NumericMatrix p, bool lonlat, bool degrees, bool from, double a, double f) { std::vector dx(d(Rcpp::_,0).begin(), d(Rcpp::_,0).end()); std::vector dy(d(Rcpp::_,1).begin(), d(Rcpp::_,1).end()); std::vector px(p(Rcpp::_,0).begin(), p(Rcpp::_,0).end()); std::vector py(p(Rcpp::_,1).begin(), p(Rcpp::_,1).end()); Rcpp::NumericVector res; if (lonlat) { res = directionToNearest_lonlat(dx, dy, px, py, degrees, from, a, f); } else { res = directionToNearest_plane(dx, dy, px, py, degrees, from); } return(res) ; } // [[Rcpp::export(name = ".dest_point")]] Rcpp::NumericMatrix dest_point(Rcpp::NumericMatrix xybd, bool lonlat, double a, double f) { std::vector x(xybd(Rcpp::_,0).begin(), xybd(Rcpp::_,0).end()); std::vector y(xybd(Rcpp::_,1).begin(), xybd(Rcpp::_,1).end()); std::vector b(xybd(Rcpp::_,2).begin(), xybd(Rcpp::_,2).end()); std::vector d(xybd(Rcpp::_,3).begin(), xybd(Rcpp::_,3).end()); std::vector > res; if (lonlat) { res = destpoint_lonlat(x, y, b, d, a, f); } else { res = destpoint_plane(x, y, b, d); } int n = res.size(); int m = res[0].size(); Rcpp::NumericMatrix r(n, m); for (int i=0; i < n; i++) { for (int j=0; j < m; j++) { r(i,j) = res[i][j]; } } return(r); } raster/src/edge.cpp0000644000176200001440000000331114507510157013754 0ustar liggesusers/* Robert Hijmans, November 2011 */ #include // [[Rcpp::export(name = ".edge")]] std::vector do_edge(std::vector d, std::vector dim, bool classes, bool edgetype, unsigned dirs) { bool falseval = 0; size_t nrow = dim[0]; size_t ncol = dim[1]; size_t n = nrow * ncol; std::vector val(n); int r[8] = { -1,0,0,1 , -1,-1,1,1}; int c[8] = { 0,-1,1,0 , -1,1,-1,1}; if (!classes) { if (!edgetype) { // inner for (size_t i = 1; i < (nrow-1); i++) { for (size_t j = 1; j < (ncol-1); j++) { size_t cell = i*ncol+j; val[cell] = NAN; if ( !std::isnan(d[cell])) { val[cell] = falseval; for (size_t k=0; k< dirs; k++) { if ( std::isnan(d[cell + r[k] * ncol + c[k]])) { val[cell] = 1; break; } } } } } } else { //outer for (size_t i = 1; i < (nrow-1); i++) { for (size_t j = 1; j < (ncol-1); j++) { size_t cell = i*ncol+j; val[cell] = falseval; if (std::isnan(d[cell])) { val[cell] = NAN; for (size_t k=0; k < dirs; k++) { if ( !std::isnan(d[cell+ r[k] * ncol + c[k] ])) { val[cell] = 1; break; } } } } } } } else { // by class for (size_t i = 1; i < (nrow-1); i++) { for (size_t j = 1; j < (ncol-1); j++) { size_t cell = i*ncol+j; double test = d[cell+r[0]*ncol+c[0]]; val[cell] = std::isnan(test) ? NAN : falseval; for (size_t k=1; k using namespace Rcpp; // [[Rcpp::export(name = ".getPolygons")]] NumericMatrix getPolygons(NumericMatrix xyv, NumericVector res, int nodes) { int n = xyv.nrow(); double xr = res(0)/2; double yr = res(1)/2; if (nodes == 4) { NumericMatrix cr(n, 10); for (int i = 0; i < n; i++) { cr(i, 0) = xyv(i, 0) - xr; cr(i, 1) = xyv(i, 0) + xr; cr(i, 2) = cr(i, 1); cr(i, 3) = cr(i, 0); cr(i, 4) = cr(i, 0); cr(i, 5) = xyv(i, 1) + yr; cr(i, 6) = cr(i, 5); cr(i, 7) = xyv(i, 1) - yr; cr(i, 8) = cr(i, 7); cr(i, 9) = cr(i, 5); } return cr; } else if (nodes == 8) { NumericMatrix cr(n, 18); for (int i = 0; i < n; i++) { cr(i, 0) = xyv(i, 0) - xr; cr(i, 1) = xyv(i, 0); cr(i, 2) = xyv(i, 0) + xr; cr(i, 3) = cr(i, 2); cr(i, 4) = cr(i, 2); cr(i, 5) = cr(i, 1); cr(i, 6) = cr(i, 0); cr(i, 7) = cr(i, 0); cr(i, 8) = cr(i, 0); cr(i, 9) = xyv(i, 1) + yr; cr(i, 10) = cr(i, 9); cr(i, 11) = cr(i, 9); cr(i, 12) = xyv(i, 1); cr(i, 13) = xyv(i, 1) - yr; cr(i, 14) = cr(i, 13); cr(i, 15) = cr(i, 13); cr(i, 16) = cr(i, 12); cr(i, 17) = cr(i, 9); } return cr; } else { NumericMatrix cr(n, 34); for (int i = 0; i < n; i++) { cr(i, 0) = xyv(i, 0) - xr; cr(i, 1) = xyv(i, 0) - 0.5 * xr; cr(i, 2) = xyv(i, 0); cr(i, 3) = xyv(i, 0) + 0.5 * xr; cr(i, 4) = xyv(i, 0) + xr; cr(i, 5) = cr(i, 4); cr(i, 6) = cr(i, 4); cr(i, 7) = cr(i, 4); cr(i, 8) = cr(i, 4); cr(i, 9) = cr(i, 3); cr(i, 10) = cr(i, 2); cr(i, 11) = cr(i, 1); cr(i, 12) = cr(i, 0); cr(i, 13) = cr(i, 0); cr(i, 14) = cr(i, 0); cr(i, 15) = cr(i, 0); cr(i, 16) = cr(i, 0); cr(i, 17) = xyv(i, 1) + yr; cr(i, 18) = cr(i, 17); cr(i, 19) = cr(i, 17); cr(i, 20) = cr(i, 17); cr(i, 21) = cr(i, 17); cr(i, 22) = xyv(i, 1) + 0.5 * yr; cr(i, 23) = xyv(i, 1); cr(i, 24) = xyv(i, 1) - 0.5 * yr; cr(i, 25) = xyv(i, 1) - yr; cr(i, 26) = cr(i, 25); cr(i, 27) = cr(i, 25); cr(i, 28) = cr(i, 25); cr(i, 29) = cr(i, 25); cr(i, 30) = cr(i, 24); cr(i, 31) = cr(i, 23); cr(i, 32) = cr(i, 22); cr(i, 33) = cr(i, 17); } return cr; } } raster/src/modal.cpp0000644000176200001440000000276114507510157014154 0ustar liggesusers#include using namespace Rcpp; // [[Rcpp::export(name = ".getMode")]] double getMode(NumericVector values, int ties) { int n = values.length(); IntegerVector counts(n); if (ties < 2) { std::sort(values.begin(), values.end()); } for (int i = 0; i < n; ++i) { counts[i] = 0; int j = 0; while ((j < i) && (values[i] != values[j])) { ++j; } ++(counts[j]); } int maxCount = 0; // first (lowest due to sorting) if (ties == 0) { for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; } } // last } else if (ties == 1) { for (int i = 1; i < n; ++i) { if (counts[i] >= counts[maxCount]) { maxCount = i; } } // dont care (first, but not sorted) } else if (ties == 2) { for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; } } // random } else if (ties == 3) { int tieCount = 1; for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; tieCount = 1; } else if (counts[i] == counts[maxCount]) { tieCount++; if (R::runif(0,1) < (1.0 / tieCount)) { maxCount = i; } } } // NA } else { int tieCount = 1; for (int i = 1; i < n; ++i) { if (counts[i] > counts[maxCount]) { maxCount = i; tieCount = 1; } else if (counts[i] == counts[maxCount]) { tieCount++; } } if (tieCount > 1 ) { return(NA_REAL); } } return values[maxCount]; } raster/src/distance.h0000644000176200001440000000534014507510157014313 0ustar liggesusers// distance double distance_plane(double x1, double y1, double x2, double y2); std::vector distance_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2); std::vector distanceToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2); double distance_lonlat(double lon1, double lat1, double lon2, double lat2, double a, double f); std::vector distance_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f) ; std::vector distanceToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, double a, double f); // direction double direction_lonlat(double lon1, double lat1, double lon2, double lat2, bool degrees, double a, double f); std::vector direction_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, double a, double f); std::vector directionToNearest_lonlat(std::vector lon1, std::vector lat1, std::vector lon2, std::vector lat2, bool degrees, bool from, double a, double f); double direction_plane(double x1, double y1, double x2, double y2, bool degrees); std::vector direction_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees); std::vector directionToNearest_plane(std::vector x1, std::vector y1, std::vector x2, std::vector y2, bool degrees, bool from); // destination std::vector destpoint_lonlat(double longitude, double latitude, double bearing, double distance, double a, double f); std::vector > destpoint_lonlat(std::vector longitude, std::vector latitude, std::vector bearing, std::vector distance, double a, double f); std::vector destpoint_plane(double x, double y, double bearing, double distance); std::vector > destpoint_plane(std::vector x, std::vector y, std::vector bearing, std::vector distance); // area double area_polygon_lonlat(std::vector lon, std::vector lat, double a, double f); double area_polygon_plane(std::vector x, std::vector y); std::vector area_polygon_lonlat(std::vector lon, std::vector lat, std::vector pols, std::vector parts, std::vector holes, double a, double f); std::vector area_polygon_plane(std::vector x, std::vector y, std::vector pols, std::vector parts, std::vector holes); raster/src/memory.cpp0000644000176200001440000000407014507510157014363 0ustar liggesusers// Robert Hijmans with improvements by Ben Fasoli // https://github.com/rspatial/raster/pull/175 #ifdef _WIN32 #include #elif __linux__ #include #elif __APPLE__ #include #include #include #include #endif // [[Rcpp::export(name = ".availableRAM")]] double availableRAM(double ram) { // return available RAM #ifdef _WIN32 MEMORYSTATUSEX statex; statex.dwLength = sizeof(statex); GlobalMemoryStatusEx(&statex); ram = statex.ullAvailPhys; #elif __linux__ // source available memory from /proc/meminfo // default to searching for MemAvailable field (kernel versions >= 3.14) FILE *fp = popen("awk '/MemAvailable/ {print $2}' /proc/meminfo", "r"); if (fp == NULL) { return ram; } double ramkb; int ok = fscanf(fp, "%lf", &ramkb); // returned in kB pclose(fp); if (ok && (ramkb > 0)) { return ramkb * 1000.; } // fallback to estimating memory from other fields if MemAvailable not found FILE *fp2 = popen("awk -v low=$(grep low /proc/zoneinfo | awk '{k+=$2}END{print k}') '{a[$1]=$2}END{print a[\"MemFree:\"]+a[\"Active(file):\"]+a[\"Inactive(file):\"]+a[\"SReclaimable:\"]-(12*low);}' /proc/meminfo", "r"); if (fp2 == NULL) { return ram; } ok = fscanf(fp2, "%lf", &ramkb); // returned in kB pclose(fp2); if (ramkb > 0) { return ramkb * 1000.; } #elif __APPLE__ vm_size_t page_size; mach_port_t mach_port; mach_msg_type_number_t count; vm_statistics64_data_t vm_stats; mach_port = mach_host_self(); count = sizeof(vm_stats) / sizeof(natural_t); if (KERN_SUCCESS == host_page_size(mach_port, &page_size) && KERN_SUCCESS == host_statistics64(mach_port, HOST_VM_INFO, (host_info64_t)&vm_stats, &count)) { long long free_memory = ((int64_t)vm_stats.free_count + (int64_t)vm_stats.inactive_count) * (int64_t)page_size; ram = free_memory; //https://stackoverflow.com/questions/63166/how-to-determine-cpu-and-memory-consumption-from-inside-a-process } #endif return ram; } raster/src/geodesic.c0000644000176200001440000021646614507510157014313 0ustar liggesusers/** * \file geodesic.c * \brief Implementation of the geodesic routines in C * * For the full documentation see geodesic.h. **********************************************************************/ /** @cond SKIP */ /* * This is a C implementation of the geodesic algorithms described in * * C. F. F. Karney, * Algorithms for geodesics, * J. Geodesy 87, 43--55 (2013); * https://doi.org/10.1007/s00190-012-0578-z * Addenda: https://geographiclib.sourceforge.io/geod-addenda.html * * See the comments in geodesic.h for documentation. * * Copyright (c) Charles Karney (2012-2022) and licensed * under the MIT/X11 License. For more information, see * https://geographiclib.sourceforge.io/ */ #include "geodesic.h" #include #include #if !defined(__cplusplus) #define nullptr 0 #endif #define GEOGRAPHICLIB_GEODESIC_ORDER 6 #define nA1 GEOGRAPHICLIB_GEODESIC_ORDER #define nC1 GEOGRAPHICLIB_GEODESIC_ORDER #define nC1p GEOGRAPHICLIB_GEODESIC_ORDER #define nA2 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) #define nC (GEOGRAPHICLIB_GEODESIC_ORDER + 1) typedef int boolx; enum booly { FALSE = 0, TRUE = 1 }; /* qd = quarter turn / degree * hd = half turn / degree * td = full turn / degree */ enum dms { qd = 90, hd = 2 * qd, td = 2 * hd }; static unsigned init = 0; static unsigned digits, maxit1, maxit2; static double epsilon, realmin, pi, degree, NaN, tiny, tol0, tol1, tol2, tolb, xthresh; static void Init(void) { if (!init) { digits = DBL_MANT_DIG; epsilon = DBL_EPSILON; realmin = DBL_MIN; #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/hd; NaN = nan("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 double sq(double x) { return x * x; } static double sumx(double u, double v, double* t) { volatile double s = u + v; volatile double up = s - v; volatile double vpp = s - up; up -= u; vpp -= v; if (t) *t = s != 0 ? 0 - (up + vpp) : s; /* error-free sum: * u + v = s + t * = round(u + v) + t */ return s; } static double polyval(int N, const double p[], double x) { double y = N < 0 ? 0 : *p++; while (--N >= 0) y = y * x + *p++; return y; } static void swapx(double* x, double* y) { double t = *x; *x = *y; *y = t; } static void norm2(double* sinx, double* cosx) { #if defined(_MSC_VER) && defined(_M_IX86) /* hypot for Visual Studio (A=win32) fails monotonicity, e.g., with * x = 0.6102683302836215 * y1 = 0.7906090004346522 * y2 = y1 + 1e-16 * the test * hypot(x, y2) >= hypot(x, y1) * fails. See also * https://bugs.python.org/issue43088 */ double r = sqrt(*sinx * *sinx + *cosx * *cosx); #else double r = hypot(*sinx, *cosx); #endif *sinx /= r; *cosx /= r; } static double AngNormalize(double x) { double y = remainder(x, (double)td); return fabs(y) == hd ? copysign((double)hd, x) : y; } static double LatFix(double x) { return fabs(x) > qd ? NaN : x; } static double AngDiff(double x, double y, double* e) { /* Use remainder instead of AngNormalize, since we treat boundary cases * later taking account of the error */ double t, d = sumx(remainder(-x, (double)td), remainder( y, (double)td), &t); /* This second sum can only change d if abs(d) < 128, so don't need to * apply remainder yet again. */ d = sumx(remainder(d, (double)td), t, &t); /* Fix the sign if d = -180, 0, 180. */ if (d == 0 || fabs(d) == hd) /* If t == 0, take sign from y - x * else (t != 0, implies d = +/-180), d and t must have opposite signs */ d = copysign(d, t == 0 ? y - x : -t); if (e) *e = t; return d; } static double AngRound(double x) { /* False positive in cppcheck requires "1.0" instead of "1" */ const double z = 1.0/16.0; volatile double y = fabs(x); volatile double w = z - y; /* The compiler mustn't "simplify" z - (z - y) to y */ y = w > 0 ? z - w : y; return copysign(y, x); } static void sincosdx(double x, double* sinx, double* cosx) { /* In order to minimize round-off errors, this function exactly reduces * the argument to the range [-45, 45] before converting it to radians. */ double r, s, c; int q = 0; r = remquo(x, (double)qd, &q); /* now abs(r) <= 45 */ r *= degree; /* Possibly could call the gnu extension sincos */ s = sin(r); c = cos(r); switch ((unsigned)q & 3U) { case 0U: *sinx = s; *cosx = c; break; case 1U: *sinx = c; *cosx = -s; break; case 2U: *sinx = -s; *cosx = -c; break; default: *sinx = -c; *cosx = s; break; /* case 3U */ } /* http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1950.pdf */ *cosx += 0; /* special values from F.10.1.12 */ /* special values from F.10.1.13 */ if (*sinx == 0) *sinx = copysign(*sinx, x); } static void sincosde(double x, double t, double* sinx, double* cosx) { /* In order to minimize round-off errors, this function exactly reduces * the argument to the range [-45, 45] before converting it to radians. */ double r, s, c; int q = 0; r = AngRound(remquo(x, (double)qd, &q) + t); /* now abs(r) <= 45 */ r *= degree; /* Possibly could call the gnu extension sincos */ s = sin(r); c = cos(r); switch ((unsigned)q & 3U) { case 0U: *sinx = s; *cosx = c; break; case 1U: *sinx = c; *cosx = -s; break; case 2U: *sinx = -s; *cosx = -c; break; default: *sinx = -c; *cosx = s; break; /* case 3U */ } /* http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1950.pdf */ *cosx += 0; /* special values from F.10.1.12 */ /* special values from F.10.1.13 */ if (*sinx == 0) *sinx = copysign(*sinx, x); } static double atan2dx(double y, double x) { /* In order to minimize round-off errors, this function rearranges the * arguments so that result of atan2 is in the range [-pi/4, pi/4] before * converting it to degrees and mapping the result to the correct * quadrant. */ int q = 0; double ang; if (fabs(y) > fabs(x)) { swapx(&x, &y); q = 2; } if (signbit(x)) { x = -x; ++q; } /* here x >= 0 and x >= abs(y), so angle is in [-pi/4, pi/4] */ ang = atan2(y, x) / degree; switch (q) { case 1: ang = copysign((double)hd, y) - ang; break; case 2: ang = qd - ang; break; case 3: ang = -qd + ang; break; default: break; } return ang; } static void A3coeff(struct geod_geodesic* g); static void C3coeff(struct geod_geodesic* g); static void C4coeff(struct geod_geodesic* g); static double SinCosSeries(boolx sinp, double sinx, double cosx, const double c[], int n); static void Lengths(const struct geod_geodesic* g, double eps, double sig12, double ssig1, double csig1, double dn1, double ssig2, double csig2, double dn2, double cbet1, double cbet2, double* ps12b, double* pm12b, double* pm0, double* pM12, double* pM21, /* Scratch area of the right size */ double Ca[]); static double Astroid(double x, double y); static double InverseStart(const struct geod_geodesic* g, double sbet1, double cbet1, double dn1, double sbet2, double cbet2, double dn2, double lam12, double slam12, double clam12, double* psalp1, double* pcalp1, /* Only updated if return val >= 0 */ double* psalp2, double* pcalp2, /* Only updated for short lines */ double* pdnm, /* Scratch area of the right size */ double Ca[]); static double Lambda12(const struct geod_geodesic* g, double sbet1, double cbet1, double dn1, double sbet2, double cbet2, double dn2, double salp1, double calp1, double slam120, double clam120, double* psalp2, double* pcalp2, double* psig12, double* pssig1, double* pcsig1, double* pssig2, double* pcsig2, double* peps, double* pdomg12, boolx diffp, double* pdlam12, /* Scratch area of the right size */ double Ca[]); static double A3f(const struct geod_geodesic* g, double eps); static void C3f(const struct geod_geodesic* g, double eps, double c[]); static void C4f(const struct geod_geodesic* g, double eps, double c[]); static double A1m1f(double eps); static void C1f(double eps, double c[]); static void C1pf(double eps, double c[]); static double A2m1f(double eps); static void C2f(double eps, double c[]); static int transit(double lon1, double lon2); static int transitdirect(double lon1, double lon2); static void accini(double s[]); static void acccopy(const double s[], double t[]); static void accadd(double s[], double y); static double accsum(const double s[], double y); static void accneg(double s[]); static void accrem(double s[], double y); static double areareduceA(double area[], double area0, int crossings, boolx reverse, boolx sign); static double areareduceB(double area, double area0, int crossings, boolx reverse, boolx sign); void geod_init(struct geod_geodesic* g, double a, double f) { if (!init) Init(); g->a = a; g->f = 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 ? atanh(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( fmax(0.001, fabs(g->f)) * fmin(1.0, 1 - g->f/2) / 2 ); A3coeff(g); C3coeff(g); C4coeff(g); } static void geod_lineinit_int(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, double salp1, double calp1, unsigned caps) { double cbet1, sbet1, 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) | /* always allow latitude and azimuth and unrolling of longitude */ GEOD_LATITUDE | GEOD_AZIMUTH | GEOD_LONG_UNROLL; l->lat1 = LatFix(lat1); l->lon1 = lon1; l->azi1 = azi1; l->salp1 = salp1; l->calp1 = calp1; sincosdx(AngRound(l->lat1), &sbet1, &cbet1); sbet1 *= l->f1; /* Ensure cbet1 = +epsilon at poles */ norm2(&sbet1, &cbet1); cbet1 = fmax(tiny, 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 = hypot(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; norm2(&l->ssig1, &l->csig1); /* sig1 in (-pi, pi] */ /* norm2(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) { double 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); } l->a13 = l->s13 = NaN; } void geod_lineinit(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, unsigned caps) { double salp1, calp1; azi1 = AngNormalize(azi1); /* Guard against underflow in salp0 */ sincosdx(AngRound(azi1), &salp1, &calp1); geod_lineinit_int(l, g, lat1, lon1, azi1, salp1, calp1, caps); } void geod_gendirectline(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, unsigned flags, double s12_a12, unsigned caps) { geod_lineinit(l, g, lat1, lon1, azi1, caps); geod_gensetdistance(l, flags, s12_a12); } void geod_directline(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double azi1, double s12, unsigned caps) { geod_gendirectline(l, g, lat1, lon1, azi1, GEOD_NOFLAGS, s12, caps); } 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) { double lat2 = 0, lon2 = 0, azi2 = 0, s12 = 0, m12 = 0, M12 = 0, M21 = 0, S12 = 0; /* Avoid warning about uninitialized B12. */ double sig12, ssig12, csig12, B12 = 0, AB1 = 0; double omg12, lam12, lon12; double ssig2, csig2, sbet2, cbet2, somg2, comg2, salp2, calp2, dn2; unsigned outmask = (plat2 ? GEOD_LATITUDE : GEOD_NONE) | (plon2 ? GEOD_LONGITUDE : GEOD_NONE) | (pazi2 ? GEOD_AZIMUTH : GEOD_NONE) | (ps12 ? GEOD_DISTANCE : GEOD_NONE) | (pm12 ? GEOD_REDUCEDLENGTH : GEOD_NONE) | (pM12 || pM21 ? GEOD_GEODESICSCALE : GEOD_NONE) | (pS12 ? GEOD_AREA : GEOD_NONE); outmask &= l->caps & OUT_ALL; if (!( (flags & GEOD_ARCMODE || (l->caps & (GEOD_DISTANCE_IN & OUT_ALL))) )) /* Impossible distance calculation requested */ return NaN; if (flags & GEOD_ARCMODE) { /* Interpret s12_a12 as spherical arc length */ sig12 = s12_a12 * degree; sincosdx(s12_a12, &ssig12, &csig12); } else { /* Interpret s12_a12 as distance */ double 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 */ double serr; ssig2 = l->ssig1 * csig12 + l->csig1 * ssig12; csig2 = l->csig1 * csig12 - l->ssig1 * ssig12; 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 = hypot(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) { double E = copysign(1, l->salp0); /* east or west going? */ /* tan(omg2) = sin(alp0) * tan(sig2) */ somg2 = l->salp0 * ssig2; comg2 = csig2; /* No need to normalize */ /* omg12 = omg2 - omg1 */ omg12 = (flags & GEOD_LONG_UNROLL) ? E * (sig12 - (atan2( ssig2, csig2) - atan2( l->ssig1, l->csig1)) + (atan2(E * somg2, comg2) - atan2(E * 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; lon2 = (flags & GEOD_LONG_UNROLL) ? l->lon1 + lon12 : AngNormalize(AngNormalize(l->lon1) + AngNormalize(lon12)); } if (outmask & GEOD_LATITUDE) lat2 = atan2dx(sbet2, l->f1 * cbet2); if (outmask & GEOD_AZIMUTH) azi2 = atan2dx(salp2, calp2); if (outmask & (GEOD_REDUCEDLENGTH | GEOD_GEODESICSCALE)) { double 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) { double 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) { double B42 = SinCosSeries(FALSE, ssig2, csig2, l->C4a, nC4); double salp12, calp12; if (l->calp0 == 0 || l->salp0 == 0) { /* alp12 = alp2 - alp1, used in atan2 so no need to normalize */ salp12 = salp2 * l->calp1 - calp2 * l->salp1; calp12 = calp2 * l->calp1 + salp2 * l->salp1; } 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); } /* In the pattern * * if ((outmask & GEOD_XX) && pYY) * *pYY = YY; * * the second check "&& pYY" is redundant. It's there to make the CLang * static analyzer happy. */ if ((outmask & GEOD_LATITUDE) && plat2) *plat2 = lat2; if ((outmask & GEOD_LONGITUDE) && plon2) *plon2 = lon2; if ((outmask & GEOD_AZIMUTH) && pazi2) *pazi2 = azi2; if ((outmask & GEOD_DISTANCE) && ps12) *ps12 = s12; if ((outmask & GEOD_REDUCEDLENGTH) && pm12) *pm12 = m12; if (outmask & GEOD_GEODESICSCALE) { if (pM12) *pM12 = M12; if (pM21) *pM21 = M21; } if ((outmask & GEOD_AREA) && pS12) *pS12 = S12; return (flags & GEOD_ARCMODE) ? s12_a12 : sig12 / degree; } void geod_setdistance(struct geod_geodesicline* l, double s13) { l->s13 = s13; l->a13 = geod_genposition(l, GEOD_NOFLAGS, l->s13, nullptr, nullptr, nullptr, nullptr, nullptr, nullptr, nullptr, nullptr); } static void geod_setarc(struct geod_geodesicline* l, double a13) { l->a13 = a13; l->s13 = NaN; geod_genposition(l, GEOD_ARCMODE, l->a13, nullptr, nullptr, nullptr, &l->s13, nullptr, nullptr, nullptr, nullptr); } void geod_gensetdistance(struct geod_geodesicline* l, unsigned flags, double s13_a13) { (flags & GEOD_ARCMODE) ? geod_setarc(l, s13_a13) : geod_setdistance(l, s13_a13); } void geod_position(const struct geod_geodesicline* l, double s12, double* plat2, double* plon2, double* pazi2) { geod_genposition(l, FALSE, s12, plat2, plon2, pazi2, nullptr, nullptr, nullptr, nullptr, nullptr); } 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) { struct geod_geodesicline l; unsigned outmask = (plat2 ? GEOD_LATITUDE : GEOD_NONE) | (plon2 ? GEOD_LONGITUDE : GEOD_NONE) | (pazi2 ? GEOD_AZIMUTH : GEOD_NONE) | (ps12 ? GEOD_DISTANCE : GEOD_NONE) | (pm12 ? GEOD_REDUCEDLENGTH : GEOD_NONE) | (pM12 || pM21 ? GEOD_GEODESICSCALE : GEOD_NONE) | (pS12 ? GEOD_AREA : GEOD_NONE); 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, double lat1, double lon1, double azi1, double s12, double* plat2, double* plon2, double* pazi2) { geod_gendirect(g, lat1, lon1, azi1, GEOD_NOFLAGS, s12, plat2, plon2, pazi2, nullptr, nullptr, nullptr, nullptr, nullptr); } static double geod_geninverse_int(const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, double* ps12, double* psalp1, double* pcalp1, double* psalp2, double* pcalp2, double* pm12, double* pM12, double* pM21, double* pS12) { double s12 = 0, m12 = 0, M12 = 0, M21 = 0, S12 = 0; double lon12, lon12s; int latsign, lonsign, swapp; double sbet1, cbet1, sbet2, cbet2, s12x = 0, m12x = 0; double dn1, dn2, lam12, slam12, clam12; double a12 = 0, sig12, calp1 = 0, salp1 = 0, calp2 = 0, salp2 = 0; double Ca[nC]; boolx meridian; /* somg12 == 2 marks that it needs to be calculated */ double omg12 = 0, somg12 = 2, comg12 = 0; unsigned outmask = (ps12 ? GEOD_DISTANCE : GEOD_NONE) | (pm12 ? GEOD_REDUCEDLENGTH : GEOD_NONE) | (pM12 || pM21 ? GEOD_GEODESICSCALE : GEOD_NONE) | (pS12 ? GEOD_AREA : GEOD_NONE); 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(lon1, lon2, &lon12s); /* Make longitude difference positive. */ lonsign = signbit(lon12) ? -1 : 1; lon12 *= lonsign; lon12s *= lonsign; lam12 = lon12 * degree; /* Calculate sincos of lon12 + error (this applies AngRound internally). */ sincosde(lon12, lon12s, &slam12, &clam12); lon12s = (hd - lon12) - lon12s; /* the supplementary longitude difference */ /* If really close to the equator, treat as on equator. */ lat1 = AngRound(LatFix(lat1)); lat2 = AngRound(LatFix(lat2)); /* Swap points so that point with higher (abs) latitude is point 1 * If one latitude is a nan, then it becomes lat1. */ swapp = fabs(lat1) < fabs(lat2) || lat2 != lat2 ? -1 : 1; if (swapp < 0) { lonsign *= -1; swapx(&lat1, &lat2); } /* Make lat1 <= -0 */ latsign = signbit(lat1) ? 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. */ sincosdx(lat1, &sbet1, &cbet1); sbet1 *= g->f1; /* Ensure cbet1 = +epsilon at poles */ norm2(&sbet1, &cbet1); cbet1 = fmax(tiny, cbet1); sincosdx(lat2, &sbet2, &cbet2); sbet2 *= g->f1; /* Ensure cbet2 = +epsilon at poles */ norm2(&sbet2, &cbet2); cbet2 = fmax(tiny, 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 = copysign(sbet1, sbet2); } else { if (fabs(sbet2) == -sbet1) cbet2 = cbet1; } dn1 = sqrt(1 + g->ep2 * sq(sbet1)); dn2 = sqrt(1 + g->ep2 * sq(sbet2)); meridian = lat1 == -qd || slam12 == 0; if (meridian) { /* Endpoints are on a single full meridian, so the geodesic might lie on * a meridian. */ double 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(fmax(0.0, csig1 * ssig2 - ssig1 * csig2) + 0, csig1 * csig2 + ssig1 * ssig2); Lengths(g, g->n, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2, cbet1, cbet2, &s12x, &m12x, nullptr, (outmask & GEOD_GEODESICSCALE) ? &M12 : nullptr, (outmask & GEOD_GEODESICSCALE) ? &M21 : nullptr, Ca); /* 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) { /* Need at least 2, to handle 90 0 90 180 */ if (sig12 < 3 * tiny || /* Prevent negative s12 or m12 for short lines */ (sig12 < tol0 && (s12x < 0 || m12x < 0))) sig12 = m12x = s12x = 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 || lon12s >= g->f * hd)) { /* 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 */ double dnm = 0; sig12 = InverseStart(g, sbet1, cbet1, dn1, sbet2, cbet2, dn2, lam12, slam12, clam12, &salp1, &calp1, &salp2, &calp2, &dnm, Ca); 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. */ double ssig1 = 0, csig1 = 0, ssig2 = 0, csig2 = 0, eps = 0, domg12 = 0; unsigned numit = 0; /* Bracketing range */ double salp1a = tiny, calp1a = 1, salp1b = tiny, calp1b = -1; boolx tripn = FALSE; boolx tripb = FALSE; for (; 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 */ double dv = 0, v = Lambda12(g, sbet1, cbet1, dn1, sbet2, cbet2, dn2, salp1, calp1, slam12, clam12, &salp2, &calp2, &sig12, &ssig1, &csig1, &ssig2, &csig2, &eps, &domg12, numit < maxit1, &dv, Ca); /* Reversed test to allow escape with NaNs */ if (tripb || !(fabs(v) >= (tripn ? 8 : 1) * 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) { double dalp1 = -v/dv; double sdalp1 = sin(dalp1), cdalp1 = cos(dalp1), nsalp1 = salp1 * cdalp1 + calp1 * sdalp1; if (nsalp1 > 0 && fabs(dalp1) < pi) { calp1 = calp1 * cdalp1 - salp1 * sdalp1; salp1 = nsalp1; norm2(&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 positive 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; norm2(&salp1, &calp1); tripn = FALSE; tripb = (fabs(salp1a - salp1) + (calp1a - calp1) < tolb || fabs(salp1 - salp1b) + (calp1 - calp1b) < tolb); } Lengths(g, eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2, cbet1, cbet2, &s12x, &m12x, nullptr, (outmask & GEOD_GEODESICSCALE) ? &M12 : nullptr, (outmask & GEOD_GEODESICSCALE) ? &M21 : nullptr, Ca); m12x *= g->b; s12x *= g->b; a12 = sig12 / degree; if (outmask & GEOD_AREA) { /* omg12 = lam12 - domg12 */ double sdomg12 = sin(domg12), cdomg12 = cos(domg12); somg12 = slam12 * cdomg12 - clam12 * sdomg12; comg12 = clam12 * cdomg12 + slam12 * sdomg12; } } } 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) { double /* From Lambda12: sin(alp1) * cos(bet1) = sin(alp0) */ salp0 = salp1 * cbet1, calp0 = hypot(calp1, salp1 * sbet1); /* calp0 > 0 */ double alp12; if (calp0 != 0 && salp0 != 0) { double /* 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; double B41, B42; norm2(&ssig1, &csig1); norm2(&ssig2, &csig2); C4f(g, eps, Ca); B41 = SinCosSeries(FALSE, ssig1, csig1, Ca, nC4); B42 = SinCosSeries(FALSE, ssig2, csig2, Ca, nC4); S12 = A4 * (B42 - B41); } else /* Avoid problems with indeterminate sig1, sig2 on equator */ S12 = 0; if (!meridian && somg12 == 2) { somg12 = sin(omg12); comg12 = cos(omg12); } if (!meridian && /* omg12 < 3/4 * pi */ comg12 > -0.7071 && /* Long difference not too big */ sbet2 - sbet1 < 1.75) { /* Lat difference not 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)) */ double domg12 = 1 + comg12, 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 */ double 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 (psalp1) *psalp1 = salp1; if (pcalp1) *pcalp1 = calp1; if (psalp2) *psalp2 = salp2; if (pcalp2) *pcalp2 = calp2; 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; /* Returned value in [0, 180] */ return a12; } 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) { double salp1, calp1, salp2, calp2, a12 = geod_geninverse_int(g, lat1, lon1, lat2, lon2, ps12, &salp1, &calp1, &salp2, &calp2, pm12, pM12, pM21, pS12); if (pazi1) *pazi1 = atan2dx(salp1, calp1); if (pazi2) *pazi2 = atan2dx(salp2, calp2); return a12; } void geod_inverseline(struct geod_geodesicline* l, const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, unsigned caps) { double salp1, calp1, a12 = geod_geninverse_int(g, lat1, lon1, lat2, lon2, nullptr, &salp1, &calp1, nullptr, nullptr, nullptr, nullptr, nullptr, nullptr), azi1 = atan2dx(salp1, calp1); caps = caps ? caps : GEOD_DISTANCE_IN | GEOD_LONGITUDE; /* Ensure that a12 can be converted to a distance */ if (caps & (OUT_ALL & GEOD_DISTANCE_IN)) caps |= GEOD_DISTANCE; geod_lineinit_int(l, g, lat1, lon1, azi1, salp1, calp1, caps); geod_setarc(l, a12); } void geod_inverse(const struct geod_geodesic* g, double lat1, double lon1, double lat2, double lon2, double* ps12, double* pazi1, double* pazi2) { geod_geninverse(g, lat1, lon1, lat2, lon2, ps12, pazi1, pazi2, nullptr, nullptr, nullptr, nullptr); } double SinCosSeries(boolx sinp, double sinx, double cosx, const double 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 */ double 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, double eps, double sig12, double ssig1, double csig1, double dn1, double ssig2, double csig2, double dn2, double cbet1, double cbet2, double* ps12b, double* pm12b, double* pm0, double* pM12, double* pM21, /* Scratch area of the right size */ double Ca[]) { double m0 = 0, J12 = 0, A1 = 0, A2 = 0; double Cb[nC]; /* Return m12b = (reduced length)/b; also calculate s12b = distance/b, * and m0 = coefficient of secular term in expression for reduced length. */ boolx redlp = pm12b || pm0 || pM12 || pM21; if (ps12b || redlp) { A1 = A1m1f(eps); C1f(eps, Ca); if (redlp) { A2 = A2m1f(eps); C2f(eps, Cb); m0 = A1 - A2; A2 = 1 + A2; } A1 = 1 + A1; } if (ps12b) { double B1 = SinCosSeries(TRUE, ssig2, csig2, Ca, nC1) - SinCosSeries(TRUE, ssig1, csig1, Ca, nC1); /* Missing a factor of b */ *ps12b = A1 * (sig12 + B1); if (redlp) { double B2 = SinCosSeries(TRUE, ssig2, csig2, Cb, nC2) - SinCosSeries(TRUE, ssig1, csig1, Cb, nC2); J12 = m0 * sig12 + (A1 * B1 - A2 * B2); } } else if (redlp) { /* Assume here that nC1 >= nC2 */ int l; for (l = 1; l <= nC2; ++l) Cb[l] = A1 * Ca[l] - A2 * Cb[l]; J12 = m0 * sig12 + (SinCosSeries(TRUE, ssig2, csig2, Cb, nC2) - SinCosSeries(TRUE, ssig1, csig1, Cb, nC2)); } if (pm0) *pm0 = m0; if (pm12b) /* Missing a factor of b. * Add parens around (csig1 * ssig2) and (ssig1 * csig2) to ensure * accurate cancellation in the case of coincident points. */ *pm12b = dn2 * (csig1 * ssig2) - dn1 * (ssig1 * csig2) - csig1 * csig2 * J12; if (pM12 || pM21) { double csig12 = csig1 * csig2 + ssig1 * ssig2; double t = g->ep2 * (cbet1 - cbet2) * (cbet1 + cbet2) / (dn1 + dn2); if (pM12) *pM12 = csig12 + (t * ssig2 - csig2 * J12) * ssig1 / dn1; if (pM21) *pM21 = csig12 - (t * ssig1 - csig1 * J12) * ssig2 / dn2; } } double Astroid(double x, double 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. */ double k; double p = sq(x), q = sq(y), r = (p + q - 1) / 6; if ( !(q == 0 && r <= 0) ) { double /* 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 discriminant 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); double u = r; double v, uv, w; if (disc >= 0) { double 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. cbrt always returns the double root. cbrt(-8) = -2. */ T = cbrt(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 double. */ double 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; } double InverseStart(const struct geod_geodesic* g, double sbet1, double cbet1, double dn1, double sbet2, double cbet2, double dn2, double lam12, double slam12, double clam12, double* psalp1, double* pcalp1, /* Only updated if return val >= 0 */ double* psalp2, double* pcalp2, /* Only updated for short lines */ double* pdnm, /* Scratch area of the right size */ double Ca[]) { double 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. */ double 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; double sbet12a; boolx shortline = cbet12 >= 0 && sbet12 < 0.5 && cbet2 * lam12 < 0.5; double somg12, comg12, ssig12, csig12; sbet12a = sbet2 * cbet1 + cbet2 * sbet1; if (shortline) { double sbetm2 = sq(sbet1 + sbet2), omg12; /* 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 = lam12 / (g->f1 * dnm); somg12 = sin(omg12); comg12 = cos(omg12); } else { somg12 = slam12; comg12 = clam12; } salp1 = cbet2 * somg12; calp1 = comg12 >= 0 ? sbet12 + cbet2 * sbet1 * sq(somg12) / (1 + comg12) : sbet12a - cbet2 * sbet1 * sq(somg12) / (1 - comg12); ssig12 = hypot(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); norm2(&salp2, &calp2); /* Set return value */ sig12 = atan2(ssig12, csig12); } else if (fabs(g->n) > 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. */ double x, y, lamscale, betscale; double lam12x = atan2(-slam12, -clam12); /* lam12 - pi */ if (g->f >= 0) { /* In fact f == 0 does not get here */ /* x = dlong, y = dlat */ { double 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 = lam12x / lamscale; y = sbet12a / betscale; } else { /* f < 0 */ /* x = dlat, y = dlong */ double cbet12a = cbet2 * cbet1 - sbet2 * sbet1, bet12a = atan2(sbet12a, cbet12a); double m12b, m0; /* 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, nullptr, &m12b, &m0, nullptr, nullptr, Ca); x = -1 + m12b / (cbet1 * cbet2 * m0 * pi); betscale = x < -0.01 ? sbet12a / x : -g->f * sq(cbet1) * pi; lamscale = betscale / cbet1; y = lam12x / lamscale; } if (y > -tol1 && x > -1 - xthresh) { /* strip near cut */ if (g->f >= 0) { salp1 = fmin(1.0, -x); calp1 = - sqrt(1 - sq(salp1)); } else { calp1 = fmax(x > -tol1 ? 0.0 : -1.0, 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 */ double k = Astroid(x, y); double 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)) norm2(&salp1, &calp1); else { salp1 = 1; calp1 = 0; } *psalp1 = salp1; *pcalp1 = calp1; if (shortline) *pdnm = dnm; if (sig12 >= 0) { *psalp2 = salp2; *pcalp2 = calp2; } return sig12; } double Lambda12(const struct geod_geodesic* g, double sbet1, double cbet1, double dn1, double sbet2, double cbet2, double dn2, double salp1, double calp1, double slam120, double clam120, double* psalp2, double* pcalp2, double* psig12, double* pssig1, double* pcsig1, double* pssig2, double* pcsig2, double* peps, double* pdomg12, boolx diffp, double* pdlam12, /* Scratch area of the right size */ double Ca[]) { double salp2 = 0, calp2 = 0, sig12 = 0, ssig1 = 0, csig1 = 0, ssig2 = 0, csig2 = 0, eps = 0, domg12 = 0, dlam12 = 0; double salp0, calp0; double somg1, comg1, somg2, comg2, somg12, comg12, lam12; double B312, eta, 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 = hypot(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; norm2(&ssig1, &csig1); /* norm2(&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; norm2(&ssig2, &csig2); /* norm2(&somg2, &comg2); -- don't need to normalize! */ /* sig12 = sig2 - sig1, limit to [0, pi] */ sig12 = atan2(fmax(0.0, csig1 * ssig2 - ssig1 * csig2) + 0, csig1 * csig2 + ssig1 * ssig2); /* omg12 = omg2 - omg1, limit to [0, pi] */ somg12 = fmax(0.0, comg1 * somg2 - somg1 * comg2) + 0; comg12 = comg1 * comg2 + somg1 * somg2; /* eta = omg12 - lam120 */ eta = atan2(somg12 * clam120 - comg12 * slam120, comg12 * clam120 + somg12 * slam120); k2 = sq(calp0) * g->ep2; eps = k2 / (2 * (1 + sqrt(1 + k2)) + k2); C3f(g, eps, Ca); B312 = (SinCosSeries(TRUE, ssig2, csig2, Ca, nC3-1) - SinCosSeries(TRUE, ssig1, csig1, Ca, nC3-1)); domg12 = -g->f * A3f(g, eps) * salp0 * (sig12 + B312); lam12 = eta + domg12; if (diffp) { if (calp2 == 0) dlam12 = - 2 * g->f1 * dn1 / sbet1; else { Lengths(g, eps, sig12, ssig1, csig1, dn1, ssig2, csig2, dn2, cbet1, cbet2, nullptr, &dlam12, nullptr, nullptr, nullptr, Ca); 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; } double A3f(const struct geod_geodesic* g, double eps) { /* Evaluate A3 */ return polyval(nA3 - 1, g->A3x, eps); } void C3f(const struct geod_geodesic* g, double eps, double c[]) { /* Evaluate C3 coeffs * Elements c[1] through c[nC3 - 1] are set */ double mult = 1; int o = 0, l; for (l = 1; l < nC3; ++l) { /* l is index of C3[l] */ int m = nC3 - l - 1; /* order of polynomial in eps */ mult *= eps; c[l] = mult * polyval(m, g->C3x + o, eps); o += m + 1; } } void C4f(const struct geod_geodesic* g, double eps, double c[]) { /* Evaluate C4 coeffs * Elements c[0] through c[nC4 - 1] are set */ double mult = 1; int o = 0, l; for (l = 0; l < nC4; ++l) { /* l is index of C4[l] */ int m = nC4 - l - 1; /* order of polynomial in eps */ c[l] = mult * polyval(m, g->C4x + o, eps); o += m + 1; mult *= eps; } } /* The scale factor A1-1 = mean value of (d/dsigma)I1 - 1 */ double A1m1f(double eps) { static const double coeff[] = { /* (1-eps)*A1-1, polynomial in eps2 of order 3 */ 1, 4, 64, 0, 256, }; int m = nA1/2; double t = polyval(m, coeff, sq(eps)) / coeff[m + 1]; return (t + eps) / (1 - eps); } /* The coefficients C1[l] in the Fourier expansion of B1 */ void C1f(double eps, double c[]) { static const double coeff[] = { /* C1[1]/eps^1, polynomial in eps2 of order 2 */ -1, 6, -16, 32, /* C1[2]/eps^2, polynomial in eps2 of order 2 */ -9, 64, -128, 2048, /* C1[3]/eps^3, polynomial in eps2 of order 1 */ 9, -16, 768, /* C1[4]/eps^4, polynomial in eps2 of order 1 */ 3, -5, 512, /* C1[5]/eps^5, polynomial in eps2 of order 0 */ -7, 1280, /* C1[6]/eps^6, polynomial in eps2 of order 0 */ -7, 2048, }; double eps2 = sq(eps), d = eps; int o = 0, l; for (l = 1; l <= nC1; ++l) { /* l is index of C1p[l] */ int m = (nC1 - l) / 2; /* order of polynomial in eps^2 */ c[l] = d * polyval(m, coeff + o, eps2) / coeff[o + m + 1]; o += m + 2; d *= eps; } } /* The coefficients C1p[l] in the Fourier expansion of B1p */ void C1pf(double eps, double c[]) { static const double coeff[] = { /* C1p[1]/eps^1, polynomial in eps2 of order 2 */ 205, -432, 768, 1536, /* C1p[2]/eps^2, polynomial in eps2 of order 2 */ 4005, -4736, 3840, 12288, /* C1p[3]/eps^3, polynomial in eps2 of order 1 */ -225, 116, 384, /* C1p[4]/eps^4, polynomial in eps2 of order 1 */ -7173, 2695, 7680, /* C1p[5]/eps^5, polynomial in eps2 of order 0 */ 3467, 7680, /* C1p[6]/eps^6, polynomial in eps2 of order 0 */ 38081, 61440, }; double eps2 = sq(eps), d = eps; int o = 0, l; for (l = 1; l <= nC1p; ++l) { /* l is index of C1p[l] */ int m = (nC1p - l) / 2; /* order of polynomial in eps^2 */ c[l] = d * polyval(m, coeff + o, eps2) / coeff[o + m + 1]; o += m + 2; d *= eps; } } /* The scale factor A2-1 = mean value of (d/dsigma)I2 - 1 */ double A2m1f(double eps) { static const double coeff[] = { /* (eps+1)*A2-1, polynomial in eps2 of order 3 */ -11, -28, -192, 0, 256, }; int m = nA2/2; double t = polyval(m, coeff, sq(eps)) / coeff[m + 1]; return (t - eps) / (1 + eps); } /* The coefficients C2[l] in the Fourier expansion of B2 */ void C2f(double eps, double c[]) { static const double coeff[] = { /* C2[1]/eps^1, polynomial in eps2 of order 2 */ 1, 2, 16, 32, /* C2[2]/eps^2, polynomial in eps2 of order 2 */ 35, 64, 384, 2048, /* C2[3]/eps^3, polynomial in eps2 of order 1 */ 15, 80, 768, /* C2[4]/eps^4, polynomial in eps2 of order 1 */ 7, 35, 512, /* C2[5]/eps^5, polynomial in eps2 of order 0 */ 63, 1280, /* C2[6]/eps^6, polynomial in eps2 of order 0 */ 77, 2048, }; double eps2 = sq(eps), d = eps; int o = 0, l; for (l = 1; l <= nC2; ++l) { /* l is index of C2[l] */ int m = (nC2 - l) / 2; /* order of polynomial in eps^2 */ c[l] = d * polyval(m, coeff + o, eps2) / coeff[o + m + 1]; o += m + 2; d *= eps; } } /* The scale factor A3 = mean value of (d/dsigma)I3 */ void A3coeff(struct geod_geodesic* g) { static const double coeff[] = { /* A3, coeff of eps^5, polynomial in n of order 0 */ -3, 128, /* A3, coeff of eps^4, polynomial in n of order 1 */ -2, -3, 64, /* A3, coeff of eps^3, polynomial in n of order 2 */ -1, -3, -1, 16, /* A3, coeff of eps^2, polynomial in n of order 2 */ 3, -1, -2, 8, /* A3, coeff of eps^1, polynomial in n of order 1 */ 1, -1, 2, /* A3, coeff of eps^0, polynomial in n of order 0 */ 1, 1, }; int o = 0, k = 0, j; for (j = nA3 - 1; j >= 0; --j) { /* coeff of eps^j */ int m = nA3 - j - 1 < j ? nA3 - j - 1 : j; /* order of polynomial in n */ g->A3x[k++] = polyval(m, coeff + o, g->n) / coeff[o + m + 1]; o += m + 2; } } /* The coefficients C3[l] in the Fourier expansion of B3 */ void C3coeff(struct geod_geodesic* g) { static const double coeff[] = { /* C3[1], coeff of eps^5, polynomial in n of order 0 */ 3, 128, /* C3[1], coeff of eps^4, polynomial in n of order 1 */ 2, 5, 128, /* C3[1], coeff of eps^3, polynomial in n of order 2 */ -1, 3, 3, 64, /* C3[1], coeff of eps^2, polynomial in n of order 2 */ -1, 0, 1, 8, /* C3[1], coeff of eps^1, polynomial in n of order 1 */ -1, 1, 4, /* C3[2], coeff of eps^5, polynomial in n of order 0 */ 5, 256, /* C3[2], coeff of eps^4, polynomial in n of order 1 */ 1, 3, 128, /* C3[2], coeff of eps^3, polynomial in n of order 2 */ -3, -2, 3, 64, /* C3[2], coeff of eps^2, polynomial in n of order 2 */ 1, -3, 2, 32, /* C3[3], coeff of eps^5, polynomial in n of order 0 */ 7, 512, /* C3[3], coeff of eps^4, polynomial in n of order 1 */ -10, 9, 384, /* C3[3], coeff of eps^3, polynomial in n of order 2 */ 5, -9, 5, 192, /* C3[4], coeff of eps^5, polynomial in n of order 0 */ 7, 512, /* C3[4], coeff of eps^4, polynomial in n of order 1 */ -14, 7, 512, /* C3[5], coeff of eps^5, polynomial in n of order 0 */ 21, 2560, }; int o = 0, k = 0, l, j; for (l = 1; l < nC3; ++l) { /* l is index of C3[l] */ for (j = nC3 - 1; j >= l; --j) { /* coeff of eps^j */ int m = nC3 - j - 1 < j ? nC3 - j - 1 : j; /* order of polynomial in n */ g->C3x[k++] = polyval(m, coeff + o, g->n) / coeff[o + m + 1]; o += m + 2; } } } /* The coefficients C4[l] in the Fourier expansion of I4 */ void C4coeff(struct geod_geodesic* g) { static const double coeff[] = { /* C4[0], coeff of eps^5, polynomial in n of order 0 */ 97, 15015, /* C4[0], coeff of eps^4, polynomial in n of order 1 */ 1088, 156, 45045, /* C4[0], coeff of eps^3, polynomial in n of order 2 */ -224, -4784, 1573, 45045, /* C4[0], coeff of eps^2, polynomial in n of order 3 */ -10656, 14144, -4576, -858, 45045, /* C4[0], coeff of eps^1, polynomial in n of order 4 */ 64, 624, -4576, 6864, -3003, 15015, /* C4[0], coeff of eps^0, polynomial in n of order 5 */ 100, 208, 572, 3432, -12012, 30030, 45045, /* C4[1], coeff of eps^5, polynomial in n of order 0 */ 1, 9009, /* C4[1], coeff of eps^4, polynomial in n of order 1 */ -2944, 468, 135135, /* C4[1], coeff of eps^3, polynomial in n of order 2 */ 5792, 1040, -1287, 135135, /* C4[1], coeff of eps^2, polynomial in n of order 3 */ 5952, -11648, 9152, -2574, 135135, /* C4[1], coeff of eps^1, polynomial in n of order 4 */ -64, -624, 4576, -6864, 3003, 135135, /* C4[2], coeff of eps^5, polynomial in n of order 0 */ 8, 10725, /* C4[2], coeff of eps^4, polynomial in n of order 1 */ 1856, -936, 225225, /* C4[2], coeff of eps^3, polynomial in n of order 2 */ -8448, 4992, -1144, 225225, /* C4[2], coeff of eps^2, polynomial in n of order 3 */ -1440, 4160, -4576, 1716, 225225, /* C4[3], coeff of eps^5, polynomial in n of order 0 */ -136, 63063, /* C4[3], coeff of eps^4, polynomial in n of order 1 */ 1024, -208, 105105, /* C4[3], coeff of eps^3, polynomial in n of order 2 */ 3584, -3328, 1144, 315315, /* C4[4], coeff of eps^5, polynomial in n of order 0 */ -128, 135135, /* C4[4], coeff of eps^4, polynomial in n of order 1 */ -2560, 832, 405405, /* C4[5], coeff of eps^5, polynomial in n of order 0 */ 128, 99099, }; int o = 0, k = 0, l, j; for (l = 0; l < nC4; ++l) { /* l is index of C4[l] */ for (j = nC4 - 1; j >= l; --j) { /* coeff of eps^j */ int m = nC4 - j - 1; /* order of polynomial in n */ g->C4x[k++] = polyval(m, coeff + o, g->n) / coeff[o + m + 1]; o += m + 2; } } } int transit(double lon1, double lon2) { double 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. */ lon12 = AngDiff(lon1, lon2, nullptr); lon1 = AngNormalize(lon1); lon2 = AngNormalize(lon2); return lon12 > 0 && ((lon1 < 0 && lon2 >= 0) || (lon1 > 0 && lon2 == 0)) ? 1 : (lon12 < 0 && lon1 >= 0 && lon2 < 0 ? -1 : 0); } int transitdirect(double lon1, double lon2) { /* Compute exactly the parity of * int(floor(lon2 / 360)) - int(floor(lon1 / 360)) */ lon1 = remainder(lon1, 2.0 * td); lon2 = remainder(lon2, 2.0 * td); return ( (lon2 >= 0 && lon2 < td ? 0 : 1) - (lon1 >= 0 && lon1 < td ? 0 : 1) ); } void accini(double s[]) { /* Initialize an accumulator; this is an array with two elements. */ s[0] = s[1] = 0; } void acccopy(const double s[], double t[]) { /* Copy an accumulator; t = s. */ t[0] = s[0]; t[1] = s[1]; } void accadd(double s[], double y) { /* Add y to an accumulator. */ double 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; } double accsum(const double s[], double y) { /* Return accumulator + y (but don't add to accumulator). */ double t[2]; acccopy(s, t); accadd(t, y); return t[0]; } void accneg(double s[]) { /* Negate an accumulator. */ s[0] = -s[0]; s[1] = -s[1]; } void accrem(double s[], double y) { /* Reduce to [-y/2, y/2]. */ s[0] = remainder(s[0], y); accadd(s, 0.0); } void geod_polygon_init(struct geod_polygon* p, boolx polylinep) { p->polyline = (polylinep != 0); geod_polygon_clear(p); } void geod_polygon_clear(struct geod_polygon* p) { p->lat0 = p->lon0 = p->lat = p->lon = NaN; accini(p->P); accini(p->A); p->num = p->crossings = 0; } void geod_polygon_addpoint(const struct geod_geodesic* g, struct geod_polygon* p, double lat, double lon) { if (p->num == 0) { p->lat0 = p->lat = lat; p->lon0 = p->lon = lon; } else { double s12, S12 = 0; /* Initialize S12 to stop Visual Studio warning */ geod_geninverse(g, p->lat, p->lon, lat, lon, &s12, nullptr, nullptr, nullptr, nullptr, nullptr, p->polyline ? nullptr : &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, double azi, double s) { if (p->num) { /* Do nothing is num is zero */ /* Initialize S12 to stop Visual Studio warning. Initialization of lat and * lon is to make CLang static analyzer happy. */ double lat = 0, lon = 0, S12 = 0; geod_gendirect(g, p->lat, p->lon, azi, GEOD_LONG_UNROLL, s, &lat, &lon, nullptr, nullptr, nullptr, nullptr, nullptr, p->polyline ? nullptr : &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, double* pA, double* pP) { double s12, S12, t[2]; 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, nullptr, nullptr, nullptr, nullptr, nullptr, &S12); if (pP) *pP = accsum(p->P, s12); acccopy(p->A, t); accadd(t, S12); if (pA) *pA = areareduceA(t, 4 * pi * g->c2, p->crossings + transit(p->lon, p->lon0), reverse, sign); return p->num; } unsigned geod_polygon_testpoint(const struct geod_geodesic* g, const struct geod_polygon* p, double lat, double lon, boolx reverse, boolx sign, double* pA, double* pP) { double perimeter, tempsum; 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) { double s12, S12 = 0; /* Initialize S12 to stop Visual Studio warning */ geod_geninverse(g, i == 0 ? p->lat : lat, i == 0 ? p->lon : lon, i != 0 ? p->lat0 : lat, i != 0 ? p->lon0 : lon, &s12, nullptr, nullptr, nullptr, nullptr, nullptr, p->polyline ? nullptr : &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; if (pA) *pA = areareduceB(tempsum, 4 * pi * g->c2, crossings, reverse, sign); return num; } unsigned geod_polygon_testedge(const struct geod_geodesic* g, const struct geod_polygon* p, double azi, double s, boolx reverse, boolx sign, double* pA, double* pP) { double perimeter, tempsum; 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; { /* Initialization of lat, lon, and S12 is to make CLang static analyzer * happy. */ double lat = 0, lon = 0, s12, S12 = 0; geod_gendirect(g, p->lat, p->lon, azi, GEOD_LONG_UNROLL, s, &lat, &lon, nullptr, nullptr, nullptr, nullptr, nullptr, &S12); tempsum += S12; crossings += transitdirect(p->lon, lon); geod_geninverse(g, lat, lon, p->lat0, p->lon0, &s12, nullptr, nullptr, nullptr, nullptr, nullptr, &S12); perimeter += s12; tempsum += S12; crossings += transit(lon, p->lon0); } if (pP) *pP = perimeter; if (pA) *pA = areareduceB(tempsum, 4 * pi * g->c2, crossings, reverse, sign); return num; } void geod_polygonarea(const struct geod_geodesic* g, double lats[], double lons[], int n, double* pA, double* 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); } double areareduceA(double area[], double area0, int crossings, boolx reverse, boolx sign) { accrem(area, area0); if (crossings & 1) accadd(area, (area[0] < 0 ? 1 : -1) * area0/2); /* area is with the clockwise sense. If !reverse convert to * counter-clockwise convention. */ if (!reverse) accneg(area); /* If sign put area in (-area0/2, area0/2], else put area in [0, area0) */ if (sign) { if (area[0] > area0/2) accadd(area, -area0); else if (area[0] <= -area0/2) accadd(area, +area0); } else { if (area[0] >= area0) accadd(area, -area0); else if (area[0] < 0) accadd(area, +area0); } return 0 + area[0]; } double areareduceB(double area, double area0, int crossings, boolx reverse, boolx sign) { area = remainder(area, area0); if (crossings & 1) area += (area < 0 ? 1 : -1) * area0/2; /* area is with the clockwise sense. If !reverse convert to * counter-clockwise convention. */ if (!reverse) area *= -1; /* If sign put area in (-area0/2, area0/2], else put area in [0, area0) */ if (sign) { if (area > area0/2) area -= area0; else if (area <= -area0/2) area += area0; } else { if (area >= area0) area -= area0; else if (area < 0) area += area0; } return 0 + area; } /** @endcond */ raster/NAMESPACE0000644000176200001440000000412114720731607012776 0ustar liggesusersimport(methods, Rcpp, terra) import(terra, except=c(area, gridDistance)) importFrom(sp, spplot, coordinates, wkt, plot, merge, bbox, disaggregate, proj4string) importFrom(grDevices, terrain.colors, heat.colors, rainbow) exportClasses(Extent, BasicRaster, Raster, RasterLayer, RasterBrick, RasterStack, RasterStackBrick) exportMethods("[", "[[", "==", "!=", "!", "%in%", adjacent, aggregate, all.equal, animate, Arith, approxNA, area, as.array, as.character, as.data.frame, as.factor, as.list, as.vector, as.matrix, as.raster, atan2, bandnr, bbox, bind, barplot, blockSize, boundaries, boxplot, buffer, brick, calc, clamp, click, cellStats, clump, colSums, Compare, couldBeLonLat, cover, coordinates, contour, corLocal, cut, crosstab, crop, crs, "crs<-", disaggregate, distance, direction, density, erase, extent, extract, extend, flip, focal, freq, getValues, getValuesBlock, geom, gridDistance, hasValues, hist, head, init, inMemory, interpolate, intersect, image, is.factor, isLonLat, layerize, lines, log, Logic, levels, is.factor, as.factor, asFactor, match, mask, Math, Math2, mean, metadata, merge, modal, mosaic, names, "names<-", ncell, ncol, "ncol<-", nlayers, nrow, "nrow<-", overlay, origin, "origin<-", pairs, persp, plot, plotRGB, predict, proj4string, quantile, RGB, raster, rasterize, ratify, rectify, reclassify, res, "res<-", resample, rotate, rowSums, "$", "$<-", sampleRandom, sampleRegular, sampleStratified, scale, select, stackSelect, setMinMax, setValues, shift, stretch, spplot, subset, subs, summary, Summary, stack, symdif, t, tail, terrain, text, trim, unique, unstack, union, update, xmin, xmax, xres, ymin, ymax, yres, zonal, yFromRow, xFromCol,colFromX, rowFromY, cellFromXY, cellFromRowCol, cellFromRowColCombine, xyFromCell, yFromCell, xFromCell, rowColFromCell,rowFromCell, colFromCell, readStart, readStop,values, "values<-", weighted.mean, which.min, which.max, whiches.min, whiches.max, Which, wkt, writeStart, writeStop, writeValues, writeRaster, zonal, zoom, xmin, xmax, ymin, ymax, "xmin<-", "xmax<-", "ymin<-", "ymax<-") useDynLib(raster, .registration = TRUE) exportPattern("^[^\\.\\_]") raster/inst/0000755000176200001440000000000014507510157012534 5ustar liggesusersraster/inst/tinytest/0000755000176200001440000000000014507510157014417 5ustar liggesusersraster/inst/tinytest/test_subset.R0000644000176200001440000000115314507510157017106 0ustar liggesusersr <- raster::brick(nrows = 100, ncols = 100, nl = 2) r_z <- setZ(r, as.Date(c("2018-01-01", "2018-01-02"))) s <- stack(r) s_z <- setZ(s, as.Date(c("2018-01-01", "2018-01-02"))) #test_that("subset keeps the z attribute if present",{ # on brick expect_equal(r_z[[1]]@z$time, as.Date("2018-01-01")) expect_equal(s_z[[2]]@z$time, as.Date("2018-01-02")) # on stack expect_equal(s_z[[c(1,2)]]@z$time, as.Date(c("2018-01-01", "2018-01-02"))) expect_equal(s_z[[c(1,2)]]@z$time, as.Date(c("2018-01-01", "2018-01-02"))) # NULL if no z set expect_equal(r[[1]]@z$time, NULL) expect_equal(s[[1]]@z$time, NULL) raster/inst/tinytest/tinytest.R0000644000176200001440000000013214507510157016421 0ustar liggesusers if ( requireNamespace("tinytest", quietly=TRUE) ) { tinytest::test_package("raster") } raster/inst/tinytest/test_sf-coercion.R0000644000176200001440000000317014507510157020011 0ustar liggesusers # This gives an error on CRAN for OSX # context("test-sf-coercion") # library(sf) # p1 <- structure(cbind(0, 0), class = c("XY", "POINT", "sfg")) # p2 <- structure(cbind(1, 1), class = c("XY", "POINT", "sfg")) # sf <- structure(data.frame(a = 1:2, geometry = structure(list(p1, p2), class = c("sfc_POINT", "sfc"), # bbox = structure(c(xmin = 0, ymin = 0, xmax = 1, ymax = 1), class = "bbox"), # crs = structure(list(epsg = NA_integer_, proj4string = NA_character_), class = "crs"), precision = 0)), # class = c("sf", "data.frame"), sf_column = "geometry", agr = factor(NA, c("constant", "aggregate", "identity"))) # raster_sf <- raster(sf) # test_that("raster from sf works", # { expect_that(raster_sf, is_a("RasterLayer")) } # ) # p1 <- rbind(c(-180, -20), c(-140, 55), c(10, 0), c(-140, -60), c(-180, -20)) # hole <- rbind(c(-150, -20), c(-100, -10), c(-110, 20), c(-150, -20)) # p1 <- list(p1, hole) # p2 <- rbind(c(-10, 0), c(140, 60), c(160, 0), c(140, -55), c(-10, 0)) # p3 <- rbind(c(-125, 0), c(0, 60), c(40, 5), c(15, -45), c(-125, 0)) # pols <- spPolygons(p1, p2, p3) # sf_pols <- st_as_sf(pols) # r <- raster(ncol = 90, nrow = 45, vals=1) # test_that("crop using sfc works", # { expect_equal(crop(r, pols), crop(r, sf_pols)) } # ) # test_that("mask using sfc works", # { expect_equal(mask(r, pols), mask(r, sf_pols)) } # ) # test_that("rasterize based on sfc works", # { expect_equal(rasterize(pols, r, fun = sum), rasterize(sf_pols, r, fun = sum)) } # ) # test_that("extract based on sfc works", # { expect_equal(extract(r, pols), extract(r, sf_pols)) } # ) raster/inst/tinytest/test_getvaluesblock.R0000644000176200001440000000050714507510157020615 0ustar liggesusers #test_that('we can extract from a single layer of a RasterStack using the lyrs argument', { rast <- raster(matrix(1:16, nrow=4), xmn=0, xmx=4, ymn=0, ymx=4) stk <- stack(list(a=rast, b=sqrt(rast))) expect_equivalent( getValuesBlock(stk[[1]], 1, 3, 3, 2, format='m'), getValuesBlock(stk, 1, 3, 3, 2, lyrs=1), ) raster/inst/tinytest/test_wkt_grd.R0000644000176200001440000000041714507510157017244 0ustar liggesusersfl <- system.file("external/test.grd", package="raster") tst <- raster::raster(fl) raster::crs(tst) <- raster::crs("EPSG:28992") tf <- tempfile(fileext=".grd") raster::writeRaster(tst, tf) tst1 <- raster::raster(tf) expect_identical(raster::wkt(tst), raster::wkt(tst1)) raster/inst/tinytest/test_rasterize.R0000644000176200001440000000074614507510157017620 0ustar liggesusers p1 <- rbind(c(-180, -20), c(-140, 55), c(10, 0), c(-140, -60), c(-180, -20)) hole <- rbind(c(-150, -20), c(-100, -10), c(-110, 20), c(-150, -20)) p1 <- list(p1, hole) p2 <- rbind(c(-10, 0), c(140, 60), c(160, 0), c(140, -55), c(-10, 0)) p3 <- rbind(c(-125, 0), c(0, 60), c(40, 5), c(15, -45), c(-125, 0)) pols <- spPolygons(p1, p2, p3) r <- raster(ncol = 90, nrow = 45) x <- rasterize(pols, r, fun = sum) # rasterize works as before expect_equal(sum(values(x), na.rm=TRUE), 3481) raster/inst/external/0000755000176200001440000000000014507510157014356 5ustar liggesusersraster/inst/external/lux.shp0000644000176200001440000017626414507510157015722 0ustar liggesusers' ~Zèèàÿù@ ®û¿Q¹H@KÅ­î@Ú¿ü_?I@ pŸp<ÀN@ó¬@ùH@g=!൤@Ú¿ü_?I@K˜ƒâ¿'@@l à½I@bwË @˜Ù@3I@ô¼á_€$@M€@I@kñ)Æ+@›;ú_®I@ɹò,@ Õÿÿ I@„ H f1@õx€}I@]IÙ¿><@ó€2I@`­=`Ü=@¤Æ`'I@1ܱ¿‰H@€Ô@I@x³ßfO@‚¸þŸ;I@þÛ<@½R@åmøI@}É ÿg@G' ÝI@é$BÀ­m@[»à“I@ÊÒÿQ{@bOùßãI@P 6@ U °I@LA à^€@(åÿŸTI@ö8> ñ@®ÀBI@b;@}@"Ï`ÉI@‡QÎì{@Ju  {I@½ÈÂßHw@ô¨ø¿£I@·Ø¿%w@\·÷_I@Þ0úŸ6}@gi eI@ ™D ƒ@jò÷ÿ/I@}\¸ÿ …@äøI@?ƒ4§…@Vàù4I@Üà–@ý?¹I@·C`8y@Þ0úŸ¶I@f˜$à!z@yÖ MI@XZã¿‚€@¹ÀÀOI@?˜ëŸmz@(åÿŸÔ I@ÕøØŸ¼z@0 \ I@åÆ_ @pô ^ I@‘ú_l@êŸùÿå I@¦‚'€¤t@øD Àà I@<ã€ót@§S@h I@L8 ¥{@`éø?ò I@éöíÛn@oŽí I@ZÓp@*Éøÿ I@ Æóߤi@üŽÀ I@äźŸði@òü¿ I@‡é1€¦p@½Iü I@=þZp@2îþ_’ I@¾Æ&àtv@j³ûŸ I@}Àw@ý3ÿ¿ I@Êóè_õp@Ån€¡I@øo€&q@Ûdù_SI@£ó¯Aq@t}þÿ(I@©_Ðß×j@àüŸ&I@öö@Âj@j5àHI@%¯ï? f@;‘ý^I@ŠsõßZd@é`ýŸCI@R »d@üÍþ«I@ؘøpk@Çÿ5I@) à#k@<¸À­I@# ãq@|¢`°I@/%? ;r@…„ÿßžI@ãÌ  sr@¾1GI@\ à(y@wÇ÷ÿÐI@5 åŸty@‘œ ÀXI@€m7 )€@J2þ¿âI@WÃy@ HûàI@%Í_[z@Á{ýÿîI@²„Ö?_@”æÀI@BÆ_Ň@ÕÐ`I@Øn³_ˆ@N|÷¿ŠI@QI«@ ˆI@ 1Ñÿö@K I@ç)@Ž{@ 0 I@ëñûˆ@ ÷_!I@å…ð?d@Ðõùÿ#I@¾…·ÿ¯@Ø`«I@Dž À’‰@ U 0I@;Ôßà‰@OdÿŸ·ÿH@)wáÿuƒ@ëÆý?µÿH@ÝàU ă@™Õù¿<ÿH@$_KÀ–@ªÿÿAÿH@ý^€â@"Ï`ÉþH@Û<' š—@Ûdù_SþH@g=!൤@ç”ü_àýH@׳1ÀOž@Ê]øÝýH@ÔUO Ëž@3— àýH@?¯ÀÖ@L÷ýH@"C@ø›@/ãÀ ýH@†¬ÑX™@‘ú_ìüH@ßCp”@ngÀüH@Áúÿ’@Zû_‰üH@0‹?@­@œbþŸ}üH@° ÝߨŽ@côõßwüH@“*ÝŸƒ‰@($üÿvüH@ŠKÀu†@=ß}üH@1ïÌ_|„@9nÀ…üH@b:B@‚@+r€•üH@ÁêŸ@èà¬üH@×I" g€@GèÀºüH@xĶD@¨¹àÙüH@šÃÿg~@Àý_ýüH@Bcàæ|@ìkú?IýH@q±¿.{@_ƒøŸ€ýH@(ÌÿÔy@;ö?£ýH@nRM Wx@UzùßÂýH@‘èߪv@Ü àÝýH@óë ¼u@ƒ €èýH@Ö¡äÇt@µåù_ðýH@ £þÌr@ ‹ùýH@Õû Éo@->ÀøýH@°ßÙ?Ën@Ymþ_õýH@%@àýl@š½ éýH@žä?îh@ëo À¿ýH@Ç~ÜŸf@@A÷øýH@Rï?&a@,™ÀdþH@ÞÆêN_@­6þH@Ôüç3^@­¨ûßþH@”Ý?õ[@«… ½ýH@z ×Z@©7þŸžýH@|NQ`ÇX@ ‹yýH@ãôÜß,W@~†ý¿fýH@o°?¢T@ÌÃøOýH@ô¾Tà"S@Yëö:ýH@YNÍQ@ÀTù¿ýH@q²Ë¿¯P@;ÐùßýH@†<@ÿN@+±à·üH@ * `5L@G~õŸRüH@VMJ ©J@˜ñ`üH@-¬#`×G@fë à ûH@,­ñ_AF@‡hø?UûH@ ÞëÿwC@z€ïúH@rØ•@@èúüÿQúH@—Ç»Ÿ*9@P üŸKúH@ôýP@E7@¢úÿDúH@ôÒœ5@÷\à3úH@1°ÐÿY4@zý`úH@rER ‰3@Y àÿùH@üLÅßY3@êH€ðùH@¶¸J V3@3 áùH@Ñp±?Ü3@ëù?¬ùH@À)æÿÙ3@’€ùH@ÑDЬ3@X° @ŽùH@˜êÿâ2@IÌýqùH@L˜þ_T2@»eÀcùH@@ø0@> @LùH@„ðªÿZ/@úgþ9ùH@˲Pÿ+@ó¬@ùH@½5€=*@ÅÅöÿ–ùH@ÅíÈ?Ð)@Ÿï€¾ùH@È ¯2)@ç=àjúH@ÈOº_Ë(@U `”úH@Ë\*€s(@à–ú?¨úH@è<:à€'@‰õ_ÊúH@¹‚Ø_—%@‰¶ÀóúH@¼M  $@êÞõ_ûH@/Ìן£!@M¿ #ûH@ÓjÀ‘@è HûH@vÔs@qðùhûH@ˆü¤@·3àŽûH@>‡C€@Sù?ÑûH@ ýŸ@¿X@üH@†¿ì¿J@eZöéüH@aà¬@îz`EýH@ô¨ø¿#@f qýH@;}à@ötùÿ†ýH@rÙÏÿþ@æ ›ýH@ØAà7 @»&`ÁýH@k˜Âÿ-#@KqúþH@7Š`O'@ÑÝàPþH@•å5À)@/¤`jþH@=Œ þ*@x¯ÿß}þH@†øŸã,@êÞõ_ˆþH@|¢`°1@¦,™þH@¸µ¿’3@ §þH@ÑG ,6@ñ…ËþH@¼â-€¾7@ËèþH@gçú_*9@êÞõ_ÿH@_Dü?^:@ï7û,ÿH@,–Ç?Ø:@&@ @ÿH@¼ 2;@à~ UÿH@J´ž;@$³þ¿ÿH@ŒÀÊ;@ö«ÿH@©#Â;@bø`îÿH@àÿ;`&;@裀\I@w²?õ8@ – ~I@½wP`l7@?„‘I@J †5@Þš ÀžI@À¾à‡3@©@¦I@²0#@v0@©à ©I@–öÝßf.@|ùøߥI@â&@ u)@·úI@Ü‹ýŸ¢&@‡ @iI@ý3ÿ¿#@F‚ II@&HÀ*@…„ÿßI@‘†®ŸY@ŠõüI@YÚNj@#ö  I@|·»ÿv@N€I@’‡S ’@ 'I@íS ö@9Cõÿ?I@*Æ·~@î÷?]I@ãàó?Ð@Ê]øÝI@àéß?@Â$ €ùI@o$ùß„ @ÎPýÿI@œKÔ” @5ùûÿI@„ÈØ¿¡ @6¢€"I@GRà¢@cvý3I@áåп°@;R <I@Ëè@àÕöŸJI@ßàÕü@@A÷xI@çз?öú@Kqú…I@’ÄÜÿ÷@²Â —I@{¦à&õ@;ö?£I@ÌUÚðï@– ÐI@(ÌÿÔí@»&`AI@Ò‚þßdí@*ŠüŸhI@—vI Ní@˜0ý¿¨I@åØÕ?ãí@2¯ðI@®| fé@û €TI@‹×?üæ@¥üÿ“I@Æ ‹å@Ð4ö_ÆI@ì@çä@åmøI@´è:àüâ@o À1I@˜Ã¬´á@ÆV `NI@¦ØM0à@1÷eI@ÍÎ?Mß@å.ü¿nI@ì¿­?²Ú@òü¿I@þÙÉ¿Ø@©@¦I@‹†€MÔ@É `vI@Ã_ö_¥Ò@G' ]I@¢CàHÐ@«ÜúŸ2I@ûz ,Ê@¦ký_»I@™l¸Ÿ¾Ç@–‹À”I@Ò—µ+Æ@7à‚I@å˜ àVÃ@ù@ú?jI@ˆÏÆß0À@/e HI@_ƒøŸ€¾@¦ký_;I@óë ¼½@›äà8I@ˆÏÆß0¼@0Ë  9I@¦+3¯º@öö@BI@Z@O Û¹@˜oùKI@Å°?`¸@’˜û?bI@:¿QÀ°³@À“õÂI@1Û㿲@WößÖI@?•ªa±@Åð ÀÜI@FØ* Ô¯@¶KúÿáI@ÓéÌ@®@ƒ÷úÿÝI@‚¤_­@WößÖI@ˆdé¿Þ«@Jó`ÀI@ÕøØŸ¼ª@Ån€¡I@Á|ËÿXª@“€ I@ý O`ª@˜®õmI@¢¤ÙŸ8ª@b¹LI@òÛ)€Öª@,€)I@ ”ÿR«@pÉõßI@AÍŸ€¯@/"þ¯I@!¨ z°@|cŽI@¥Úéÿ±@^õ_kI@±Þ±@ã‰ÿ¿ZI@%¬®¿ü°@0Ë  9I@À_i°@²Â I@yo5€ñ¯@ötùÿI@¬× Ò®@ƒ €èI@g'Å¿¶«@,nõÿžI@Ù¬Ÿ£ª@ – ~I@M:€4ª@9+ýßlI@ù—î¿ß©@=   ZI@œ"4@q©@°ö`4I@jq¾¿Þ¨@.¼ý½I@œKÔ”¨@fBþ_–I@Ò `¨@‘2ûŸpI@J´ž§@Þþ¿^I@)ÊÆÿô¥@SÕüß.I@¬W²ßê£@o$ùßI@µ¿³¡@WÈ`áÿH@’Yÿß¿ž@Êü»ÿH@G€€˜@óë ¼ÿH@Ia •@žF÷ÿ³ÿH@}³¬“@v@¥ÿH@öaÞ_@—Hõß{ÿH@óè°ˆ@&@ @ÿH@Ë1À­†@cvý3ÿH@Éx1 ½…@Û%ýÿ0ÿH@MªK݃@Vàù4ÿH@›¦×‚@Å­þßCÿH@~†ý¿f|@3— àœÿH@§’ Š{@¬Bû?¤ÿH@9WÞŸœz@ocõ?§ÿH@k[9 ®y@dÜý¿¤ÿH@ A€Óx@ngÀÿH@: ]w@ötùÿ†ÿH@&Ù4eu@wÇ÷ÿPÿH@IúQ`Ct@x1 9ÿH@>\0ÀWo@€+ú¿úþH@áçC@Sm@ï¹ÀçþH@£]¿?)k@$t`ÝþH@YØßéh@Ìl ÙþH@ü7@“^@pô ÞþH@MT%€Q\@×óûÜþH@²/[@ýµØþH@Î’:à>W@†lÀKÿH@KÇ  O@ âúîÿH@}‡Ë¿ÐN@>œúdI@Ÿp<ÀN@aS`ÚI@"bµ¿ÔO@›;ú_®I@ƒû¿òU@×2øþI@”&Î b@Ù€I@µŽàúk@,™ÀäI@{èPÀUr@˜®õíI@þÆ=p@4TÿÿƒI@œbþŸýo@Ó© ´I@XE, ¼o@ æI@`k€­t@@)ÿÿ¤I@,™Àä@5ºÿŸu I@JôÏ_*‚@u€‰ I@›8¹ß¡ˆ@sÀ àÁ I@¨:? +@\!€ I@#· @ö@´(@ I@<"à‘@.}  I@\Mè?µ“@­¨ûß I@Q„³ß™@ L  Ö I@"NÌx™@÷€ I@j à›@¨¹àÙ I@*sÒÿ›@ÖÌ÷ß I@¦Âñß0Ÿ@æU>I@[ûÐ? ³@->ÀxI@5ùûÿ¿@÷³õ_)I@ßÄN€zÎ@fBþ_I@¬¬ ` Ñ@æU>I@›}7@ÝÞ@kÚÿßÜI@ÖÝß á@oŽíI@Î<`³ó@qý?wI@Í“à¨õ@Ö6uI@y.K@Fý?˜I@­ëÀ.@,nõÿI@ÓÁú?‡@Ú¿ü_?I@˜ƒâ¿'@@l à½I@ èàC áÞ@ í÷täH@¢ù1 ZC@,™ÀdþH@ºuv®ÿ¥¶@¸ À;ðH@¤ž. î½@òÄÿ_mïH@ˆúÙŸöÁ@üÍþ«ïH@Š^>@”Ã@µüŸÇïH@yÙD ÙÅ@”=ø?öïH@I÷à6Ç@Y¬ú¿ðH@ÿWÂ_È@^à;ðH@_¿_/É@€• àbðH@Û½?RÊ@ˆÎøßÆðH@©¼_ýÊ@òÄÿ_íðH@ V9@rË@ûåö?þðH@éÕß–Ì@WJ  ñH@“Ô¶øÍ@JJöß5ñH@|5´¿»Î@ö?@ñH@ÏßßûÒ@*ŠüŸhñH@6   ×@N%@•ñH@" §Ú@LY²ñH@ jÓ¿ÁÞ@û¦úßÛñH@o°?¢à@N=û_èñH@Ó÷Ÿ©á@‘ú_ìñH@Üc+`éå@IÌýññH@Á’' Xë@Ú§@ìñH@¼uÝßÉð@ø€àñH@s•öüô@¹ÀÀÏñH@L¬çÿ°ô@N@:òH@|MÀéø@;R <òH@?ö>ù@Cw€ÃñH@Á Ýÿ@½àMñH@ ¾?1@½Ë`ÕðH@šÀB v@\9ÿŸØðH@ß/, Ì@d^`ðH@„ÜÁ_þ @†øŸcðH@€ÕÓ?o@Á{ýÿîïH@¤(ÀE@0 ößóïH@â¹ïÿ€@s•öüïH@ötùÿ@ ‡÷‚ïH@·@2$@Æ ‹ïH@ßC@)%@î’þ˜îH@<Ï+à–*@¡»À¡îH@Óà?0@ˆü$ïH@(f9à%6@.ïH@JGµ_©<@@l à½îH@/ãÀ =@~G`DîH@«±çßì6@îÑúß:îH@)8åŸS7@—s ÁíH@D_`p=@˜oùËíH@ˆ»Ý?Ô=@0aúQíH@¢ù1 ZC@–L`òìH@}ÀC@,™ÀäìH@I ú“A@’ànìH@×´ÿ¿¹@@ÎÒ@KìH@¿U@-@@¸ À;ìH@•I€Ü>@Šž  ìH@HàF=@wIÿ? ìH@vuàÿ;<@¶Šö_ìH@K :@©ø@üëH@ÅÄ(­6@ÙA úëH@ô= Ñ)@Zû_ ìH@/"þ/%@÷€ìH@p÷I ë"@#ö  ìH@ƒ^ÉŸ¹ @Y $ìH@!¼ê¿Ö@èúüÿQìH@CÊìÂ@u& €3ìH@ó—P Ó@Þñý?ìH@8°E 4@F‚ ÉëH@ï&S`\@\!€…ëH@~Åù‰@ì® bëH@§<Ûÿ@Ÿï€>ëH@BùÀþ@'ÿÿâêH@84À`@Ǽ ÀêH@ôøÿi@N€žêH@“Ô¶ø @âäÀFêH@‡“  @¼ãû(êH@°ˆå¿Õ @k\ êH@²®» @(ø¿êH@¥®@Ô @Ymþ_õéH@-$`t @OüÿÕéH@Çåª?ã@ö«éH@ª Oà„@©µö_ãèH@EDÖ¿@‘ú_lèH@½Ê5`ë@ÄÀCèH@ûRGàr@ÿØû¿0èH@¨=€ @Àý_ýçH@úª `Ò @ˆP ‚çH@—É. Í @AàQçH@¼¿¬ @/"þ/çH@Ù®T@o@ÏÎõ¿ÔæH@aýáßN@hà´æH@^†9 @ð`YæH@±‡Àk@T~`9æH@‹X¼?{@­¨ûßæH@ÃK ÀH@$t`ÝåH@L×ú¿vþ@:À™åH@È& ¨ý@É `våH@‹›Çý@ÆV `NåH@ZT8@8ü@©ø@üäH@KÇ  û@û €ÔäH@ö·àŸú@òBø²äH@WÜêÿ=ø@ í÷täH@9@ô@côõßwäH@ƒàÐßtô@ï¡  åH@hb²Ÿbô@n¦ @åH@ºù_ô@ ñ jåH@zÓŸÀó@lü?åH@*¡&ÀÑò@¹ØþߢåH@k=À‹ñ@&@ ÀåH@¦ðËð@DsøÿÌåH@ÉM`÷ï@hÏ@×åH@¤Ý*€î@éû_äåH@•å5Àí@6 @çåH@º”% ë@¹V÷ŸçåH@do­0é@þ±÷áåH@»yì_@è@ZùŸÛåH@ü#% 6ä@:©õŸ±åH@íj,@_ã@‹šùªåH@òm àwá@äøŸåH@n{í_zß@™–ý_šåH@-$`tÝ@)cø_™åH@'¯_nÛ@ž° œåH@mÒáßoÙ@\÷£åH@þðó߃×@:©õŸ±åH@D1»žÖ@ïõÿ»åH@øô¿ùÔ@™ ÕåH@š>;àºÒ@7àæH@¬­Ø_vË@÷³õ_©æH@û%ÁŸ É@tûö¿íæH@ ÿÜŸ¤Ç@©7þŸçH@zç«?Æ@É÷÷ßkçH@¹Õ½_Ä@Z” ÄçH@n{í_zÃ@†« îçH@Ìî àÃ@Vàù4èH@­UàÃ@=uöß”èH@‘ŸK@eÃ@”=ø?öèH@ŒmJ`Ä@æ eéH@÷³õ_)¿@(ø¿†éH@$ÿB½@r/öŠéH@C ·ßN¼@Æ+÷ŸˆéH@ó×`»@j àƒéH@ OÀÀ¹@0 ößséH@ޛ׿ˆµ@‰ 1éH@þÙÉ¿´@k éH@úÒÛŸ‹²@¡ø?éH@'©DÀ¾±@G©`éH@ó>éŸ;°@6¢€"éH@XC¹Ÿ­@Ÿï€>éH@Ï#N@v§@Ïw@_éH@+±à·¥@ ÿõŸoéH@äàƒ¢@›¥ €–éH@‰Ë·_º @ÕÀ¥éH@I7Û?Ã@(¦@²éH@ +&€¬™@0Ë  ¹éH@þœ@àš–@¬¬ `ŒéH@ì, í”@n(`{éH@‘ˆ! ü“@Ymþ_uéH@ú? ’@bø`néH@Ôÿ( ?‹@Ò‚þßdéH@×ÕŸP‰@¨¹àYéH@ìZR yˆ@­* QéH@V¸'@û†@³:éH@  ½Ÿ¿…@’€éH@¦ðË„@ð^ÿ¿ûèH@¼£1 œƒ@. ÅèH@@@) ‚@7 ”èH@O¸²Ÿ €@m€gèH@›¹òó}@Jó`@èH@1°ÐÿY|@11 @+èH@?×çÿz@WJ  èH@ƒa Æu@`, èH@ Àæs@§éõèH@ñòS ?r@>E îçH@àì À3o@ö?ÀçH@ï#àOl@*öŸÎçH@ÙDE ‡j@¦ªù¿ÝçH@lÂÀ‰f@"MþèH@Ô'ûßøc@ú`(èH@ÐHßÿ"c@à?À2èH@3–<à²a@P üŸKèH@éâà~`@A§÷¿ièH@¡ø?—_@S–€ŒèH@è"Ï? _@°ö`´èH@N¾4 9^@«F ÀéH@!h7Àí]@‰8/éH@ ~¼_]@G~õŸRéH@ºù_\@etéH@Ðô+:Z@;ö?£éH@æÿÙ2X@`ªüßÏéH@ÀÖ[U@B€êH@™â?T@Á< ÌéH@öaÞ_S@ëù?¬éH@§¦ê?çQ@ªþ?éH@—Þå¿“P@žq ÀyéH@¯âÀ×O@%ÿ_qéH@Aæó O@É÷÷ßkéH@œÁß/N@ù@ú?jéH@¾„éÿEM@ª^àméH@Ë\*€sL@ŽÐ €uéH@N€þJ@S–€ŒéH@·ßNà¥I@PÊÿ?©éH@-×6 E@`, êH@¯8A@cC@þ 8êH@aà¬A@„]ûŸOêH@­A-@º@@ iÀWêH@IM7`Â>@Ÿ.ÿß`êH@Ø¿Â<@’˜û?bêH@÷ ÀÄ;@@«@`êH@ëXߟÖ9@™ UêH@ÌXý8@DsøÿLêH@; n7@sþ_7êH@'?5 Ö3@½ À÷éH@(’ U2@@«@àéH@»Rà®0@2p ÍéH@´ýñÃ/@eúÇéH@Sù?Ñ.@y-øŸÂéH@íG@à,@¢@¾éH@œÌ Àå)@W‰¿éH@PK9€ú&@. ÅéH@_€."@2àÔéH@2²¿G@2îþ_’éH@âH€¢@’Yÿß¿éH@óè°@¨ú_ÏéH@2.É¿ž@OüÿÕéH@qÛß—@¥®@ÔéH@ž° œ @½àÍéH@ó~³ÿÇ @©vúÿÀéH@lîè¹@Â÷•éH@“ôÿ&@‚:àvéH@1ÅOþ@ëo À?éH@D€ºú@¡»À!éH@hÍŸãõ@ù@ú?êèH@F+ Sò@†lÀËèH@n©A Lî@œ¡úÿŸèH@8…2àní@¦,™èH@`)ß~ë@†êÿèH@wóØ¿€è@à `èH@¸ †æ@5ùûÿ—èH@° I å@©7þŸžèH@ןH óã@wˆûŸ®èH@àC áÞ@òÄÿ_íèH@©_Ðß×â@þ±÷aéH@àãŸ[ä@¥üÿ“éH@l—ôÿÃä@4“û_¦éH@Ò‚þßdå@ ®û¿ÑéH@¨¹àÙå@¿X@êH@Ù*Úæ@qr`£êH@ÑÚÀ_Äå@k\ ëH@÷€å@+ðü?ZëH@›û/"ã@«ÜúŸ²ëH@ÿâ߈â@ð`ÙëH@¢¤ÙŸ8â@î’þìH@¿ÙA€gâ@y-øŸBìH@Ù¬Ÿ£â@hÏ@WìH@Å/ ÿâ@jtÿ?kìH@5M¯ÿä@ 0ìH@ºA@¡ä@°³ø›ìH@Éã@æ@Ó© ´ìH@ïõÿ»ç@Ð4ö_ÆìH@ÓÀ,@ï@œbþŸýìH@LÅñ@ý?9íH@µ$ö¿ò@ueàUíH@aR:`pô@Æ ‹íH@Â#;€÷@-VýßËíH@  ÀØõ@Ç‘÷?úíH@4ôëô@ÂcàîH@}²Þ–ô@¿îø.îH@]ˆÕaô@àö_BîH@¡:ÊPô@Œ‚WîH@xEð¿•ô@Å/ îH@ÝßÿCõ@lXøŸ¡îH@G' Ýö@sÿ@äîH@½‰Æ&÷@côõß÷îH@KÚ¿x÷@´¾õ!ïH@Kˆ$@n÷@.ûùß_ïH@à` ÷@P‹à†ïH@åØÕ?ãõ@q±ý¿ÅïH@¨z €·õ@?û¿ÕïH@cvý³õ@~†ý¿æïH@b¢Þßâõ@½ À÷ïH@“Â@>ö@%`ðH@GèÀºö@õù_ðH@GË?ø@ëù?,ðH@>ÀÅø@2-û¿4ðH@r/öŠú@ýrû?ðH@'æÍŸ>ÿ@> @LðH@‚bØ0@AàQðH@ØØÂü@»eÀcðH@zk&{@~Åù‰ðH@$`•@Cw€ÃðH@²AË_Æ @`éø?òðH@l«ÝŸ @ê‡àñH@úýî_Q @£`À5ñH@fëŸÐ @ ² @HñH@˜„°¿‘ @Èþ?oñH@´ @‰õ_ÊñH@Àê韷@ßWþßòH@ªrëÊ@g*@CòH@ázóŸ^@A§÷¿iòH@{9Ã?2@Þñý?”òH@f f@ÉaÔòH@D¯³ßâ@=ßýòH@_—á?Ý@ÉaTóH@™—Ë_„@žq ÀyóH@Ó~ï_î@•% £óH@ƒµ½¯@\÷#ôH@YìÄ$@ Àù?MôH@ÝòË?~@WÈ`aôH@N.l@¡@„ôH@ŸVÑš@Y ¤ôH@$s4`ó@»&`ÁôH@O¦<€f@û¦úßÛôH@6¡9€¸@Àý_ýôH@ RŸ#@!çýõH@„1@Ã@SÕüß.õH@N»ó-!@š~@GõH@aPÇßÍ!@cµùUõH@2¶ÿØ"@íS võH@3Àª@#@Zû_‰õH@Z'²ÿÏ#@ööß±õH@b/€×$@c7ÀöH@±ÉT š'@Ju  {öH@¯+ /)@ùþßÇöH@àj€x+@iMûÿ÷H@¦? Ø+@¿îø.÷H@<ú> \,@¹ø_W÷H@³MàŒ,@Y¬ú¿—÷H@‚¡ÔR,@®ÀÂ÷H@ŒÀÊ+@v àé÷H@N@º)@> @LøH@mÒáßo)@žûŸ‘øH@WJ  œ)@…ùŸºøH@Õ¤% Ó)@ÆV `ÎøH@FWñ_ƒ*@‘2ûŸðøH@˲Pÿ+@ó¬@ùH@„ðªÿZ/@úgþ9ùH@@ø0@> @LùH@L˜þ_T2@»eÀcùH@˜êÿâ2@IÌýqùH@ÑDЬ3@X° @ŽùH@À)æÿÙ3@’€ùH@Ñp±?Ü3@ëù?¬ùH@¶¸J V3@3 áùH@üLÅßY3@êH€ðùH@rER ‰3@Y àÿùH@1°ÐÿY4@zý`úH@ôÒœ5@÷\à3úH@ôýP@E7@¢úÿDúH@—Ç»Ÿ*9@P üŸKúH@rØ•@@èúüÿQúH@ ÞëÿwC@z€ïúH@,­ñ_AF@‡hø?UûH@-¬#`×G@fë à ûH@VMJ ©J@˜ñ`üH@ * `5L@G~õŸRüH@†<@ÿN@+±à·üH@q²Ë¿¯P@;ÐùßýH@YNÍQ@ÀTù¿ýH@ô¾Tà"S@Yëö:ýH@o°?¢T@ÌÃøOýH@ãôÜß,W@~†ý¿fýH@|NQ`ÇX@ ‹yýH@z ×Z@©7þŸžýH@”Ý?õ[@«… ½ýH@Ôüç3^@­¨ûßþH@ÞÆêN_@­6þH@Rï?&a@,™ÀdþH@Ç~ÜŸf@@A÷øýH@žä?îh@ëo À¿ýH@OÎÀi@‡)üß2ýH@&¿É_ïh@’€üH@mª ¶h@ötùÿ†ûH@põÖŸHh@vŒ %ûH@Z¼Ôß}g@ˆÀßúH@g‘Ôßže@âbû‹úH@Ü`êßÜd@LA à^úH@êÉ>ÀAd@fBþ_úH@Êr¯¤c@ƒ6÷_€ùH@z)éLc@Ýs€OùH@PÍ@Àµb@1ˆþ¿ ùH@;‘ýÞ`@b¹ÌøH@þà`@»ö?ŸøH@OÙ¬_@Èþ?oøH@OdÿŸ7_@Æ  øH@«Íßka@ìkú?É÷H@¿šE Eb@v@¥÷H@u€Ôb@…E€|÷H@0I`~c@Í“à(÷H@4Ã_öc@$³þ¿ÿöH@“ÿÉß½g@ ² @HöH@ç×ÿÎh@]`à'öH@<%R`"j@wIÿ? öH@+ €áj@_ƒøŸöH@8®Ò’l@>E îõH@à+ Vo@va÷_ßõH@…Ãû?Áp@ööß±õH@Dr*cq@; ’õH@æ€Àƒq@7à‚õH@2)€{q@‰¶ÀsõH@nü& Ëp@GèÀ:õH@àÀp@y—À*õH@ò„5áp@`õH@þÜ @'q@u€ õH@<Ìê_Šq@æ×@ùôH@4ý €Žr@O£ûÿÙôH@!¨ zt@›;ú_®ôH@úéÀôu@–‹À”ôH@DàH Áv@lÂÀ‰ôH@ˆæðÿ™w@¸™€€ôH@íÔ;`Gy@€tôH@I ú“}@bàaôH@‘ð½¿A@?û¿UôH@‚ú;€ê€@…Ãû?AôH@ Ûªk‚@K°ö'ôH@OMÕ΃@N|÷¿ ôH@ÿï%à…@íªöŸëóH@ÇI@І@BÎûÿ¸óH@ªó$Àˆ@Y àóH@àu‰@4<à0óH@åÄ쟆‹@Œ @óH@ó¿"àŒ@ƒ6÷_óH@Øñ_ @5ºÿŸõòH@¬¬ ` •@§S@èòH@ƒ3¶ßó–@Á ÝòH@Ñp±?Ü—@à~ ÕòH@&Ù4e™@{<À¾òH@7´T «š@?ü_¢òH@T;`ª›@.:ö?‚òH@g*@Ãœ@†lÀKòH@»ç Ÿ@÷³õ_)òH@ð‰€Áž@`, òH@Ž'þÿjŸ@œbþŸýñH@:~âßë @6 @çñH@¯9@Í¡@Þþ¿ÞñH@š’îߣ£@#ËößÒñH@"d(@w¦@ÝÊùÿÄñH@)NAÀR¨@Ì-@·ñH@Ãv €ª@¡»À¡ñH@8Z ©«@(ø¿†ñH@Ò«¿-­@*ŠüŸhñH@ößÖY¯@þ 8ñH@ª3免@nåüâðH@vuàÿ;´@11 @«ðH@ •Í¼µ@ƒ÷úÿ]ðH@uv®ÿ¥¶@¸ À;ðH@ À&k`ü@± ƒÙH@J‰ò?Ø@@ê ‚òH@5º;¾ÿ‡†@Ô‘ aïH@Ë×Õ†@ðà7ïH@)!»ê‹@­6ïH@­Ùÿç@ïõÿ;ïH@ õ áŽ@>]þ¿AïH@PvL@À@2àTïH@/ @q’@bø`nïH@‘ˆ! ü“@›üýÿ‹ïH@)áð^•@Ý4 ­ïH@¸ †–@èúüÿÑïH@Ó0àú–@ æïH@V¡ý’—@; ðH@9Qà×—@&@ @ðH@;»B@:˜@sÿ@äðH@ÄGþ?Ò˜@Jùÿ'ñH@ŽRÀ0™@Roü?=ñH@æi韚@ Hû`ñH@‹Å àoœ@ñûžñH@Áúÿž@0 \ñH@Œ0 rŸ@+±à7ñH@ý ºÿÀŸ@\÷#ñH@¢é¿  @ŒÁý_ùðH@‚ ²Ÿ¤ @->ÀxðH@ªGØ¿¡@IÀNðH@¾qÎ_S¡@58ø_:ðH@W‰¿¡@©@&ðH@H:ÀÏ¢@”æÀðH@Aý@u¦@+r€•ïH@-Jàb§@QHøÿmïH@q é§@~G`DïH@Ð5@'¨@‚y@ïH@$qÁßP¨@Y àîH@–ËÊ¡¨@Ǽ @îH@¢6»ÿÙ¨@´g +îH@?D8 „©@äq îH@¨Lµ?åª@fÀöÛíH@JôÏ_*®@ï¹ÀçíH@›BÓ²@\!€îH@ÌÀ·ŸB´@zTüßîH@éó¬ÿε@Èyÿ'îH@/yòŸ$·@àö_BîH@à&Ä@jò÷ÿ¯ïH@Ê‹LÀ¯Å@Jùÿ§ïH@VNÀ†Æ@»ö?ŸïH@÷ŠU È@‹[ý¿‡ïH@!ü´cÉ@"ÀkïH@BŽ1 ¬Î@êH€ðîH@"P? Ð@û €ÔîH@tÐãÿ§Ñ@óë ¼îH@ "@]Ó@´à«îH@ 'Õ@6¢€¢îH@=±±¿ªÚ@+r€•îH@PøS€{Ü@Ðö¿ŽîH@@l à=Þ@@ê ‚îH@ÇÔŸõß@òÄÿ_mîH@J †á@G~õŸRîH@–w ¸ã@v@%îH@ÌÃøOé@ZU@¢íH@ì™N€›ì@‹ÙõLíH@ÓÀ,@ï@œbþŸýìH@ïõÿ»ç@Ð4ö_ÆìH@Éã@æ@Ó© ´ìH@ºA@¡ä@°³ø›ìH@5M¯ÿä@ 0ìH@Å/ ÿâ@jtÿ?kìH@Ù¬Ÿ£â@hÏ@WìH@¿ÙA€gâ@y-øŸBìH@¢¤ÙŸ8â@î’þìH@ÿâ߈â@ð`ÙëH@›û/"ã@«ÜúŸ²ëH@÷€å@+ðü?ZëH@ÑÚÀ_Äå@k\ ëH@Ù*Úæ@qr`£êH@¨¹àÙå@¿X@êH@Ò‚þßdå@ ®û¿ÑéH@l—ôÿÃä@4“û_¦éH@àãŸ[ä@¥üÿ“éH@©_Ðß×â@þ±÷aéH@àC áÞ@òÄÿ_íèH@ןH óã@wˆûŸ®èH@° I å@©7þŸžèH@¸ †æ@5ùûÿ—èH@wóØ¿€è@à `èH@`)ß~ë@†êÿèH@8…2àní@¦,™èH@n©A Lî@œ¡úÿŸèH@F+ Sò@†lÀËèH@hÍŸãõ@ù@ú?êèH@D€ºú@¡»À!éH@1ÅOþ@ëo À?éH@“ôÿ&@‚:àvéH@lîè¹@Â÷•éH@ó~³ÿÇ @©vúÿÀéH@ž° œ @½àÍéH@qÛß—@¥®@ÔéH@2.É¿ž@OüÿÕéH@óè°@¨ú_ÏéH@âH€¢@’Yÿß¿éH@2²¿G@2îþ_’éH@—3>@µ@MþþÿEéH@ÎdæŸl@¥üÿéH@ï>àä@SW êèH@e„;@Å@(åÿŸÔèH@ Á`Ä@÷³õ_©èH@WîŸ@éâà~èH@ ÄŸÙ@ìý_XèH@þÝà@¨z €7èH@×Ç`¬@>E îçH@:g¸¿‚@›zö¿ÐçH@ÑÚÀ_Ä@Jó`ÀçH@J‰ò?Ø@О€®çH@‡|áß±@WJ  œçH@ô“A ]@úöŸŒçH@=ö/ æ@×2ø~çH@Ž¥ö¿¯@ZÓþÿfçH@ë3Nà)@ueàUçH@Oº% Ã@x1 9çH@ BP @•% #çH@p À?¥@Ju  ûæH@-VýßK@rZ @ÐæH@g;®_@ZU@¢æH@×´ÿ¿¹ @ ÀæH@€П‘ @”§`^æH@u  @ñ…KæH@ S  @ ÷_!æH@¦¿°_$ @@«@àåH@è» / @ötùÿ†åH@ïv÷ßÎ @ÇÔ åH@E `@ÓÁú?åH@LBØßÈ@êŸùÿåäH@H @¹ø_×äH@KÅ­îü@<¸À­äH@¾¯ü¿ û@\÷£äH@¤ßßù@ý3ÿ¿œäH@Ù°_¨ö@@«@`äH@HåÃ?®õ@ ÿ¿=äH@>³$@Mõ@Ó÷Ÿ)äH@„qä?¬ô@v àéãH@e™òß‹ô@æU¾ãH@È#ÙŸ›ô@V¡ý’ãH@¾EíŸ#õ@ ®û¿QãH@ƒû¿òõ@dÀ)ãH@Ìî à÷@ßWþßãH@á%ƒù@. ÅâH@Ÿ-1àvú@ô¨ø¿£âH@‰tÃßÄú@÷€‘âH@bàáú@œbþŸ}âH@by> ¿ú@š½ iâH@«)kú@hÏ@WâH@²„Ö?_ù@7G€6âH@Ôÿ( ?÷@¾¯ü¿ âH@Þ† Âô@N=û_èáH@’¬äß>ñ@¶µ ÊáH@ˆæðÿ™ï@Š4ù¸áH@¢·ô?+î@Šž  áH@3þØøì@@ê ‚áH@·I ì@$t`]áH@¯âÀ×ë@j5àHáH@ÖâSŒë@&@áH@:¾¬?xë@–L`òàH@ƒŒà‹ë@§ àÅàH@,Ø ì@r™ ràH@SIàÅí@ ÿ¿=àH@× Ïñ@†lÀËßH@(OÀ¼ò@,€©ßH@—+€ïó@"ÀkßH@ç꿵ô@ñ…KßH@CÊìÂõ@PÊÿ?)ßH@¢P& Où@RÀÇÞH@/d;^ú@|ùøߥÞH@/yòŸ$û@È:À„ÞH@/ÎJ Fü@˜€FÞH@Ë™³_óý@Y àÿÝH@úØÿ­þ@œ#@ÛÝH@s+çÿÿ@58ø_ºÝH@…²S qÿ@À¾à‡ÝH@d Bàý@¶µ JÝH@bwËü@'ý÷¿'ÝH@iŒ÷_¾û@¥üÿÝH@ëH`9û@Ê ëÜH@šÀB vú@Y¬ú¿—ÜH@gá_Âø@¿ÀÜH@@TÀjô@Y $ÜH@'+Lzñ@dÀ)ÜH@ãß%@fî@C4üŸ*ÜH@éû_dì@ocõ?'ÜH@Ä3 uê@&@ÜH@³ëÿ˜é@}_ùÜH@ËïÙß~å@2¯ðÛH@ïÀ¢ã@ æÛH@ìý_ØÞ@pKýÔÛH@Ù—* Ý@Z” ÄÛH@‰Í*à\Û@ôQ@®ÛH@\ãØÍÙ@[»à“ÛH@Eð"À§Ñ@Èþ?ïÚH@Êßÿ¿˜Î@OdÿŸ·ÚH@5Œ«_#Ì@fBþ_–ÚH@º¨ |É@Å/ ÚH@ý ºÿÀÇ@9+ýßlÚH@­* QÅ@ùþßGÚH@ªaC`zÁ@lü?ÿÙH@%·?z»@± ƒÙH@° g·@WÈ`áÙH@Oöàÿر@¶Šö_ÚH@À¨¬¿ˆ®@dÀ)ÚH@b‹´¿yª@5ºÿŸuÚH@P¢-ð¤@j àÛH@g«?€¢@Ý4 -ÛH@¢"Ò_}ž@Í)ù¿@ÛH@›8¹ß¡œ@à@ÛH@Ia ™@è» /ÛH@?<@b‘@¨¹àÙÚH@oâ»ÿUŒ@SÕüß®ÚH@÷‡ ùŽ@Ò‚þßäÚH@¨ú_χ@÷³õ_©ÛH@”çÑ¿ê@z€oÜH@‹·ßëy@Â÷ÝH@?²_q@Äà/ÝH@Ù®T@oh@Á{ýÿîÜH@ц `Ûd@¥®@ÔÜH@ ÀæS@¢9üæÜH@׿ëS@°tüùÜH@m¬?üS@Ì-@7ÝH@8°E 4O@†øŸcßH@!Q  „N@;Ðù߀ßH@0aúQ-@'¾û_åH@÷òñ¿K+@IN`,åH@+r€•!@¹V÷ŸçåH@±EÚßïH@ÑR`ž@v"ûÿ<ïH@'Ó²ÿK@ìý_XïH@n¦ @!@š? à$ðH@„HD‰!@wˆûŸ.ðH@9ªÃŸ!@Âùõ¿3ðH@àÀ @£ŸüXðH@2„ï?*$@¥ý¿IðH@|ø*à;%@"Ï`IðH@„ài'@lXøŸ!ðH@72@ý&@j5àHðH@Þð/@ª*@µüŸGðH@Ì@ã0@»¼÷?YðH@3ÑŸË2@ü ûMðH@o`´¿š4@ó€2ðH@Éö)à6@ç|@ ðH@…›)8@gçú_ªïH@€?ã_W9@Oâ÷_|ïH@!S€ ;@Ù@XïH@™kêŸT=@Í)ù¿@ïH@EX¿_í@@x1 9ïH@çR¿±N@LA à^ïH@8Z ©S@×2ø~ïH@/7µ¿õU@Þš ÀžïH@5³ŸÞW@ùþßÇïH@E `\@·±úŸSðH@–´ñb@Ô‘ añH@‘ú_li@7àòH@‘Ä?*m@@ê ‚òH@° íÿt@òÄÿ_íñH@¼8TJw@ã¡÷ß­ñH@#ö  y@ð^ÿ¿{ñH@–‹Àz@Ù@XñH@%ñ, 8{@N€ñH@Ç'è|@ëDöÿùðH@¬‚ÅŸ°}@ùþßÇðH@ú`¨€@¦í vðH@Ì*Ç¿*‚@ŠÝCðH@ ÿÜŸ¤ƒ@Ymþ_õïH@5Îè?R…@­ëÀ®ïH@”&Î †@ïøþŠïH@º;¾ÿ‡†@Ô‘ aïH@HOdÿŸ7_@òÄÿ_mïH@s•öüô@ ‹ùýH@¦ŠKÀu†@=ß}üH@“*ÝŸƒ‰@($üÿvüH@° ÝߨŽ@côõßwüH@0‹?@­@œbþŸ}üH@Áúÿ’@Zû_‰üH@ßCp”@ngÀüH@†¬ÑX™@‘ú_ìüH@"C@ø›@/ãÀ ýH@?¯ÀÖ@L÷ýH@ÔUO Ëž@3— àýH@2®¿Ÿ@ú¿›üH@ÆÍ @§’  ûH@Vž¼Ÿ…¦@ç|@ ûH@êtæ? §@iMûÿúH@öȬÿï³@é!@!úH@Wˆ7U³@hQ €ûH@ÇþGàî¬@(gàûH@ (åÿŸ¬@ ˆûH@þí®@~Åù‰ûH@k›€:°@µO €XûH@È1€K·@Ú§@ìúH@§éõ€¹@‘ú_lûH@_o$¼@9nÀüH@¤pÚßÃ@ ®û¿QüH@w€ÜÇ@ÚhàÉûH@ñ·]È@!  ÷úH@) à#Ë@va÷__úH@8ùŸÐ@o À1úH@ΠíÕ@‰8/úH@JªßÚ@Ý4 -úH@€ë/`nà@¨ú_ÏùH@x\àþã@ötùÿùH@½‰Æ&ç@†øŸcøH@x˜Õ¿ç@zý`œ÷H@˜Ã¬´å@ëDöÿùöH@i"è?Öå@¤Æ`'öH@¨Lµ?åæ@N€öH@¡= ]í@*ŠüŸèõH@.þ:`ìï@²Úü¿jõH@n©A Lî@êŸùÿåôH@ÞÜF Mì@]ÞûŸlôH@¢{9`ï@N§ €ÐóH@•ŒÎ¿~ô@2îþ_óH@e­Ûèò@ˆÀßòH@ñÇ@àyð@4<à°òH@|‹Ú?Gò@o À±òH@•’PÀ—ò@ý?9òH@L¬çÿ°ô@N@:òH@s•öüô@¹ÀÀÏñH@¼uÝßÉð@ø€àñH@Á’' Xë@Ú§@ìñH@Üc+`éå@IÌýññH@Ó÷Ÿ©á@‘ú_ìñH@o°?¢à@N=û_èñH@ jÓ¿ÁÞ@û¦úßÛñH@" §Ú@LY²ñH@6   ×@N%@•ñH@ÏßßûÒ@*ŠüŸhñH@|5´¿»Î@ö?@ñH@“Ô¶øÍ@JJöß5ñH@éÕß–Ì@WJ  ñH@ V9@rË@ûåö?þðH@©¼_ýÊ@òÄÿ_íðH@Û½?RÊ@ˆÎøßÆðH@_¿_/É@€• àbðH@ÿWÂ_È@^à;ðH@I÷à6Ç@Y¬ú¿ðH@yÙD ÙÅ@”=ø?öïH@Š^>@”Ã@µüŸÇïH@ˆúÙŸöÁ@üÍþ«ïH@¤ž. î½@òÄÿ_mïH@uv®ÿ¥¶@¸ À;ðH@ •Í¼µ@ƒ÷úÿ]ðH@vuàÿ;´@11 @«ðH@ª3免@nåüâðH@ößÖY¯@þ 8ñH@Ò«¿-­@*ŠüŸhñH@8Z ©«@(ø¿†ñH@Ãv €ª@¡»À¡ñH@)NAÀR¨@Ì-@·ñH@"d(@w¦@ÝÊùÿÄñH@š’îߣ£@#ËößÒñH@¯9@Í¡@Þþ¿ÞñH@:~âßë @6 @çñH@Ž'þÿjŸ@œbþŸýñH@ð‰€Áž@`, òH@»ç Ÿ@÷³õ_)òH@g*@Ãœ@†lÀKòH@T;`ª›@.:ö?‚òH@7´T «š@?ü_¢òH@&Ù4e™@{<À¾òH@Ñp±?Ü—@à~ ÕòH@ƒ3¶ßó–@Á ÝòH@¬¬ ` •@§S@èòH@Øñ_ @5ºÿŸõòH@ó¿"àŒ@ƒ6÷_óH@åÄ쟆‹@Œ @óH@àu‰@4<à0óH@ªó$Àˆ@Y àóH@ÇI@І@BÎûÿ¸óH@ÿï%à…@íªöŸëóH@OMÕ΃@N|÷¿ ôH@ Ûªk‚@K°ö'ôH@‚ú;€ê€@…Ãû?AôH@‘ð½¿A@?û¿UôH@I ú“}@bàaôH@íÔ;`Gy@€tôH@ˆæðÿ™w@¸™€€ôH@DàH Áv@lÂÀ‰ôH@úéÀôu@–‹À”ôH@!¨ zt@›;ú_®ôH@4ý €Žr@O£ûÿÙôH@<Ìê_Šq@æ×@ùôH@þÜ @'q@u€ õH@ò„5áp@`õH@àÀp@y—À*õH@nü& Ëp@GèÀ:õH@2)€{q@‰¶ÀsõH@æ€Àƒq@7à‚õH@Dr*cq@; ’õH@…Ãû?Áp@ööß±õH@à+ Vo@va÷_ßõH@8®Ò’l@>E îõH@+ €áj@_ƒøŸöH@<%R`"j@wIÿ? öH@ç×ÿÎh@]`à'öH@“ÿÉß½g@ ² @HöH@4Ã_öc@$³þ¿ÿöH@0I`~c@Í“à(÷H@u€Ôb@…E€|÷H@¿šE Eb@v@¥÷H@«Íßka@ìkú?É÷H@OdÿŸ7_@Æ  øH@OÙ¬_@Èþ?oøH@þà`@»ö?ŸøH@;‘ýÞ`@b¹ÌøH@PÍ@Àµb@1ˆþ¿ ùH@z)éLc@Ýs€OùH@Êr¯¤c@ƒ6÷_€ùH@êÉ>ÀAd@fBþ_úH@Ü`êßÜd@LA à^úH@g‘Ôßže@âbû‹úH@Z¼Ôß}g@ˆÀßúH@põÖŸHh@vŒ %ûH@mª ¶h@ötùÿ†ûH@&¿É_ïh@’€üH@OÎÀi@‡)üß2ýH@žä?îh@ëo À¿ýH@%@àýl@š½ éýH@°ßÙ?Ën@Ymþ_õýH@Õû Éo@->ÀøýH@ £þÌr@ ‹ùýH@Ö¡äÇt@µåù_ðýH@óë ¼u@ƒ €èýH@‘èߪv@Ü àÝýH@nRM Wx@UzùßÂýH@(ÌÿÔy@;ö?£ýH@q±¿.{@_ƒøŸ€ýH@Bcàæ|@ìkú?IýH@šÃÿg~@Àý_ýüH@xĶD@¨¹àÙüH@×I" g€@GèÀºüH@ÁêŸ@èà¬üH@b:B@‚@+r€•üH@1ïÌ_|„@9nÀ…üH@ŠKÀu†@=ß}üH@ xèàÿù@œbþŸýìH@ŒÀÊ;@©@¦I@l®| fé@û €TI@åØÕ?ãí@2¯ðI@—vI Ní@˜0ý¿¨I@Ò‚þßdí@*ŠüŸhI@(ÌÿÔí@»&`AI@ÌUÚðï@– ÐI@{¦à&õ@;ö?£I@’ÄÜÿ÷@²Â —I@çз?öú@Kqú…I@ßàÕü@@A÷xI@Ëè@àÕöŸJI@áåп°@;R <I@GRà¢@cvý3I@„ÈØ¿¡ @6¢€"I@œKÔ” @5ùûÿI@o$ùß„ @ÎPýÿI@àéß?@Â$ €ùI@ãàó?Ð@Ê]øÝI@*Æ·~@î÷?]I@íS ö@9Cõÿ?I@’‡S ’@ 'I@|·»ÿv@N€I@YÚNj@#ö  I@‘†®ŸY@ŠõüI@&HÀ*@…„ÿßI@ý3ÿ¿#@F‚ II@Ü‹ýŸ¢&@‡ @iI@â&@ u)@·úI@–öÝßf.@|ùøߥI@²0#@v0@©à ©I@À¾à‡3@©@¦I@J †5@Þš ÀžI@½wP`l7@?„‘I@w²?õ8@ – ~I@àÿ;`&;@裀\I@©#Â;@bø`îÿH@ŒÀÊ;@ö«ÿH@J´ž;@$³þ¿ÿH@¼ 2;@à~ UÿH@,–Ç?Ø:@&@ @ÿH@_Dü?^:@ï7û,ÿH@gçú_*9@êÞõ_ÿH@¼â-€¾7@ËèþH@ÑG ,6@ñ…ËþH@¸µ¿’3@ §þH@|¢`°1@¦,™þH@†øŸã,@êÞõ_ˆþH@=Œ þ*@x¯ÿß}þH@•å5À)@/¤`jþH@7Š`O'@ÑÝàPþH@k˜Âÿ-#@KqúþH@ØAà7 @»&`ÁýH@rÙÏÿþ@æ ›ýH@;}à@ötùÿ†ýH@ô¨ø¿#@f qýH@aà¬@îz`EýH@†¿ì¿J@eZöéüH@ ýŸ@¿X@üH@>‡C€@Sù?ÑûH@ˆü¤@·3àŽûH@vÔs@qðùhûH@ÓjÀ‘@è HûH@/Ìן£!@M¿ #ûH@¼M  $@êÞõ_ûH@¹‚Ø_—%@‰¶ÀóúH@è<:à€'@‰õ_ÊúH@Ë\*€s(@à–ú?¨úH@ÈOº_Ë(@U `”úH@È ¯2)@ç=àjúH@ÅíÈ?Ð)@Ÿï€¾ùH@½5€=*@ÅÅöÿ–ùH@˲Pÿ+@ó¬@ùH@FWñ_ƒ*@‘2ûŸðøH@Õ¤% Ó)@ÆV `ÎøH@WJ  œ)@…ùŸºøH@mÒáßo)@žûŸ‘øH@N@º)@> @LøH@ŒÀÊ+@v àé÷H@‚¡ÔR,@®ÀÂ÷H@³MàŒ,@Y¬ú¿—÷H@<ú> \,@¹ø_W÷H@¦? Ø+@¿îø.÷H@àj€x+@iMûÿ÷H@¯+ /)@ùþßÇöH@±ÉT š'@Ju  {öH@b/€×$@c7ÀöH@Z'²ÿÏ#@ööß±õH@3Àª@#@Zû_‰õH@2¶ÿØ"@íS võH@aPÇßÍ!@cµùUõH@N»ó-!@š~@GõH@„1@Ã@SÕüß.õH@ RŸ#@!çýõH@6¡9€¸@Àý_ýôH@O¦<€f@û¦úßÛôH@$s4`ó@»&`ÁôH@ŸVÑš@Y ¤ôH@N.l@¡@„ôH@ÝòË?~@WÈ`aôH@YìÄ$@ Àù?MôH@ƒµ½¯@\÷#ôH@Ó~ï_î@•% £óH@™—Ë_„@žq ÀyóH@_—á?Ý@ÉaTóH@D¯³ßâ@=ßýòH@f f@ÉaÔòH@{9Ã?2@Þñý?”òH@ázóŸ^@A§÷¿iòH@ªrëÊ@g*@CòH@Àê韷@ßWþßòH@´ @‰õ_ÊñH@˜„°¿‘ @Èþ?oñH@fëŸÐ @ ² @HñH@úýî_Q @£`À5ñH@l«ÝŸ @ê‡àñH@²AË_Æ @`éø?òðH@$`•@Cw€ÃðH@zk&{@~Åù‰ðH@ØØÂü@»eÀcðH@‚bØ0@AàQðH@'æÍŸ>ÿ@> @LðH@r/öŠú@ýrû?ðH@>ÀÅø@2-û¿4ðH@GË?ø@ëù?,ðH@GèÀºö@õù_ðH@“Â@>ö@%`ðH@b¢Þßâõ@½ À÷ïH@cvý³õ@~†ý¿æïH@¨z €·õ@?û¿ÕïH@åØÕ?ãõ@q±ý¿ÅïH@à` ÷@P‹à†ïH@Kˆ$@n÷@.ûùß_ïH@KÚ¿x÷@´¾õ!ïH@½‰Æ&÷@côõß÷îH@G' Ýö@sÿ@äîH@ÝßÿCõ@lXøŸ¡îH@xEð¿•ô@Å/ îH@¡:ÊPô@Œ‚WîH@]ˆÕaô@àö_BîH@}²Þ–ô@¿îø.îH@4ôëô@ÂcàîH@  ÀØõ@Ç‘÷?úíH@Â#;€÷@-VýßËíH@aR:`pô@Æ ‹íH@µ$ö¿ò@ueàUíH@LÅñ@ý?9íH@ÓÀ,@ï@œbþŸýìH@ì™N€›ì@‹ÙõLíH@ÌÃøOé@ZU@¢íH@–w ¸ã@v@%îH@J †á@G~õŸRîH@ÇÔŸõß@òÄÿ_mîH@@l à=Þ@@ê ‚îH@PøS€{Ü@Ðö¿ŽîH@=±±¿ªÚ@+r€•îH@ 'Õ@6¢€¢îH@ "@]Ó@´à«îH@tÐãÿ§Ñ@óë ¼îH@"P? Ð@û €ÔîH@BŽ1 ¬Î@êH€ðîH@!ü´cÉ@"ÀkïH@÷ŠU È@‹[ý¿‡ïH@VNÀ†Æ@»ö?ŸïH@Ê‹LÀ¯Å@Jùÿ§ïH@™™>à&Ä@jò÷ÿ¯ïH@fBþ_–Â@/"þ¯ïH@q$@ÑÁ@Uä«ïH@X½?÷À@•% £ïH@âÏK €¿@¬¬ `ŒïH@‰Êé_P¾@÷Þ oïH@ïõ½Ÿ}½@– PïH@ånÆû»@ ‡÷ïH@Yî7 Æ¹@èà¬îH@ÀxðH@¢é¿  @ŒÁý_ùðH@ý ºÿÀŸ@\÷#ñH@Œ0 rŸ@+±à7ñH@Áúÿž@0 \ñH@‹Å àoœ@ñûžñH@æi韚@ Hû`ñH@ŽRÀ0™@Roü?=ñH@ÄGþ?Ò˜@Jùÿ'ñH@;»B@:˜@sÿ@äðH@9Qà×—@&@ @ðH@V¡ý’—@; ðH@Ó0àú–@ æïH@¸ †–@èúüÿÑïH@)áð^•@Ý4 ­ïH@‘ˆ! ü“@›üýÿ‹ïH@/ @q’@bø`nïH@PvL@À@2àTïH@ õ áŽ@>]þ¿AïH@­Ùÿç@ïõÿ;ïH@)!»ê‹@­6ïH@Ë×Õ†@ðà7ïH@º;¾ÿ‡†@Ô‘ aïH@”&Î †@ïøþŠïH@5Îè?R…@­ëÀ®ïH@ ÿÜŸ¤ƒ@Ymþ_õïH@Ì*Ç¿*‚@ŠÝCðH@ú`¨€@¦í vðH@¬‚ÅŸ°}@ùþßÇðH@Ç'è|@ëDöÿùðH@%ñ, 8{@N€ñH@–‹Àz@Ù@XñH@#ö  y@ð^ÿ¿{ñH@¼8TJw@ã¡÷ß­ñH@° íÿt@òÄÿ_íñH@‘Ä?*m@@ê ‚òH@‘ú_li@7àòH@–´ñb@Ô‘ añH@E `\@·±úŸSðH@5³ŸÞW@ùþßÇïH@/7µ¿õU@Þš ÀžïH@8Z ©S@×2ø~ïH@çR¿±N@LA à^ïH@EX¿_í@@x1 9ïH@™kêŸT=@Í)ù¿@ïH@!S€ ;@Ù@XïH@€?ã_W9@Oâ÷_|ïH@…›)8@gçú_ªïH@Éö)à6@ç|@ ðH@o`´¿š4@ó€2ðH@3ÑŸË2@ü ûMðH@Ì@ã0@»¼÷?YðH@Þð/@ª*@µüŸGðH@72@ý&@j5àHðH@ÑÝàÐ&@8†àXðH@I"$ ü$@)Í€ñH@;ç#j@GèÀºñH@ìØJà½@¨¹àYòH@oLË>@côõßwòH@€+ú¿úú@ÌúÿþòH@Š æ¿rú@F‚ IóH@tz½ú@@A÷xóH@èàÿù@‹[ý¿‡óH@`Á&9ü@ùÿÈóH@•düÅ@iö€¦ôH@“ƒD  @Häõ?ÄôH@¥Úéÿ@ ÿ¿½õH@ÔR ¾@ؘøðõH@Üa¸ßF@O£ûÿYöH@{Ý¿@ø›ý?V÷H@¾Ú€Ñ@©7þŸøH@9nÀ@ÍhõãøH@i 1 @¯Møß©ùH@ùk °@VbÀïùH@üyK Â@°5ÀÖúH@’ôˆ*@÷Þ ïúH@Ù•·Ÿc.@É÷÷ßkûH@²—ñßQ1@ˆÀ_ûH@'Tì?4@èúüÿQûH@EÃÿÊ4@N§ €PûH@;Q3 R>@¡|`ÿúH@WI; 2C@éâà~ûH@e„;@ÅC@bŽõ?üH@ XÕ?FD@Àý_}üH@âcÉõN@ï7û¬üH@X7 :O@UöŸ­üH@{g€Y@pô ÞüH@| €˜_@’ànýH@²lÞŒ_@G' ÝýH@¨¥@}_@ð`YþH@²/[@ýµØþH@MT%€Q\@×óûÜþH@ü7@“^@pô ÞþH@YØßéh@Ìl ÙþH@£]¿?)k@$t`ÝþH@áçC@Sm@ï¹ÀçþH@>\0ÀWo@€+ú¿úþH@IúQ`Ct@x1 9ÿH@&Ù4eu@wÇ÷ÿPÿH@: ]w@ötùÿ†ÿH@ A€Óx@ngÀÿH@k[9 ®y@dÜý¿¤ÿH@9WÞŸœz@ocõ?§ÿH@§’ Š{@¬Bû?¤ÿH@~†ý¿f|@3— àœÿH@›¦×‚@Å­þßCÿH@MªK݃@Vàù4ÿH@Éx1 ½…@Û%ýÿ0ÿH@Ë1À­†@cvý3ÿH@óè°ˆ@&@ @ÿH@öaÞ_@—Hõß{ÿH@}³¬“@v@¥ÿH@Ia •@žF÷ÿ³ÿH@G€€˜@óë ¼ÿH@’Yÿß¿ž@Êü»ÿH@µ¿³¡@WÈ`áÿH@¬W²ßê£@o$ùßI@)ÊÆÿô¥@SÕüß.I@J´ž§@Þþ¿^I@Ò `¨@‘2ûŸpI@œKÔ”¨@fBþ_–I@jq¾¿Þ¨@.¼ý½I@œ"4@q©@°ö`4I@ù—î¿ß©@=   ZI@M:€4ª@9+ýßlI@Ù¬Ÿ£ª@ – ~I@g'Å¿¶«@,nõÿžI@¬× Ò®@ƒ €èI@yo5€ñ¯@ötùÿI@À_i°@²Â I@%¬®¿ü°@0Ë  9I@±Þ±@ã‰ÿ¿ZI@¥Úéÿ±@^õ_kI@!¨ z°@|cŽI@AÍŸ€¯@/"þ¯I@ ”ÿR«@pÉõßI@òÛ)€Öª@,€)I@¢¤ÙŸ8ª@b¹LI@ý O`ª@˜®õmI@Á|ËÿXª@“€ I@ÕøØŸ¼ª@Ån€¡I@ˆdé¿Þ«@Jó`ÀI@‚¤_­@WößÖI@ÓéÌ@®@ƒ÷úÿÝI@FØ* Ô¯@¶KúÿáI@?•ªa±@Åð ÀÜI@1Û㿲@WößÖI@:¿QÀ°³@À“õÂI@Å°?`¸@’˜û?bI@Z@O Û¹@˜oùKI@¦+3¯º@öö@BI@ˆÏÆß0¼@0Ë  9I@óë ¼½@›äà8I@_ƒøŸ€¾@¦ký_;I@ˆÏÆß0À@/e HI@å˜ àVÃ@ù@ú?jI@Ò—µ+Æ@7à‚I@™l¸Ÿ¾Ç@–‹À”I@ûz ,Ê@¦ký_»I@¢CàHÐ@«ÜúŸ2I@Ã_ö_¥Ò@G' ]I@‹†€MÔ@É `vI@þÙÉ¿Ø@©@¦I@ì¿­?²Ú@òü¿I@ÍÎ?Mß@å.ü¿nI@¦ØM0à@1÷eI@˜Ã¬´á@ÆV `NI@´è:àüâ@o À1I@ì@çä@åmøI@Æ ‹å@Ð4ö_ÆI@‹×?üæ@¥üÿ“I@®| fé@û €TI@èWÜêÿ=ø@‘q÷ÿ’ÜH@KÅ­î@ÑÝàPíH@úLBØßÈŠ@ô¨ø¿#ëH@ø„Óí@&—÷¶êH@YK`Œ@õx€}êH@ÿEL`¥”@ל æéH@ºU) ý–@É÷÷ßkéH@ÆB!Àñž@ ÓûßôèH@Ó•€W©@Êü»èH@´ ,³@Y¬ú¿—èH@;}àº@ìý_XèH@‚Ìç?Æ@Dÿ_PèH@¤³å¿´Ê@; èH@Ƭ0àÙÌ@ÅÅöÿèH@œy(ÀfÏ@‡hø?UèH@ Á`Ä×@ ÷_!éH@½¿?kã@BÎûÿ8éH@Fý?˜é@-VýßËèH@â¤8`ºé@U;ý èH@ˆúÙŸöé@G~õŸRèH@@Ö&ð@1÷åçH@àÕöŸÊû@äÈûýçH@˜±6ú@ÎPýÿçH@»Ý?X@èxõ¿çH@ý6@@)@6¢€"çH@së ‡@PÊÿ?©æH@HÍËÛ @Ç‘÷?úæH@¹.%`® @›zö¿ÐæH@ASDÀ@ïÀ"çH@*‡»\@dÜý¿¤çH@EX¿_í@m¾ø?èH@²ù @Ûæ èH@KÅ­î@lü?çH@cåŸ2@×´ÿ¿¹æH@§È_9@<6úòåH@'¯_n @wˆûŸ®åH@ìì3€@´¾õ!åH@Ãsßÿ @˜€ÆäH@:2 (@0I`~äH@/µ­:@ÿøÓãH@ àœ@>E îâH@ Âä_.@Ê kâH@!Q  „@¨¹àYâH@}¡6`F@Jó`ÀáH@ 7 |@]`à'áH@´ÒÞ¿ý @^ ÒàH@ÊIà€@ÜL@€àH@ÕÐ`@‘óþ?ÎßH@¾Úß]@4TÿÿßH@z ×@Äõÿ\ÞH@â @Õ @7 ÞH@R0à@Žfú_ ÞH@Íáÿ3ÿ@Žfú_ ÞH@¹ÑÜý@Žfú_ ÞH@‰ õ?éý@õx€ýÝH@P߶ßo@›;ú_®ÝH@[ú@6@Í“à¨ÝH@) í€ý@/"þ¯ÝH@í(ï_0ú@ÝÊùÿÄÝH@o Ï¿ê@ W@\ÞH@+ƒ¬Ÿåæ@²Úü¿jÞH@¡¾D@®â@Æìú?fÞH@„Ÿ8€~Û@²Xõ¯ÞH@Ãõæ?½Ô@ëDöÿùÞH@åNÀáÓ@;ÐùßßH@äò@àXÒ@,Ø ßH@·ïÉÐ@ßWþßßH@½`&@Ð@d`ßH@;Q3 RÎ@`éø?òÞH@±s. Ì@*öŸÎÞH@‚e <É@¿X@–ÞH@‚vÁ¿ŒÆ@sVú¿YÞH@§½`PÅ@Yëö:ÞH@¾ñ9 :Ä@‚y@ÞH@ïL²sÃ@ŒÁý_ùÝH@t”( ’Â@Á< ÌÝH@_Ö¼Á@`k€­ÝH@1ܱ¿‰À@(gàÝH@-¬#`׿@à úÿ‚ÝH@UR@=¾@ âúnÝH@IxJ ˆ¼@éû_dÝH@6Žàź@bàaÝH@A=蟹@æ eÝH@ËñL`!¸@_íÀhÝH@¼aô?m¶@5ºÿŸuÝH@³Ꟗµ@$³þ¿ÝH@ØÀδ@âbû‹ÝH@—3€\³@iö€¦ÝH@¢áÿT±@È€ÓÝH@×´ÿ¿¹¨@é!@¡ÞH@R«·SŸ@©ø@|ßH@%ÚÏ›@âäÀÆßH@"ú ˜@”æÀàH@7_üŸ‰‘@'¾û_àH@{ºüƒ@.:ö?àH@´(@‰@->ÀøßH@m@΋@Ý ö_çßH@á;÷?<Š@N§ €ÐßH@nü& Ëˆ@&—÷¶ßH@³ù¿~‡@L÷™ßH@ý -€c†@°tüyßH@ß ñ…@•£øßgßH@"Èš…@½Ë`UßH@9@Q…@ëù?,ßH@W]$@…@¡@ßH@ê1Û_‡‡@ÀTù¿ŸÞH@iŒ÷_¾‡@@A÷xÞH@£KI o‡@`ªüßOÞH@@Ó؇@?ö>ÞH@OÑO@,†@8ùŸÞH@îü  ‚@(¦@²ÝH@ ´?Ì}@àüŸ¦ÝH@" §z@ïÀ¢ÝH@$ª¿wv@) à£ÝH@ÒFCOr@÷³õ_©ÝH@ï Ñ_Co@ÿØû¿°ÝH@âw²Rm@Š4ù¸ÝH@Ô}!`„k@ÄÀÃÝH@$ÿBi@\9ÿŸØÝH@BÆ_Åg@¤H âÝH@V¸'@ûf@—²äÝH@Í=â_f@þ±÷áÝH@tþ7@zd@ÿøÓÝH@áè@½_@ ÀÝH@…/Àü]@ýô`zÝH@”¼¾ÿ$\@>E nÝH@èîßaW@=þZÝH@zþÕ_†U@¼"øßJÝH@müßðR@Èyÿ'ÝH@wìFJ@‘q÷ÿ’ÜH@!@bF@.:ö?ÝH@åC³_5B@Ý ö_gÝH@û É7?@Ðõùÿ£ÝH@ÌAñß“=@Roü?½ÝH@þ21À²<@vË€ÇÝH@JŸN`×:@OüÿÕÝH@‰bMÀ 7@š½ éÝH@È ¯25@‚:àöÝH@z§áß3@¢xøßÞH@¾`j0@·rþ?1ÞH@‚ú;€ê,@(åÿŸTÞH@ç à÷(@P‹à†ÞH@kT /'@fBþ_–ÞH@k›€:$@•% £ÞH@zTüß@­ëÀ®ÞH@~r @–Êü·ÞH@bëß@—s ÁÞH@éŸ\@–L`òÞH@– :f@-ÿ`VßH@Û¦6@‚@µŽàzßH@hQ €@žûŸ‘ßH@š%à[@§’  àH@[»à@‰ 1àH@¶ß@q±ý¿EàH@á¨Gà0@„ ZàH@Ì€í?¶@Y ààH@t¼ú_K@g*@ÃàH@”Ý?õ@_íÀèàH@Ì®A€ˆ@'ý÷¿'áH@]: è@$³þ¿áH@i9`?@ÏÎõ¿ÔáH@ä¯æ@™WøáH@÷ à´@Ù€âH@òØèÿÉ@$1÷DâH@5< }@‘œ ÀXâH@õÏüÿr@2àÔâH@ñ/Ý¿@ÒÅ ÀýâH@ž¬ÿ@&—÷6ãH@Ý 7àó@§S@hãH@ß…R X@¤‡…ãH@òm àw @Ñ@‘ãH@¨8ÌŸˆ @æ ›ãH@ l-@™ @¼ãû¨ãH@éŽQà•@Xï °ãH@Ò.Kà{@Ñšöÿ·ãH@ÙDE ‡þ@ýrû¿ãH@&AÑŸªü@2p ÍãH@ËÛð?"û@PL€äãH@¢9üæù@ˆP äH@é6¸ßgù@µ$ö¿äH@ŒC ´ø@þ 8äH@WÜêÿ=ø@ í÷täH@ö·àŸú@òBø²äH@KÇ  û@û €ÔäH@ZT8@8ü@©ø@üäH@‹›Çý@ÆV `NåH@È& ¨ý@É `våH@L×ú¿vþ@:À™åH@ÃK ÀH@$t`ÝåH@‹X¼?{@­¨ûßæH@±‡Àk@T~`9æH@^†9 @ð`YæH@aýáßN@hà´æH@Ù®T@o@ÏÎõ¿ÔæH@¼¿¬ @/"þ/çH@—É. Í @AàQçH@úª `Ò @ˆP ‚çH@¨=€ @Àý_ýçH@ûRGàr@ÿØû¿0èH@½Ê5`ë@ÄÀCèH@EDÖ¿@‘ú_lèH@ª Oà„@©µö_ãèH@Çåª?ã@ö«éH@-$`t @OüÿÕéH@¥®@Ô @Ymþ_õéH@²®» @(ø¿êH@°ˆå¿Õ @k\ êH@‡“  @¼ãû(êH@“Ô¶ø @âäÀFêH@ôøÿi@N€žêH@84À`@Ǽ ÀêH@BùÀþ@'ÿÿâêH@§<Ûÿ@Ÿï€>ëH@~Åù‰@ì® bëH@ï&S`\@\!€…ëH@8°E 4@F‚ ÉëH@ó—P Ó@Þñý?ìH@CÊìÂ@u& €3ìH@!¼ê¿Ö@èúüÿQìH@ƒ^ÉŸ¹ @Y $ìH@p÷I ë"@#ö  ìH@/"þ/%@÷€ìH@ô= Ñ)@Zû_ ìH@ÅÄ(­6@ÙA úëH@K :@©ø@üëH@vuàÿ;<@¶Šö_ìH@HàF=@wIÿ? ìH@•I€Ü>@Šž  ìH@¿U@-@@¸ À;ìH@×´ÿ¿¹@@ÎÒ@KìH@I ú“A@’ànìH@}ÀC@,™ÀäìH@¢ù1 ZC@–L`òìH@æ>ÖßTD@þ±÷áìH@Võ°{D@òBø²ìH@ûºã¸D@•£øßgìH@Å/ ÿ>@1÷åëH@âŸÆ?@f ñêH@“³R@·3àëH@ëã?´Q@ ˆëH@Ô'ûßøS@;R ¼ëH@Á¦À´U@?ö¾ëH@.äÏ¿vW@ö?ÀëH@M@<àôY@«Ä€_ìH@Ô>%b[@¾¯ü¿‹ìH@#@¦^@IÌýñìH@¨ú_Ïg@Ðõùÿ#íH@2ÚÀµs@ÑÝàPíH@ìÂ{@@)ÿÿ$íH@Ç¿K€Ì€@u& €³ìH@Êü»†@èúüÿÑëH@LBØßÈŠ@ô¨ø¿#ëH@8•ÏÙŸä@’×÷Ÿ„»H@qšÓŸÜ†@ö5ýŸäÏH@ÄË0IÀCD@9ÀÊÏH@„ò€ýE@é`ýŸÃÏH@0´ßÐG@Å­þßÃÏH@»Rà®H@¾1ÇÏH@ü:OÀŸK@û¦úßÛÏH@Ê €^L@šößÏH@°óÂß'M@«Ä€ßÏH@üN8`üM@û¦úßÛÏH@úè7ÀŠO@ñ…ËÏH@¹¿þP@ó€²ÏH@ †)€S@» †ÏH@)#.V@Âùõ¿3ÏH@œ=Y@Èþ?ïÎH@ûÎÌ[@…ùŸºÎH@CÞÕ\@èxõ¿–ÎH@¢»‡]@yÖ MÎH@ËÆ9 [^@´à+ÎH@±Çw_@åmøÎH@9,ËßÖ`@³ù¿þÍH@‘t8€Ÿa@Ç‘÷?úÍH@}ÊÖŸib@ëDöÿùÍH@D=À(c@=ßýÍH@Âcàf@º>ÿÎH@QE·áh@k ÎH@®Ïÿåk@;ö?#ÎH@ú•RÀ q@v@%ÎH@12Ø?t@Áý@*ÎH@LÚ;@ƒw@ í÷ôÍH@e,`#y@Œ‚×ÍH@ÞJ@+|@#ö  ˜ÍH@wF¾¿ÿ~@°5ÀVÍH@jˆèßG€@Ó© 4ÍH@ˆÀ_@^øÿÍH@1Ûã¿‚@C¶àåÌH@µãŸ|‚@#5»ÌH@©áד‚@€+ú¿zÌH@ÈNì_a‚@0aúQÌH@×ýßè@ ýß*ÌH@o$ùß„@‚y@ÌH@ð^ÿ¿û€@Zû_ ÌH@Ë. Q€@+/ùŸüËH@ÇI@Ð~@ç=àêËH@‰#Q`èz@~ø¿ÄËH@›'ÀQw@ì,þߦËH@_Å5€¯{@Èþ?oËH@]Å ~@à~ UËH@æÿÙ2€@ËÇ EËH@ •æ‡„@%› ,ËH@˜'”…@?ü_"ËH@qšÓŸÜ†@О€®ÊH@¯9@Í…@RþÿIÊH@óÖßu†@ ÀÉH@>ÜÄp€@á½þwÉH@£té_’z@>E nÉH@W3ß3z@ æÉH@h:à_©w@„ ÚÉH@(;& `t@ýô`zÉH@Ç>@{w@ã‰ÿ¿ÚÈH@½wP`l{@ð`YÈH@Çfä4|@ëo À?ÈH@ÜËÇÿ.@·ô€ìÇH@»äÉ’„@жýŸÇH@Ñÿ„@û €ÔÆH@A§÷¿é‚@3— àœÆH@ç¾A <ƒ@š? à$ÆH@Ag-`]€@@)ÿÿ$ÆH@":€U|@v@%ÆH@tQ€j|@GèÀºÅH@uSàl|@ã¡÷ß­ÅH@×®¿Ûz@2îþ_’ÅH@2D%àu@¬¬ ` ÅH@Fq@éâà~ÄH@l,àqp@=uößÄH@nÔT`p@Èþ?ïÃH@‘Ñq@ˆÎøßFÃH@aÔA +x@ĆúŸtÃH@ "Åßz}@ã¡÷ß-ÁH@•Î  ­u@3 áÀH@Ë0IÀCx@ ÷_¡¿H@_® `Fx@Ò  ¿H@ÉdH€`w@œ¡úÿŸ¾H@ŒÖ´ÿ¿u@­ëÀ®½H@0ßò?–u@G©`½H@I¸€w@ í÷ô»H@Î~Q@âp@ê‡à’»H@© ëßXp@r/öŠ»H@3‚S@Vk@’×÷Ÿ„»H@~^+€­g@ùþßÇ»H@Þçßpc@ECÀ¦»H@Æjóÿª_@0 ößó»H@Mê`iV@)K@Æ»H@Âø'ÀÉU@1ÇúûH@>ÜÄpT@J2þ¿â»H@¿U@-L@¾ò ¤¼H@Ïù€L@4“û_¦¼H@öw:€L@" §¼H@¥lË_¥K@‰ ±¼H@rER ‰G@÷€½H@™@×ߎ3@ÿÎH@D=À(c@=ßýÍH@}ÊÖŸib@ëDöÿùÍH@‘t8€Ÿa@Ç‘÷?úÍH@9,ËßÖ`@³ù¿þÍH@±Çw_@åmøÎH@ËÆ9 [^@´à+ÎH@¢»‡]@yÖ MÎH@CÞÕ\@èxõ¿–ÎH@ûÎÌ[@…ùŸºÎH@œ=Y@Èþ?ïÎH@)#.V@Âùõ¿3ÏH@ †)€S@» †ÏH@¹¿þP@ó€²ÏH@úè7ÀŠO@ñ…ËÏH@üN8`üM@û¦úßÛÏH@°óÂß'M@«Ä€ßÏH@Ê €^L@šößÏH@ü:OÀŸK@û¦úßÛÏH@»Rà®H@¾1ÇÏH@0´ßÐG@Å­þßÃÏH@„ò€ýE@é`ýŸÃÏH@Ë0IÀCD@9ÀÊÏH@}Kàº?@ö5ýŸäÏH@¡¾D@®>@Ø`+ÐH@PL€d=@ í÷tÐH@Ð"€@<@îz`ÅÐH@ @@J:@ 3ÑH@Í&¸?´6@¿îø.ÑH@×`LÀÐ3@ÿØû¿0ÑH@Úþø¿á1@³:ÑH@¸24à$0@ £þLÑH@14KÀ·.@gi eÑH@ù, -@¡@„ÑH@EÚÆŸ¨,@K°ö§ÑH@ìÙà'+@%ÿ_ñÑH@J¹ÿ†(@)K@FÒH@õ9 [&@ ˆÒH@UøñŸ‡%@ï7û¬ÒH@¤Ì6%@àö_ÂÒH@ËÇ Å$@ötùÿÓH@$_KÀ–$@ªÿÿÁÓH@(ü)À=$@z€ïÓH@¶¡ €í#@\!€ÔH@Eî¯?#@„ÿ?-ÔH@å…ð?d@pÉõߘÔH@ñÅÍ_×@èúüÿÑÔH@ž™Üÿ2@ýô`úÔH@•ù`s@à úÿ‚ÕH@ñû@wÇ÷ÿÐÕH@Ôì@ßÙ AÖH@,EUÀû@ëDöÿyÖH@€(¹?î@ Õÿÿ ÖH@ÚQÞ¿`@Ê ëÖH@ŒC`Y@âbû ×H@ÎPýÿ@'ý÷¿'×H@¾qÎ_S @÷\à3×H@Üß°Ÿ‹ @µüŸG×H@ª^àm@ L  V×H@ðŠà+@ W@\×H@Ó¬C Àä@Ö6u×H@‹ÈM`|á@IÌýq×H@¥îÒŸ`ß@*ŠüŸh×H@¦¿°_$Ú@ö?@×H@ÎÒ@ËÕ@áüúß™×H@‹G +Ô@º}û߶×H@5Ñ)À^Ò@m@€Î×H@-«U`mÑ@°5ÀÖ×H@:¾¬?xÏ@"eö?á×H@™ªæÿvÍ@ûO`æ×H@ºÿ rË@¹V÷Ÿç×H@N“!àsÈ@Èû`â×H@Ù¿_ŠÆ@ìý_Ø×H@+ÙÒqÂ@Ž¥ö¿¯×H@‡é1€¦À@ïÀ¢×H@ôþ@¯½@)cø_™×H@”|ôŸ˜¹@à—×H@t‘矅µ@=`Ÿ×H@ŠH╲@wˆûŸ®×H@Eð"À§±@–Êü·×H@wIÿ? °@åïÿ_Ì×H@FÖ·2­@ûØH@¾7À«­@Ó÷Ÿ)ØH@傯¿W®@­* QØH@@— °@äq ‡ØH@ØïìŸe±@]`à§ØH@-€B §³@|áÀÒØH@Dñð¿¸@ÇÔ ÙH@¨ÛŸ¬¸@ÀTù¿ÙH@çÒ*À˜¹@1ÇúCÙH@}_ùº@‘ú_lÙH@›cÌŸgº@ U °ÙH@Ø1*€”º@³ºÚH@Ÿ× `ëº@LY2ÛH@û»@L×ú¿vÛH@Ø„€½@A§÷¿éÛH@ìZR yÀ@O£ûÿÙÛH@_€.Â@û €ÔÛH@=a @8Å@È€ÓÛH@ÔD@2Ç@³@ý_ÜÛH@üä(@È@>œúäÛH@’V¾_³É@ ‹ùÛH@f+Ô?-Ë@; ÜH@å°*Í@iŒ÷_>ÜH@ÏxÏ?ÉÎ@ؘøpÜH@ŒÈ¿…Ï@¿X@–ÜH@i8àÊÐ@oÍ`ÝH@ÙÖ&€(Ñ@6¢€"ÝH@ðÃÿ%Ò@g*@CÝH@sÀ àÁÒ@eÄ QÝH@á¥`$Ô@/¤`jÝH@2ƒ!@ÀÕ@äÈû}ÝH@IN`,Ù@¶Í@ÝH@Ù×ô’Û@ö?ÀÝH@ù¿cß@»¤ÿÞH@õ Pè@ãJ`¸ÞH@œK ë@¸ðöÿõÞH@1ZªÎì@ñF (ßH@j " ™í@IÀNßH@#ȵ_Fî@Æ ‹ßH@‡–L€'@…E€|ßH@¬jÍÝ@müßpßH@ʳ? @1÷eßH@ë±? @èúüÿQßH@éŸ\@–L`òÞH@bëß@—s ÁÞH@~r @–Êü·ÞH@zTüß@­ëÀ®ÞH@k›€:$@•% £ÞH@kT /'@fBþ_–ÞH@ç à÷(@P‹à†ÞH@‚ú;€ê,@(åÿŸTÞH@¾`j0@·rþ?1ÞH@z§áß3@¢xøßÞH@È ¯25@‚:àöÝH@‰bMÀ 7@š½ éÝH@JŸN`×:@OüÿÕÝH@þ21À²<@vË€ÇÝH@ÌAñß“=@Roü?½ÝH@û É7?@Ðõùÿ£ÝH@åC³_5B@Ý ö_gÝH@!@bF@.:ö?ÝH@wìFJ@‘q÷ÿ’ÜH@müßðR@Èyÿ'ÝH@zþÕ_†U@¼"øßJÝH@èîßaW@=þZÝH@”¼¾ÿ$\@>E nÝH@…/Àü]@ýô`zÝH@áè@½_@ ÀÝH@tþ7@zd@ÿøÓÝH@Í=â_f@þ±÷áÝH@V¸'@ûf@—²äÝH@BÆ_Åg@¤H âÝH@$ÿBi@\9ÿŸØÝH@Ô}!`„k@ÄÀÃÝH@âw²Rm@Š4ù¸ÝH@ï Ñ_Co@ÿØû¿°ÝH@ÒFCOr@÷³õ_©ÝH@$ª¿wv@) à£ÝH@" §z@ïÀ¢ÝH@ ´?Ì}@àüŸ¦ÝH@îü  ‚@(¦@²ÝH@OÑO@,†@8ùŸÞH@@Ó؇@?ö>ÞH@£KI o‡@`ªüßOÞH@iŒ÷_¾‡@@A÷xÞH@ê1Û_‡‡@ÀTù¿ŸÞH@W]$@…@¡@ßH@9@Q…@ëù?,ßH@"Èš…@½Ë`UßH@ß ñ…@•£øßgßH@ý -€c†@°tüyßH@³ù¿~‡@L÷™ßH@nü& Ëˆ@&—÷¶ßH@á;÷?<Š@N§ €ÐßH@m@΋@Ý ö_çßH@´(@‰@->ÀøßH@{ºüƒ@.:ö?àH@7_üŸ‰‘@'¾û_àH@"ú ˜@”æÀàH@%ÚÏ›@âäÀÆßH@R«·SŸ@©ø@|ßH@×´ÿ¿¹¨@é!@¡ÞH@¢áÿT±@È€ÓÝH@—3€\³@iö€¦ÝH@ hIxJ ˆh@^à;ÆH@ ð8 e@C4üŸ*ÜH@*BÑ<€Eþ@ú( —ÙH@ÏLî™þ@/¤`jÙH@¶‹Ä_îþ@(åÿŸTÙH@Ã:ÀYÿ@À“õBÙH@ ôG w@ ÷_!ÙH@hÍŸã@t> ÙH@ù€¥@TSõŸóØH@ÿ1–@š½ éØH@…ñO€“@gi åØH@Y¶ÿ– @´éàæØH@+… ˆ @müßðØH@U#`M@x¯ÿßýØH@ƒ‰Ü_@3— àÙH@IúQ`C@XFú&ÙH@ÓV 5@¤Æ`'ÙH@Œ;@(@iö€&ÙH@v àé@,nõÿÙH@EMà@‘Û ûØH@0ÈÈ-@Wþ¿ÙH@f–±_@ötùÿÙH@|âο< @Wþ¿ÙH@Ý0Àô @,@ýØH@þ®¶ÿT"@š½ éØH@öcQà¶%@PÊÿ?©ØH@sjã_6'@?„‘ØH@ ? (@P‹à†ØH@rÞÿÇ)@øÚùŸxØH@t'Ø+@ؘøpØH@nx¬ßm.@ÕûjØH@—ä_O0@ÕûjØH@%îëŸ+2@>E nØH@ßØ_ú3@ ‹yØH@9,ËßÖ4@óiü_ØH@¼aô?m6@èxõ¿–ØH@aæ·¿å7@ U °ØH@uv®ÿ¥:@*ŠüŸèØH@Ï£âÿŽ<@­¨ûßÙH@’ÆO€´=@üv  5ÙH@G@àÜ>@ƒ÷úÿ]ÙH@ùí@kE@aÑ ÙH@R®øŸ_H@ÎPýÿÙH@¸šÐjK@H ÙH@´|¸?rN@âbû ÙH@‰`Ú?hP@ÓjÀÙH@{©T`3R@QúßÙH@î; #V@¢úÿDÙH@ÜÍ:€ÑW@½àMÙH@ë[ ãZ@/ @ñØH@/Nßß^]@à?À²ØH@@Ö&`@ ‹yØH@¡QôŸ¹c@Roü?=ØH@$³þ¿a@?ü_"ØH@æÀÝ`@Ðö¿ØH@oáíÿë]@ôøÿé×H@²o ˜\@ïv÷ßÎ×H@æ?b[@à?À²×H@iàª_§X@SW j×H@áù¹_ Y@Š4ù8×H@ÐI­ÿŒY@åïÿ_ÌÖH@Œ±_âY@}¢ÖH@è9ù_tZ@ÙA zÖH@Ð"€@\@xîû? ÖH@§Ô>€¹\@½ À÷ÕH@(ÎÕk]@dÜý¿¤ÕH@óiü_^@Ì«|ÕH@w¶Oà_@û €TÕH@“kL€H`@#Œú0ÕH@o:U„b@HfýÿÔH@ß. ¼d@ìý_ØÔH@ ð8 e@„ ZÔH@¢åH€ýd@müßðÓH@º€<`Ãd@#ËößRÓH@Þ(`}d@àõÒH@N ¸`@\xûÿúÒH@¥Y°¿²_@=ßýÒH@ sà%_@HfýÿÒH@ÓB4€Ø^@d`ÓH@3m^@´(@ ÓH@«Û, H^@ƒßà ÓH@Hc¼ÿò]@²ù ÓH@Ág`’]@¥ƒõÓH@¸ï(Œ\@-ÔõŸÓH@éâà~X@­¨ûßÓH@³:W@k\ ÓH@9WÞŸœV@½IüÓH@úgþ9V@Ešü?ÓH@—_åU@aÑ ÓH@¢áÿTU@ù€%ÓH@FªÖ_U@'ý÷¿'ÓH@9ê§T@9­ (ÓH@E®åßxT@ 'ÓH@¿U@-T@vŒ %ÓH@¢MåCT@6áàDÓH@ÅÖ¿-T@ü@pÓH@…oH@ØS@uãþŸšÓH@3®4†S@e… @¯ÓH@k¯ì—R@#ËößÒÓH@_±LàRQ@müßðÓH@œKÔ”P@õx€ýÓH@#€¿N@žûŸÔH@ôûÝ¿¢L@WJ  ÔH@vJÍ?vJ@fë à ÔH@&”¶Ÿ)G@©7þŸÔH@O`ýD@ÜàÔH@™–ý_C@~Åù ÔH@«Û, H>@0aúÑÓH@ # Ó<@1ˆþ¿ ÓH@@%€0:@ÉaTÓH@¶ß9@üÍþ+ÓH@^òä?I6@ùÿÈÒH@Þ‡î,3@PL€dÒH@f¯N‹1@°ùŸÒH@Ǽ À/@Q² ÖÑH@­€ô.@òBø²ÑH@f f.@Æ+÷ŸˆÑH@U `.@þŸ\ÑH@·C`8-@tûö¿mÐH@Ñðª*@5{@SÐH@ÚªEÀø(@Ÿï€>ÐH@\F °&@‚y@ÐH@ˆüL ™$@’àîÏH@|ŽÀS#@õ ÐÏH@µcò5"@|¢`°ÏH@’™É?L!@ÖÌ÷ߌÏH@¾²=@ @(åÿŸTÏH@ @L€i@Ò ÏH@þÇS `@z€ïÎH@;7À/@àÀÎH@Hº°è@º>ÿ”ÎH@o$ùß„@·ô€lÎH@0´ßÐ@Œ‚WÎH@¿N >@›äà8ÎH@{g€ @ã ÎH@û €T @(ø¿ÎH@Èñ¿l @äÈûýÍH@„2è߉@µåù_ðÍH@wÜ®Ÿ@va÷_ßÍH@M:€4þ@2àÔÍH@4§äÿÿ@º}ûß6ÍH@Þçßpÿ@wIÿ? ÍH@Ä´NàÆÿ@!  ÷ÌH@½ˆø¼@Sù?ÑÌH@©@ñ@¿îø®ÌH@ÅÄ(­@‡Ò`=ÌH@}Š @Ý@\·÷_ÌH@ _%@É@Ju  ûËH@éËÚ¿ @v àéËH@r®¼?9 @hÏ@×ËH@³,Àÿ@ëÆý?µËH@Ô}!`„@ì® bËH@uØ@¿— ¸ÊH@¢¸Â?•@ÉaTÊH@(ø¿†@°tüùÉH@9K óô@ ÉH@jœÑ¤ò@þ±÷áÈH@‚ú;€êð@‘óþ?ÎÈH@4°Ÿð@è ÈÈH@®ÐÍOî@1ÇúÃÈH@0LCàŠì@ÄÀÃÈH@µLÈÿËê@RþÿÉÈH@&ëªé@Œ‚×ÈH@2ÃëŸLè@{{ áÈH@œRàÏæ@žq ÀùÈH@RÂá?¼â@*öŸNÉH@ví>á@6 @gÉH@S)°ß—ß@Qñ€xÉH@F6 ßÝ@)Í€ÉH@e¹Ÿ:Û@Wþ¿ƒÉH@ïõ½Ÿ}Ù@œbþŸ}ÉH@á<Å?¦Ø@!  wÉH@·ÝÛ_×@ö5ýŸdÉH@*²Îß!Ô@LY2ÉH@ŽÑ×ßÏ@fÀöÛÈH@pÞ¬ßÌ@ëù?¬ÈH@%ñ, 8Ë@«F ÀšÈH@ÕNÿHÊ@º>ÿ”ÈH@PIÆÿWÈ@Žfú_ÈH@Ài°_fÂ@»¤ÿ†ÈH@S tÀ@lü?ÈH@¥-Ïÿ‚¿@°tüyÈH@€À ¨¾@/ @qÈH@™íñß½@Åð À\ÈH@–ËÊ¡¸@; ÈH@Év¾Ÿ·@Ì«üÇH@¢Î?nµ@eZöéÇH@Ahû_Dz@ ”ÿÒÇH@^†9 ¯@è» ¯ÇH@Ø™ÆÚ­@ Õÿÿ ÇH@À,'€æ¬@Âcà›ÇH@êH€ðª@›¥ €–ÇH@õ³?í£@c7ÀÇH@iaäŸø¡@¯ü‡ÇH@ð6-€B @É `vÇH@+ÄŸ¸ž@d^`ÇH@Ž¨7@¼œ@®ç÷?8ÇH@ýÕŸ³›@ó¬@ÇH@9¸›@->ÀøÆH@äÈûýš@ûO`æÆH@,„Q ›@û €ÔÆH@¡æ€g›@Häõ?ÄÆH@>°ã¿@œ@Èyÿ§ÆH@¾„éÿE@›üýÿ‹ÆH@ž¹›@ËhÆH@¬Vä߀™@È€SÆH@æE ¨˜@t¼ú_KÆH@ûcïÿ–@Jó`@ÆH@?¬Ô?Ê”@^à;ÆH@}ô`Å‘@«… =ÆH@oùå¿@ªÿÿAÆH@He/€•Œ@*öŸNÆH@} F€.@ð`ÙÇH@QµH âŒ@6¢€"ÈH@²»;Œ@Ýs€OÈH@ŠÃ_´‹@J2þ¿bÈH@C#T€ZŠ@)Í€ÈH@F,ÞŸ½ˆ@ê‡à’ÈH@µâ¸ßã„@[»à“ÈH@ŒmJ`„@î’þ˜ÈH@λÚb‚@y—ÀªÈH@[ú@6}@a’ÀüÈH@*‰. þx@Âùõ¿3ÉH@EZ2à{@€ `sÉH@ärÕŸq@È€ÓÉH@Wˆ7U@É `vÊH@ݵß5@'ý÷¿'ËH@0t Dy@*Éøÿ ËH@÷ˆâŸcy@’€ËH@!S€ s@ Àù?MËH@IxJ ˆh@ñûžËH@æA`ai@Å/ ÿËH@>…Ðÿzj@|úß|ÌH@*uE¢r@» ÍH@æ-.Àw@•düEÍH@ÿìä_ |@ÿ™ÿ_ŽÍH@žI8€À{@á½þ÷ÍH@>\0ÀW{@P‹à†ÎH@ÜOBÀŒ{@ !÷ßÎH@,™Àä@¤H bÏH@r­î?φ@o À1ÐH@À¨¬¿ˆ†@ Sø¿eÐH@Í¿éŸØ…@Ý ö_çÐH@>]þ¿Á…@u¤@øÐH@w 5à‰@ëo À¿ÑH@d[ÄÓ–@¹ÀÀÏÑH@@TÀj˜@eÄ ÑÑH@ц `Û @û¦úßÛÑH@…¯?ª¡@2p ÍÒH@Á´Ÿµ @j5àÈÓH@HÓM ô¡@¸Z ^ÔH@Ài°_f¦@Z” DÕH@d€š@›zö¿ÐÕH@eCÌ_•@ ÀÖH@«š½¿ƒ@òBø2ÖH@Ûæ „@Cw€ÃÖH@“¿ÿ1}@}_ù—×H@ ÖÍÿŠ|@µåù_pØH@>Þ7@7à‚ÙH@Êßÿ¿˜†@0Ë  9ÚH@]IÙ¿>Œ@§Ñýÿ¬ÚH@oâ»ÿUŒ@SÕüß®ÚH@?<@b‘@¨¹àÙÚH@Ia ™@è» /ÛH@›8¹ß¡œ@à@ÛH@¢"Ò_}ž@Í)ù¿@ÛH@g«?€¢@Ý4 -ÛH@P¢-ð¤@j àÛH@b‹´¿yª@5ºÿŸuÚH@À¨¬¿ˆ®@dÀ)ÚH@Oöàÿر@¶Šö_ÚH@° g·@WÈ`áÙH@%·?z»@± ƒÙH@ªaC`zÁ@lü?ÿÙH@­* QÅ@ùþßGÚH@ý ºÿÀÇ@9+ýßlÚH@º¨ |É@Å/ ÚH@5Œ«_#Ì@fBþ_–ÚH@Êßÿ¿˜Î@OdÿŸ·ÚH@Eð"À§Ñ@Èþ?ïÚH@\ãØÍÙ@[»à“ÛH@‰Í*à\Û@ôQ@®ÛH@Ù—* Ý@Z” ÄÛH@ìý_ØÞ@pKýÔÛH@ïÀ¢ã@ æÛH@ËïÙß~å@2¯ðÛH@³ëÿ˜é@}_ùÜH@Ä3 uê@&@ÜH@éû_dì@ocõ?'ÜH@ãß%@fî@C4üŸ*ÜH@'+Lzñ@dÀ)ÜH@@TÀjô@Y $ÜH@gá_Âø@¿ÀÜH@3®4†û@} ýuÛH@S“¿ÿý@ÂcàÛH@/v±þ@*3 óÚH@ºlSÀfþ@MþþÿÅÚH@‰öÊ€þ@²Â —ÚH@–Êü7þ@û¦úßÛÙH@BÑ<€Eþ@ú( —ÙH@ ðýaSï=@ ®û¿Q¹H@i àÿò@nåüâËH@»N.l(@ÃáýŸ`¹H@¼L Ê%@’àn¹H@nPÚŸ´%@Ó+ `o¹H@óè° @§’ Š¹H@d^à@dÜý¿¤¹H@´è:àü@d^à¹H@s0`M@ À ºH@—K6`ˆ@k ºH@)E`0@c  =ºH@Ћêß»@b¹LºH@5ìß/@<÷ýPºH@oz`@N§ €PºH@±1ñ?àî@ƒa ƹH@mþŸŸí@óë ¼¹H@‹î¬“ë@4TÿÿºH@+±ßÑê@&@ºH@î'Rñ@ ”ÿÒºH@øîâ?Õë@ïõÿ;»H@šj êæ@Ïù€š»H@µz@žå@u& €³»H@¹¿þä@©à )¼H@pŠùöã@þZì¼H@»€©ã@š? à$½H@ñrè_Xã@øD À`½H@) à#ã@%`‡½H@gRØ|á@¶ þŸ¿¾H@Ä4àEÒ@Ã_ö_%¿H@IKÄßÈ@BP@ô¿H@O`ýÀ@Ì«ü¿H@>ß?«¾@×2øþ¿H@éÕß–´@ìý_Ø¿H@›;ú_®¥@Çÿ5ÀH@é J ÚŸ@9nÀÀH@Ù—* ™@2p Í¿H@©_Ðß×’@øöÿš¿H@Ô<²¿t@t}þÿ(ÀH@“ÿÉß½k@A§÷¿éÀH@] Ý_X@|cŽÂH@ §«¿NW@®ÏÿeÃH@ööß1]@K°ö§ÃH@À¼ßp`@ £þÌÃH@÷²'`¿\@éâà~ÄH@Õ¥óŸ=X@ÞoöÿXÅH@NÏÜ¿‰O@ê‡àÅH@ TÆ¿ÏD@Ÿ`¼ÄH@hNÉÿB@m¾ø?ÅH@ýaSï=@; ’ÅH@ÿ1–A@hà´ÅH@²D àÒB@ñÜ÷ÀÅH@Ù¬Ÿ£B@/e ÈÅH@Æ¿®B@4Ò÷¿ÈÅH@ïáÔÿ C@ÑÝàÐÅH@—ÆíŸÀN@¬Bû?¤ÆH@+ƒ¬ŸåN@®ÆH@–õàüO@ŠÝÃÆH@(9³Ÿ½U@:jù?ÆH@X0À™_@Þ0úŸ6ÇH@­€ôf@ ³ÇH@™…U@Êm@ÍhõcÈH@ójÊ_kx@ú`(ÉH@z( âx@Û%ýÿ0ÉH@*‰. þx@Âùõ¿3ÉH@[ú@6}@a’ÀüÈH@λÚb‚@y—ÀªÈH@ŒmJ`„@î’þ˜ÈH@µâ¸ßã„@[»à“ÈH@F,ÞŸ½ˆ@ê‡à’ÈH@C#T€ZŠ@)Í€ÈH@ŠÃ_´‹@J2þ¿bÈH@²»;Œ@Ýs€OÈH@QµH âŒ@6¢€"ÈH@} F€.@ð`ÙÇH@He/€•Œ@*öŸNÆH@oùå¿@ªÿÿAÆH@}ô`Å‘@«… =ÆH@?¬Ô?Ê”@^à;ÆH@ûcïÿ–@Jó`@ÆH@æE ¨˜@t¼ú_KÆH@¬Vä߀™@È€SÆH@ž¹›@ËhÆH@¾„éÿE@›üýÿ‹ÆH@>°ã¿@œ@Èyÿ§ÆH@¡æ€g›@Häõ?ÄÆH@,„Q ›@û €ÔÆH@äÈûýš@ûO`æÆH@9¸›@->ÀøÆH@ýÕŸ³›@ó¬@ÇH@Ž¨7@¼œ@®ç÷?8ÇH@+ÄŸ¸ž@d^`ÇH@ð6-€B @É `vÇH@iaäŸø¡@¯ü‡ÇH@õ³?í£@c7ÀÇH@êH€ðª@›¥ €–ÇH@À,'€æ¬@Âcà›ÇH@Ø™ÆÚ­@ Õÿÿ ÇH@^†9 ¯@è» ¯ÇH@Ahû_Dz@ ”ÿÒÇH@¢Î?nµ@eZöéÇH@Év¾Ÿ·@Ì«üÇH@–ËÊ¡¸@; ÈH@™íñß½@Åð À\ÈH@€À ¨¾@/ @qÈH@¥-Ïÿ‚¿@°tüyÈH@S tÀ@lü?ÈH@Ài°_fÂ@»¤ÿ†ÈH@PIÆÿWÈ@Žfú_ÈH@ÕNÿHÊ@º>ÿ”ÈH@%ñ, 8Ë@«F ÀšÈH@pÞ¬ßÌ@ëù?¬ÈH@ŽÑ×ßÏ@fÀöÛÈH@*²Îß!Ô@LY2ÉH@·ÝÛ_×@ö5ýŸdÉH@á<Å?¦Ø@!  wÉH@ïõ½Ÿ}Ù@œbþŸ}ÉH@e¹Ÿ:Û@Wþ¿ƒÉH@F6 ßÝ@)Í€ÉH@S)°ß—ß@Qñ€xÉH@ví>á@6 @gÉH@RÂá?¼â@*öŸNÉH@œRàÏæ@žq ÀùÈH@2ÃëŸLè@{{ áÈH@&ëªé@Œ‚×ÈH@µLÈÿËê@RþÿÉÈH@0LCàŠì@ÄÀÃÈH@®ÐÍOî@1ÇúÃÈH@4°Ÿð@è ÈÈH@‚ú;€êð@‘óþ?ÎÈH@jœÑ¤ò@þ±÷áÈH@9K óô@ ÉH@(ø¿†@°tüùÉH@¢¸Â?•@ÉaTÊH@ç¿ ¦ @sÿ@dÊH@_Å5€¯@Ó+ `oÊH@ˆã¯@×2ø~ÊH@Ö^Ù?.@ñûžÊH@_Ù @²Úü¿êÊH@µO €Ø@×2øþÊH@:”>ë@r/ö ËH@Æ,!@†êÿËH@wóØ¿€$@:jù?ËH@ÌXý(@ötùÿËH@~Ú°¿O-@ ‹ùÊH@pH¼ŸÇ.@<¸À-ËH@4Ò÷¿È0@bàaËH@Š1¸ÿ+3@ÖÌ÷ߌËH@Ãsßÿ5@Ån€¡ËH@êH€ð6@l ¬ËH@n;#î8@Äà¯ËH@ÿìä_ @@UöŸ­ËH@ûÎÌC@|¢`°ËH@Séå E@sþ_·ËH@m–&ZF@ñÜ÷ÀËH@¦ì6 ŒF@ëo À¿ËH@D€ºF@Ǽ ÀËH@ö5ýŸäF@àÀËH@Õ¢²1G@û ÄËH@ûûR`}G@X…öÈËH@PŸìãG@¨ú_ÏËH@®ä¶¿«H@šößËH@“iÙÿ¥I@¶KúÿáËH@ä·ÿJ@nåüâËH@ë3Nà)J@Èû`âËH@EƒÒ³J@’˜û?âËH@¾œáK@3 áËH@c¡àxK@@«@àËH@˜M`K@ó*ßËH@%ÚÏK@î÷?ÝËH@€ `óK@ã‰ÿ¿ÚËH@RC€ L@ÇRûß×ËH@ŒZ/ÀL@(åÿŸÔËH@ ~ €+L@´¦ýÿÍËH@7ñÝÿ*L@ˆÎøßÆËH@pÉõßL@”À¶ËH@ºù_L@ U °ËH@lo"À L@ˆü¤ËH@i÷ÔL@3— àœËH@à `&L@õù_•ËH@Y.SL@X° @ŽËH@î{Ô_¯L@’×÷Ÿ„ËH@“³N@¢9üfËH@Ë6~N@G' ]ËH@tÓ$€´N@-ÿ`VËH@P = ØN@%ÚOËH@0`,€çN@Ahû_GËH@íÀRÀêN@¶ þŸ?ËH@D¯³ßâN@÷\à3ËH@¢¯ÏN@à–ú?(ËH@B{ºN@Šž  ËH@66à˜N@^Æ€ËH@“³N@B€ËH@ýaSïM@õx€ýÊH@ºì¿ÎM@v àéÊH@< 翬M@c  ½ÊH@f~¹?¬M@:©õŸ±ÊH@š(ß¿»M@XFú¦ÊH@4Õ8@ÕM@»ö?ŸÊH@ RŸ#N@(gàÊH@2-û¿4N@êÞõ_ˆÊH@§È_9N@”æÀ€ÊH@ S1N@ù@ú?jÊH@ˬ8N@Ì@cÊH@H¬ÿRN@Åð À\ÊH@¸*`mN@¨¹àYÊH@EDÖ¿N@D€WÊH@¹×0à¸N@ueàUÊH@bäÀO@”þûßSÊH@X™ß¥P@õ PÊH@xïÉ? Q@ïv÷ßNÊH@#5;Q@2p MÊH@Æ ‹Q@9ì€JÊH@î; #R@ ü_CÊH@ŽQCÀÆR@½ˆø<ÊH@ž¹S@Ñšöÿ7ÊH@[:ÍŸÂS@l ,ÊH@ôà T@à–ú?(ÊH@o£¿Ÿ3T@ì,þß&ÊH@v´Ü_^T@XFú&ÊH@h@ †T@±\&ÊH@•g=ÒT@Èyÿ'ÊH@òå_ìU@ôQ@.ÊH@Ê]øÝV@­6ÊH@~´Q9W@OdÿŸ7ÊH@_C.@ôW@×´ÿ¿9ÊH@ÓPX@Ü΀;ÊH@ù”­?ÓX@Jó`@ÊH@<0€ðY@ÌÃøOÊH@58ø_:[@„ ZÊH@8¿†[@þŸ\ÊH@ÖM1 Þ[@ƒ÷úÿ]ÊH@MÖ,À \@Ü à]ÊH@ —ÑŸh\@×óû\ÊH@Ú}¿\@=þZÊH@ó—P Ó\@Q² VÊH@\Î!€]@õ PÊH@¦,]@2p MÊH@} F€.]@)K@FÊH@ `0]@#5;ÊH@õ÷Î?,]@”À6ÊH@5Pð ]@5ùûÿÊH@f•ã_]@úöŸ ÊH@Ò«¿-]@'¾û_ÊH@Kò3`V]@}É ÿÉH@<Ìê_Š]@¤ÞøúÉH@…1à^@‘2ûŸðÉH@öL'ÀM^@É÷÷ßëÉH@#wCài^@ æÉH@©áד^@— ùÙÉH@&êܵ^@Y.ÓÉH@+ƒ¬Ÿå^@Á< ÌÉH@[Ïïp_@Roü?½ÉH@F™.@²_@?Ãþ_³ÉH@ÜÚ_É_@ï7û¬ÉH@,™Àä_@Þš ÀžÉH@êÛ´ßû_@à—ÉH@jIì%`@åmø‘ÉH@裀\`@ƒßàŠÉH@t=4 œ`@¤‡…ÉH@ÞÅ€ä`@$³þ¿ÉH@€çÿ4a@8Åü?{ÉH@9˜M€aa@ŒÁý_yÉH@’‡S ’a@côõßwÉH@Ÿ‚²ßÉa@‚:àvÉH@±Ý=@÷a@¸ðöÿuÉH@4L›c@r™ rÉH@˜†#@4d@µåù_pÉH@É6ô?Žd@ΠmÉH@SIàÅe@@«@`ÉH@€gµŸf@³@ý_\ÉH@ágØÿkf@à~ UÉH@ / ›f@¹ÀÀOÉH@}Èßæf@û DÉH@?oK`Jg@BÎûÿ8ÉH@âQS`;g@Ó© 4ÉH@›û/"g@jò÷ÿ/ÉH@g ðf@y—À*ÉH@£à²f@Ÿ¬÷Ÿ%ÉH@`U 'f@iMûÿÉH@ÑÄ¿øc@Žø_øÈH@=uöß”c@Æ•ÀðÈH@™ÂÞJc@×ýßèÈH@ÛeÇ_½b@2àÔÈH@†- `©b@ÌÃøÏÈH@a'' ªb@ £þÌÈH@4)ì?¾b@Ð4ö_ÆÈH@§è' c@÷\à³ÈH@¸nï¿:c@ôQ@®ÈH@éJ€qc@Í“à¨ÈH@&Á<à‘c@iö€¦ÈH@@,@€±c@š? à¤ÈH@¬jÍÝc@6¢€¢ÈH@ý‡²¿d@é!@¡ÈH@)Ÿ³?/d@xîû? ÈH@c4À?„d@aÑ ŸÈH@%m²_Úd@,nõÿžÈH@5ìß/e@ö·àŸÈH@‘†®ŸYe@1ˆþ¿ ÈH@7žøÿ«e@M¿ £ÈH@gÈ_÷e@¤Æ`§ÈH@ÅÄ(­f@“¿ÿ±ÈH@oä.€øf@DÝ µÈH@0óÛßòg@.¼ý½ÈH@†´ß=h@ßÙ ÁÈH@´~+Ài@yÖ ÍÈH@ixÀai@rZ @ÐÈH@Fê±i@AàÑÈH@´ÒÞ¿ýi@èúüÿÑÈH@Û»íßHj@õ ÐÈH@Óî_rj@ÌÃøÏÈH@ÿk«¼j@ÎÒ@ËÈH@–ß³¿ýj@˜€ÆÈH@0Ë  9k@»&`ÁÈH@&‚@€ok@¸ À»ÈH@¼£1 œk@üv  µÈH@û'4 ­k@Îù_²ÈH@žI8€Àk@´à«ÈH@#uÐ_Çk@v@¥ÈH@›óßÅk@.} ›ÈH@µ ¶k@7_üŸ‰ÈH@(Tà¦k@³ù¿~ÈH@ àŽk@etÈH@†UÝŸbk@A§÷¿iÈH@ô¾Tà"k@þ±÷aÈH@ÿ9 ßj@8†àXÈH@by> ¿j@ÄGþ?RÈH@–tÖŸ«j@t¼ú_KÈH@I; j@©vúÿ@ÈH@" §j@58ø_:ÈH@ jÓ¿Áj@z“ø?4ÈH@ ýÑ?Új@“¿ÿ1ÈH@ªžÌ?új@e… @/ÈH@Ù-k@`k€-ÈH@Ç'èl@Èyÿ'ÈH@£u·_ül@ñûÈH@ãÈXm@ÂcàÈH@†* yn@àÈH@ñ @o@N%@ÈH@ÒÙò_Zo@2îþ_ÈH@"P? p@ïøþ ÈH@Ö6up@äq ÈH@ô'¿Òp@»¤ÿÈH@)áð^q@KqúÈH@yšH@·q@ ýŸÈH@¨åæŸ r@¯üÈH@65·ß-r@´(@ ÈH@y.Kr@Æ  ÈH@“=``r@X° @ÈH@:©õŸ±r@xîû? ÈH@ê1Û_‡s@‡Ò`=ÈH@<¡×ŸÄs@ ü_CÈH@#óÈ t@ùÿHÈH@ú¿u@ÀÖ[ÈH@Æ_bu@@«@`ÈH@-×6 u@Æìú?fÈH@aË«u@N=û_hÈH@º>ÿ”w@Ìl YÈH@<Ìê_Šy@‰w`QÈH@¹ìç@ñÜ÷@ÈH@Æ•Àp@º}ûß6ÈH@ø `>ƒ@ 'ÈH@ò˜ =‡@¦í öÇH@ª Oà„‹@ùÿÈÇH@ƘG@}Ž@Ù€ÇH@àÁ n‘@Ü£õ¿uÇH@Ù*Ú’@Ž'þÿjÇH@‚bØ0”@×´ÿ¿9ÇH@3¿ÜÖ”@/"þ/ÇH@U `š@ôøÿéÆH@$_KÀ–œ@rZ @ÐÆH@ÕÀ¢@UöŸ­ÆH@µ9­_Ù¢@¾ò ¤ÆH@‘Ç€¤@´ ÆH@3D n¥@Á{ýÿnÆH@&lä_pª@÷\à³ÅH@NÔ@Ìl YÄH@vº°Ø@HfýÄH@ÅoЋÝ@hà´ÄH@ !›ä@‡ @éÄH@Æ+÷Ÿˆç@8Åü?ûÄH@Âö´?'ç@æ ÅH@ŽÒß*ë@Í“à¨ÄH@GÔ ^ð@xþíÂH@i àÿò@}_ùÁH@\L@Kñ@êÞõ_ÁH@åC³_5Þ@š~@GÁH@,B@ïÝ@va÷_ßÀH@Ø/·ÿñ·@Ý ö_çÀH@æ?b³@ñûÁH@(ø¿† @Äõÿ\ÀH@œ¤;€,¡@»¼÷?Y¿H@9@Q¡@ÀTù¿¿H@ `ó?3Ÿ@ÕÐ`¿H@W±×?xš@Å­þßþH@T¨M ”@†« n¾H@¦­:@jŽ@¡ø?—¾H@ÀFÀ¶„@Á Ý¾H@‚¡ÔR„@—s Á¾H@- }@½ˆø¼¼H@û"€n@T½À[¼H@G}' hf@Ú¿ü_¿»H@ú»±"g@О€.ºH@ó«9@0g@c7ÀºH@2 ;g@u¤@ø¹H@³“â_Ûe@q3ºH@ ,ôd@Ð_ ºH@¦þ¬¿F^@ÿØû¿0ºH@ì«ÄŸUX@ø›ý?VºH@±1ñ?àJ@"Àk»H@šéâ_™I@»¤ÿ†»H@.)N ²9@2îþ_’»H@ã·S­5@NæàòºH@†í@,@á½þw¹H@O£ûÿY+@»¼÷?Y¹H@zêì¿)+@ ®û¿Q¹H@N.l(@ÃáýŸ`¹H@ ðM:€4þ@$t`]ÂH@}Kàº?@Œ @’ØH@Ùñß´Ÿ@è» ¯×H@òY"@£@e… @¯×H@ÉK«ßT¥@(¦@²×H@„Ÿ8€~§@k›€º×H@îR4 Œ©@P üŸË×H@™Ûl«@,™Àä×H@FÖ·2­@ûØH@wIÿ? °@åïÿ_Ì×H@Eð"À§±@–Êü·×H@ŠH╲@wˆûŸ®×H@t‘矅µ@=`Ÿ×H@”|ôŸ˜¹@à—×H@ôþ@¯½@)cø_™×H@‡é1€¦À@ïÀ¢×H@+ÙÒqÂ@Ž¥ö¿¯×H@Ù¿_ŠÆ@ìý_Ø×H@N“!àsÈ@Èû`â×H@ºÿ rË@¹V÷Ÿç×H@™ªæÿvÍ@ûO`æ×H@:¾¬?xÏ@"eö?á×H@-«U`mÑ@°5ÀÖ×H@5Ñ)À^Ò@m@€Î×H@‹G +Ô@º}û߶×H@ÎÒ@ËÕ@áüúß™×H@¦¿°_$Ú@ö?@×H@¥îÒŸ`ß@*ŠüŸh×H@‹ÈM`|á@IÌýq×H@Ó¬C Àä@Ö6u×H@ðŠà+@ W@\×H@ª^àm@ L  V×H@Üß°Ÿ‹ @µüŸG×H@¾qÎ_S @÷\à3×H@ÎPýÿ@'ý÷¿'×H@ŒC`Y@âbû ×H@ÚQÞ¿`@Ê ëÖH@€(¹?î@ Õÿÿ ÖH@,EUÀû@ëDöÿyÖH@Ôì@ßÙ AÖH@ñû@wÇ÷ÿÐÕH@•ù`s@à úÿ‚ÕH@ž™Üÿ2@ýô`úÔH@ñÅÍ_×@èúüÿÑÔH@å…ð?d@pÉõߘÔH@Eî¯?#@„ÿ?-ÔH@¶¡ €í#@\!€ÔH@(ü)À=$@z€ïÓH@$_KÀ–$@ªÿÿÁÓH@ËÇ Å$@ötùÿÓH@¤Ì6%@àö_ÂÒH@UøñŸ‡%@ï7û¬ÒH@õ9 [&@ ˆÒH@J¹ÿ†(@)K@FÒH@ìÙà'+@%ÿ_ñÑH@EÚÆŸ¨,@K°ö§ÑH@ù, -@¡@„ÑH@14KÀ·.@gi eÑH@¸24à$0@ £þLÑH@Úþø¿á1@³:ÑH@×`LÀÐ3@ÿØû¿0ÑH@Í&¸?´6@¿îø.ÑH@ @@J:@ 3ÑH@Ð"€@<@îz`ÅÐH@PL€d=@ í÷tÐH@¡¾D@®>@Ø`+ÐH@}Kàº?@ö5ýŸäÏH@¼& ý=@½àÍÏH@ÃJ w9@$\ @ŠÏH@&6@å7@!  wÏH@ŠsõßZ4@Ù@XÏH@IM7`Â2@û DÏH@ÌÖÀA1@´g +ÏH@J ,€)/@ˆP ÏH@@RÀM-@L˜þ_ÔÎH@eúG,@ ³ÎH@lÂÀ‰*@É÷÷ßkÎH@ ŽG€*@ W@\ÎH@CòßÍ(@9Cõÿ?ÎH@° g'@¼ãû(ÎH@uv®ÿ¥&@…„ÿßÎH@²ÅE $$@ ÎH@$F®‹"@íS öÍH@e,`#!@¸Z ÞÍH@«°à‚ @– ÐÍH@˜î¿ßy@/"þ¯ÍH@_lÎ@ Ê`›ÍH@YçÿÑ@(ø¿†ÍH@ýJ)à…@×óû\ÍH@Ä3 u@G?ù?0ÍH@ë¿”@4TÿÿÍH@M”ïßÝ@ŠsõßÚÌH@# ó?u@ïÀ¢ÌH@™n+ a"@œ¡úÿŸÌH@fm \$@ó¬@šÌH@ôçôF&@^øÿŽÌH@³)Ó?ó'@™õÿ}ÌH@5ùûÿ+@ L  VÌH@ç¿ ¦-@GèÀ:ÌH@Lì±_=/@á¥`$ÌH@¤(ÀE1@‘Û ûËH@.±¦3@&—÷¶ËH@yAá?1@þZlËH@™­'€ƒ.@¿îø.ËH@ðu)àd,@üŽÀËH@u€Ô*@íS öÊH@P5Ý_û)@üK÷ßïÊH@y®1à(@"ÀëÊH@Ü΀;&@€ `óÊH@Ç€O ª$@Ÿmû?ËH@’àn"@k ËH@@¿ïß¼ @/"þ/ËH@òÛ)€Ö@®ç÷?8ËH@jq¾¿Þ@Ü΀;ËH@%†Oæ@®ç÷?8ËH@:½Þ?@Ý4 -ËH@‰¹A@@@ê ËH@!;±…@¤H âÊH@owÞß@DsøÿÌÊH@dȱ@cvý³ÊH@0ßò?– @fBþ_–ÊH@(â¾È @fÀö[ÊH@¯Ü" @}žõß9ÊH@ãKÑ_" @…„ÿßÊH@z¾ ú@…ùŸºÉH@I7Û?Ã@^õ_kÉH@p¸MÀÈþ@RþÿIÉH@LBØßÈö@ýrû?ÉH@XÅÀßÔô@›äà8ÉH@ èËó@„ÿ?-ÉH@ÁèM ãî@ötùÿÉH@Ÿìë@ŽÐ €õÈH@Iy òê@ŒC 4ÈH@dÀ©ê@QHøÿíÇH@#ȵ_Fê@Jó`ÀÇH@6Láÿ–é@õù_•ÇH@ngÀé@d`‚ÇH@“€ å@à `ÇH@;¨' Gä@ âúîÆH@•ÏÙŸä@×óûÜÆH@4é!à1ä@58ø_ºÆH@ îM€å@á½þwÆH@²ÃÒŸå@‹ÙõLÆH@l.@æ@Ûæ ŽÅH@²š2`^æ@;‘ý^ÅH@Âö´?'ç@æ ÅH@Æ+÷Ÿˆç@8Åü?ûÄH@ !›ä@‡ @éÄH@ÅoЋÝ@hà´ÄH@vº°Ø@HfýÄH@a>NÔ@Ìl YÄH@ÀÓ¿NÐ@üÍþ+ÄH@¹ ¾Ì@j³ûŸ ÄH@i· „É@Ž'þÿêÃH@_2àÑÇ@ W@ÜÃH@ëEÄÿãÅ@·±úŸÓÃH@Þ¯À_åÃ@N§ €ÐÃH@• É¼@ÿøÓÃH@Þò¿Çº@0aúÑÃH@`ªüßϸ@ñ…ËÃH@*à" ô¶@óë ¼ÃH@Ê^ÆGµ@ECÀ¦ÃH@d R÷²@×2ø~ÃH@ÒW럫@¹V÷ŸçÂH@í)½_š¨@èà¬ÂH@ˬ8¦@¶Šö_„ÂH@éJ€q£@$t`]ÂH@ì/?`³¢@Ð4ö_ÆÂH@¥š w¢@/ãÀ ÃH@Ëò`‹¢@bø`nÃH@ȧS`ù¢@ÇÿµÃH@™Õù¿<£@åïÿ_ÌÃH@ÑÄ¿ø£@ĆúŸôÃH@ŠÝC¦@j5àHÄH@—+€ï§@ê‡à’ÄH@j5àÈ©@«÷ÿÔÄH@`Õ •ª@Žø_øÄH@o#+à«@ ÷_!ÅH@:½ÿM«@-VýßKÅH@ƒ@ 'ÈH@Æ•Àp@º}ûß6ÈH@¹ìç@ñÜ÷@ÈH@<Ìê_Šy@‰w`QÈH@º>ÿ”w@Ìl YÈH@aË«u@N=û_hÈH@-×6 u@Æìú?fÈH@Æ_bu@@«@`ÈH@ú¿u@ÀÖ[ÈH@#óÈ t@ùÿHÈH@<¡×ŸÄs@ ü_CÈH@ê1Û_‡s@‡Ò`=ÈH@:©õŸ±r@xîû? ÈH@“=``r@X° @ÈH@y.Kr@Æ  ÈH@65·ß-r@´(@ ÈH@¨åæŸ r@¯üÈH@yšH@·q@ ýŸÈH@)áð^q@KqúÈH@ô'¿Òp@»¤ÿÈH@Ö6up@äq ÈH@"P? p@ïøþ ÈH@ÒÙò_Zo@2îþ_ÈH@ñ @o@N%@ÈH@†* yn@àÈH@ãÈXm@ÂcàÈH@£u·_ül@ñûÈH@Ç'èl@Èyÿ'ÈH@Ù-k@`k€-ÈH@ªžÌ?új@e… @/ÈH@ ýÑ?Új@“¿ÿ1ÈH@ jÓ¿Áj@z“ø?4ÈH@" §j@58ø_:ÈH@I; j@©vúÿ@ÈH@–tÖŸ«j@t¼ú_KÈH@by> ¿j@ÄGþ?RÈH@ÿ9 ßj@8†àXÈH@ô¾Tà"k@þ±÷aÈH@†UÝŸbk@A§÷¿iÈH@ àŽk@etÈH@(Tà¦k@³ù¿~ÈH@µ ¶k@7_üŸ‰ÈH@›óßÅk@.} ›ÈH@#uÐ_Çk@v@¥ÈH@žI8€Àk@´à«ÈH@û'4 ­k@Îù_²ÈH@¼£1 œk@üv  µÈH@&‚@€ok@¸ À»ÈH@0Ë  9k@»&`ÁÈH@–ß³¿ýj@˜€ÆÈH@ÿk«¼j@ÎÒ@ËÈH@Óî_rj@ÌÃøÏÈH@Û»íßHj@õ ÐÈH@´ÒÞ¿ýi@èúüÿÑÈH@Fê±i@AàÑÈH@ixÀai@rZ @ÐÈH@´~+Ài@yÖ ÍÈH@†´ß=h@ßÙ ÁÈH@0óÛßòg@.¼ý½ÈH@oä.€øf@DÝ µÈH@ÅÄ(­f@“¿ÿ±ÈH@gÈ_÷e@¤Æ`§ÈH@7žøÿ«e@M¿ £ÈH@‘†®ŸYe@1ˆþ¿ ÈH@5ìß/e@ö·àŸÈH@%m²_Úd@,nõÿžÈH@c4À?„d@aÑ ŸÈH@)Ÿ³?/d@xîû? ÈH@ý‡²¿d@é!@¡ÈH@¬jÍÝc@6¢€¢ÈH@@,@€±c@š? à¤ÈH@&Á<à‘c@iö€¦ÈH@éJ€qc@Í“à¨ÈH@¸nï¿:c@ôQ@®ÈH@§è' c@÷\à³ÈH@4)ì?¾b@Ð4ö_ÆÈH@a'' ªb@ £þÌÈH@†- `©b@ÌÃøÏÈH@ÛeÇ_½b@2àÔÈH@™ÂÞJc@×ýßèÈH@=uöß”c@Æ•ÀðÈH@ÑÄ¿øc@Žø_øÈH@`U 'f@iMûÿÉH@£à²f@Ÿ¬÷Ÿ%ÉH@g ðf@y—À*ÉH@›û/"g@jò÷ÿ/ÉH@âQS`;g@Ó© 4ÉH@?oK`Jg@BÎûÿ8ÉH@}Èßæf@û DÉH@ / ›f@¹ÀÀOÉH@ágØÿkf@à~ UÉH@€gµŸf@³@ý_\ÉH@SIàÅe@@«@`ÉH@É6ô?Žd@ΠmÉH@˜†#@4d@µåù_pÉH@4L›c@r™ rÉH@±Ý=@÷a@¸ðöÿuÉH@Ÿ‚²ßÉa@‚:àvÉH@’‡S ’a@côõßwÉH@9˜M€aa@ŒÁý_yÉH@€çÿ4a@8Åü?{ÉH@ÞÅ€ä`@$³þ¿ÉH@t=4 œ`@¤‡…ÉH@裀\`@ƒßàŠÉH@jIì%`@åmø‘ÉH@êÛ´ßû_@à—ÉH@,™Àä_@Þš ÀžÉH@ÜÚ_É_@ï7û¬ÉH@F™.@²_@?Ãþ_³ÉH@[Ïïp_@Roü?½ÉH@+ƒ¬Ÿå^@Á< ÌÉH@&êܵ^@Y.ÓÉH@©áד^@— ùÙÉH@#wCài^@ æÉH@öL'ÀM^@É÷÷ßëÉH@…1à^@‘2ûŸðÉH@<Ìê_Š]@¤ÞøúÉH@Kò3`V]@}É ÿÉH@Ò«¿-]@'¾û_ÊH@f•ã_]@úöŸ ÊH@5Pð ]@5ùûÿÊH@õ÷Î?,]@”À6ÊH@ `0]@#5;ÊH@} F€.]@)K@FÊH@¦,]@2p MÊH@\Î!€]@õ PÊH@ó—P Ó\@Q² VÊH@Ú}¿\@=þZÊH@ —ÑŸh\@×óû\ÊH@MÖ,À \@Ü à]ÊH@ÖM1 Þ[@ƒ÷úÿ]ÊH@8¿†[@þŸ\ÊH@58ø_:[@„ ZÊH@<0€ðY@ÌÃøOÊH@ù”­?ÓX@Jó`@ÊH@ÓPX@Ü΀;ÊH@_C.@ôW@×´ÿ¿9ÊH@~´Q9W@OdÿŸ7ÊH@Ê]øÝV@­6ÊH@òå_ìU@ôQ@.ÊH@•g=ÒT@Èyÿ'ÊH@h@ †T@±\&ÊH@v´Ü_^T@XFú&ÊH@o£¿Ÿ3T@ì,þß&ÊH@ôà T@à–ú?(ÊH@[:ÍŸÂS@l ,ÊH@ž¹S@Ñšöÿ7ÊH@ŽQCÀÆR@½ˆø<ÊH@î; #R@ ü_CÊH@Æ ‹Q@9ì€JÊH@#5;Q@2p MÊH@xïÉ? Q@ïv÷ßNÊH@X™ß¥P@õ PÊH@bäÀO@”þûßSÊH@¹×0à¸N@ueàUÊH@EDÖ¿N@D€WÊH@¸*`mN@¨¹àYÊH@H¬ÿRN@Åð À\ÊH@ˬ8N@Ì@cÊH@ S1N@ù@ú?jÊH@§È_9N@”æÀ€ÊH@2-û¿4N@êÞõ_ˆÊH@ RŸ#N@(gàÊH@4Õ8@ÕM@»ö?ŸÊH@š(ß¿»M@XFú¦ÊH@f~¹?¬M@:©õŸ±ÊH@< 翬M@c  ½ÊH@ºì¿ÎM@v àéÊH@ýaSïM@õx€ýÊH@“³N@B€ËH@66à˜N@^Æ€ËH@B{ºN@Šž  ËH@¢¯ÏN@à–ú?(ËH@D¯³ßâN@÷\à3ËH@íÀRÀêN@¶ þŸ?ËH@0`,€çN@Ahû_GËH@P = ØN@%ÚOËH@tÓ$€´N@-ÿ`VËH@Ë6~N@G' ]ËH@“³N@¢9üfËH@î{Ô_¯L@’×÷Ÿ„ËH@Y.SL@X° @ŽËH@à `&L@õù_•ËH@i÷ÔL@3— àœËH@lo"À L@ˆü¤ËH@ºù_L@ U °ËH@pÉõßL@”À¶ËH@7ñÝÿ*L@ˆÎøßÆËH@ ~ €+L@´¦ýÿÍËH@ŒZ/ÀL@(åÿŸÔËH@RC€ L@ÇRûß×ËH@€ `óK@ã‰ÿ¿ÚËH@%ÚÏK@î÷?ÝËH@˜M`K@ó*ßËH@c¡àxK@@«@àËH@¾œáK@3 áËH@EƒÒ³J@’˜û?âËH@ë3Nà)J@Èû`âËH@ä·ÿJ@nåüâËH@“iÙÿ¥I@¶KúÿáËH@®ä¶¿«H@šößËH@PŸìãG@¨ú_ÏËH@ûûR`}G@X…öÈËH@Õ¢²1G@û ÄËH@ö5ýŸäF@àÀËH@D€ºF@Ǽ ÀËH@¦ì6 ŒF@ëo À¿ËH@m–&ZF@ñÜ÷ÀËH@Séå E@sþ_·ËH@ûÎÌC@|¢`°ËH@ÿìä_ @@UöŸ­ËH@n;#î8@Äà¯ËH@êH€ð6@l ¬ËH@Ãsßÿ5@Ån€¡ËH@Š1¸ÿ+3@ÖÌ÷ߌËH@4Ò÷¿È0@bàaËH@pH¼ŸÇ.@<¸À-ËH@~Ú°¿O-@ ‹ùÊH@ÌXý(@ötùÿËH@wóØ¿€$@:jù?ËH@Æ,!@†êÿËH@:”>ë@r/ö ËH@µO €Ø@×2øþÊH@_Ù @²Úü¿êÊH@Ö^Ù?.@ñûžÊH@ˆã¯@×2ø~ÊH@_Å5€¯@Ó+ `oÊH@ç¿ ¦ @sÿ@dÊH@¢¸Â?•@ÉaTÊH@uØ@¿— ¸ÊH@Ô}!`„@ì® bËH@³,Àÿ@ëÆý?µËH@r®¼?9 @hÏ@×ËH@éËÚ¿ @v àéËH@ _%@É@Ju  ûËH@}Š @Ý@\·÷_ÌH@ÅÄ(­@‡Ò`=ÌH@©@ñ@¿îø®ÌH@½ˆø¼@Sù?ÑÌH@Ä´NàÆÿ@!  ÷ÌH@Þçßpÿ@wIÿ? ÍH@4§äÿÿ@º}ûß6ÍH@M:€4þ@2àÔÍH@wÜ®Ÿ@va÷_ßÍH@„2è߉@µåù_ðÍH@Èñ¿l @äÈûýÍH@û €T @(ø¿ÎH@{g€ @ã ÎH@¿N >@›äà8ÎH@0´ßÐ@Œ‚WÎH@o$ùß„@·ô€lÎH@Hº°è@º>ÿ”ÎH@;7À/@àÀÎH@þÇS `@z€ïÎH@ @L€i@Ò ÏH@¾²=@ @(åÿŸTÏH@’™É?L!@ÖÌ÷ߌÏH@µcò5"@|¢`°ÏH@|ŽÀS#@õ ÐÏH@ˆüL ™$@’àîÏH@\F °&@‚y@ÐH@ÚªEÀø(@Ÿï€>ÐH@Ñðª*@5{@SÐH@·C`8-@tûö¿mÐH@U `.@þŸ\ÑH@f f.@Æ+÷ŸˆÑH@­€ô.@òBø²ÑH@Ǽ À/@Q² ÖÑH@f¯N‹1@°ùŸÒH@Þ‡î,3@PL€dÒH@^òä?I6@ùÿÈÒH@¶ß9@üÍþ+ÓH@@%€0:@ÉaTÓH@ # Ó<@1ˆþ¿ ÓH@«Û, H>@0aúÑÓH@™–ý_C@~Åù ÔH@O`ýD@ÜàÔH@&”¶Ÿ)G@©7þŸÔH@vJÍ?vJ@fë à ÔH@ôûÝ¿¢L@WJ  ÔH@#€¿N@žûŸÔH@œKÔ”P@õx€ýÓH@_±LàRQ@müßðÓH@k¯ì—R@#ËößÒÓH@3®4†S@e… @¯ÓH@…oH@ØS@uãþŸšÓH@ÅÖ¿-T@ü@pÓH@¢MåCT@6áàDÓH@¿U@-T@vŒ %ÓH@E®åßxT@ 'ÓH@9ê§T@9­ (ÓH@FªÖ_U@'ý÷¿'ÓH@¢áÿTU@ù€%ÓH@—_åU@aÑ ÓH@úgþ9V@Ešü?ÓH@9WÞŸœV@½IüÓH@³:W@k\ ÓH@éâà~X@­¨ûßÓH@¸ï(Œ\@-ÔõŸÓH@Ág`’]@¥ƒõÓH@Hc¼ÿò]@²ù ÓH@«Û, H^@ƒßà ÓH@3m^@´(@ ÓH@ÓB4€Ø^@d`ÓH@ sà%_@HfýÿÒH@¥Y°¿²_@=ßýÒH@N ¸`@\xûÿúÒH@Þ(`}d@àõÒH@º€<`Ãd@#ËößRÓH@¢åH€ýd@müßðÓH@ ð8 e@„ ZÔH@ß. ¼d@ìý_ØÔH@o:U„b@HfýÿÔH@“kL€H`@#Œú0ÕH@w¶Oà_@û €TÕH@óiü_^@Ì«|ÕH@(ÎÕk]@dÜý¿¤ÕH@§Ô>€¹\@½ À÷ÕH@Ð"€@\@xîû? ÖH@è9ù_tZ@ÙA zÖH@Œ±_âY@}¢ÖH@ÐI­ÿŒY@åïÿ_ÌÖH@áù¹_ Y@Š4ù8×H@iàª_§X@SW j×H@æ?b[@à?À²×H@²o ˜\@ïv÷ßÎ×H@oáíÿë]@ôøÿé×H@æÀÝ`@Ðö¿ØH@$³þ¿a@?ü_"ØH@¡QôŸ¹c@Roü?=ØH@¯x  ïe@`ªüßOØH@9nÀj@Ju  {ØH@®Ïÿåk@üŽÀˆØH@‰bMÀ o@ÓjÀ‘ØH@ „¶ÿut@Œ @’ØH@Ï$@ày@r/öŠØH@,@ý{@ÕÐ`ƒØH@IµÓÿ~@á½þwØH@)Í€@å.ü¿nØH@Ò™(΀@WößVØH@£ 6`©…@™õÿý×H@1Þ$@,‡@Ý ö_ç×H@çéTà‰@«÷ÿÔ×H@:E`Š@‘óþ?Î×H@äÜä¿Y@öö@Â×H@»eÀã‘@Ü΀»×H@Ùñß´Ÿ@è» ¯×H@ X:¾¬?xë@e… @¯×H@]: è@’˜û?bêH@h-×6 E@`, êH@·ßNà¥I@PÊÿ?©éH@N€þJ@S–€ŒéH@Ë\*€sL@ŽÐ €uéH@¾„éÿEM@ª^àméH@œÁß/N@ù@ú?jéH@Aæó O@É÷÷ßkéH@¯âÀ×O@%ÿ_qéH@—Þå¿“P@žq ÀyéH@§¦ê?çQ@ªþ?éH@öaÞ_S@ëù?¬éH@™â?T@Á< ÌéH@ÀÖ[U@B€êH@æÿÙ2X@`ªüßÏéH@Ðô+:Z@;ö?£éH@ºù_\@etéH@ ~¼_]@G~õŸRéH@!h7Àí]@‰8/éH@N¾4 9^@«F ÀéH@è"Ï? _@°ö`´èH@¡ø?—_@S–€ŒèH@éâà~`@A§÷¿ièH@3–<à²a@P üŸKèH@ÐHßÿ"c@à?À2èH@Ô'ûßøc@ú`(èH@lÂÀ‰f@"MþèH@ÙDE ‡j@¦ªù¿ÝçH@ï#àOl@*öŸÎçH@àì À3o@ö?ÀçH@ñòS ?r@>E îçH@ Àæs@§éõèH@ƒa Æu@`, èH@?×çÿz@WJ  èH@1°ÐÿY|@11 @+èH@›¹òó}@Jó`@èH@O¸²Ÿ €@m€gèH@@@) ‚@7 ”èH@¼£1 œƒ@. ÅèH@¦ðË„@ð^ÿ¿ûèH@  ½Ÿ¿…@’€éH@V¸'@û†@³:éH@ìZR yˆ@­* QéH@×ÕŸP‰@¨¹àYéH@Ôÿ( ?‹@Ò‚þßdéH@ú? ’@bø`néH@‘ˆ! ü“@Ymþ_uéH@ì, í”@n(`{éH@þœ@àš–@¬¬ `ŒéH@ +&€¬™@0Ë  ¹éH@I7Û?Ã@(¦@²éH@‰Ë·_º @ÕÀ¥éH@äàƒ¢@›¥ €–éH@+±à·¥@ ÿõŸoéH@Ï#N@v§@Ïw@_éH@XC¹Ÿ­@Ÿï€>éH@ó>éŸ;°@6¢€"éH@'©DÀ¾±@G©`éH@úÒÛŸ‹²@¡ø?éH@þÙÉ¿´@k éH@ޛ׿ˆµ@‰ 1éH@ OÀÀ¹@0 ößséH@ó×`»@j àƒéH@C ·ßN¼@Æ+÷ŸˆéH@$ÿB½@r/öŠéH@÷³õ_)¿@(ø¿†éH@ŒmJ`Ä@æ eéH@‘ŸK@eÃ@”=ø?öèH@­UàÃ@=uöß”èH@Ìî àÃ@Vàù4èH@n{í_zÃ@†« îçH@¹Õ½_Ä@Z” ÄçH@zç«?Æ@É÷÷ßkçH@ ÿÜŸ¤Ç@©7þŸçH@û%ÁŸ É@tûö¿íæH@¬­Ø_vË@÷³õ_©æH@š>;àºÒ@7àæH@øô¿ùÔ@™ ÕåH@D1»žÖ@ïõÿ»åH@þðó߃×@:©õŸ±åH@mÒáßoÙ@\÷£åH@'¯_nÛ@ž° œåH@-$`tÝ@)cø_™åH@n{í_zß@™–ý_šåH@òm àwá@äøŸåH@íj,@_ã@‹šùªåH@ü#% 6ä@:©õŸ±åH@»yì_@è@ZùŸÛåH@do­0é@þ±÷áåH@º”% ë@¹V÷ŸçåH@•å5Àí@6 @çåH@¤Ý*€î@éû_äåH@ÉM`÷ï@hÏ@×åH@¦ðËð@DsøÿÌåH@k=À‹ñ@&@ ÀåH@*¡&ÀÑò@¹ØþߢåH@zÓŸÀó@lü?åH@ºù_ô@ ñ jåH@hb²Ÿbô@n¦ @åH@ƒàÐßtô@ï¡  åH@9@ô@côõßwäH@WÜêÿ=ø@ í÷täH@ŒC ´ø@þ 8äH@é6¸ßgù@µ$ö¿äH@¢9üæù@ˆP äH@ËÛð?"û@PL€äãH@&AÑŸªü@2p ÍãH@ÙDE ‡þ@ýrû¿ãH@Ò.Kà{@Ñšöÿ·ãH@éŽQà•@Xï °ãH@ l-@™ @¼ãû¨ãH@¨8ÌŸˆ @æ ›ãH@òm àw @Ñ@‘ãH@ß…R X@¤‡…ãH@Ý 7àó@§S@hãH@ž¬ÿ@&—÷6ãH@ñ/Ý¿@ÒÅ ÀýâH@õÏüÿr@2àÔâH@5< }@‘œ ÀXâH@òØèÿÉ@$1÷DâH@÷ à´@Ù€âH@ä¯æ@™WøáH@i9`?@ÏÎõ¿ÔáH@]: è@$³þ¿áH@Ì®A€ˆ@'ý÷¿'áH@”Ý?õ@_íÀèàH@t¼ú_K@g*@ÃàH@Ì€í?¶@Y ààH@á¨Gà0@„ ZàH@¶ß@q±ý¿EàH@[»à@‰ 1àH@š%à[@§’  àH@hQ €@žûŸ‘ßH@Û¦6@‚@µŽàzßH@– :f@-ÿ`VßH@éŸ\@–L`òÞH@ë±? @èúüÿQßH@ʳ? @1÷eßH@¬jÍÝ@müßpßH@‡–L€'@…E€|ßH@#ȵ_Fî@Æ ‹ßH@j " ™í@IÀNßH@1ZªÎì@ñF (ßH@œK ë@¸ðöÿõÞH@õ Pè@ãJ`¸ÞH@ù¿cß@»¤ÿÞH@Ù×ô’Û@ö?ÀÝH@IN`,Ù@¶Í@ÝH@2ƒ!@ÀÕ@äÈû}ÝH@á¥`$Ô@/¤`jÝH@sÀ àÁÒ@eÄ QÝH@ðÃÿ%Ò@g*@CÝH@ÙÖ&€(Ñ@6¢€"ÝH@i8àÊÐ@oÍ`ÝH@ŒÈ¿…Ï@¿X@–ÜH@ÏxÏ?ÉÎ@ؘøpÜH@å°*Í@iŒ÷_>ÜH@f+Ô?-Ë@; ÜH@’V¾_³É@ ‹ùÛH@üä(@È@>œúäÛH@ÔD@2Ç@³@ý_ÜÛH@=a @8Å@È€ÓÛH@_€.Â@û €ÔÛH@ìZR yÀ@O£ûÿÙÛH@Ø„€½@A§÷¿éÛH@û»@L×ú¿vÛH@Ÿ× `ëº@LY2ÛH@Ø1*€”º@³ºÚH@›cÌŸgº@ U °ÙH@}_ùº@‘ú_lÙH@çÒ*À˜¹@1ÇúCÙH@¨ÛŸ¬¸@ÀTù¿ÙH@Dñð¿¸@ÇÔ ÙH@-€B §³@|áÀÒØH@ØïìŸe±@]`à§ØH@@— °@äq ‡ØH@傯¿W®@­* QØH@¾7À«­@Ó÷Ÿ)ØH@FÖ·2­@ûØH@™Ûl«@,™Àä×H@îR4 Œ©@P üŸË×H@„Ÿ8€~§@k›€º×H@ÉK«ßT¥@(¦@²×H@òY"@£@e… @¯×H@Ùñß´Ÿ@è» ¯×H@»eÀã‘@Ü΀»×H@äÜä¿Y@öö@Â×H@:E`Š@‘óþ?Î×H@çéTà‰@«÷ÿÔ×H@1Þ$@,‡@Ý ö_ç×H@£ 6`©…@™õÿý×H@Ò™(΀@WößVØH@)Í€@å.ü¿nØH@IµÓÿ~@á½þwØH@,@ý{@ÕÐ`ƒØH@Ï$@ày@r/öŠØH@ „¶ÿut@Œ @’ØH@‰bMÀ o@ÓjÀ‘ØH@®Ïÿåk@üŽÀˆØH@9nÀj@Ju  {ØH@¯x  ïe@`ªüßOØH@¡QôŸ¹c@Roü?=ØH@@Ö&`@ ‹yØH@/Nßß^]@à?À²ØH@ë[ ãZ@/ @ñØH@ÜÍ:€ÑW@½àMÙH@î; #V@¢úÿDÙH@{©T`3R@QúßÙH@‰`Ú?hP@ÓjÀÙH@´|¸?rN@âbû ÙH@¸šÐjK@H ÙH@R®øŸ_H@ÎPýÿÙH@ùí@kE@aÑ ÙH@G@àÜ>@ƒ÷úÿ]ÙH@’ÆO€´=@üv  5ÙH@Ï£âÿŽ<@­¨ûßÙH@uv®ÿ¥:@*ŠüŸèØH@aæ·¿å7@ U °ØH@¼aô?m6@èxõ¿–ØH@9,ËßÖ4@óiü_ØH@ßØ_ú3@ ‹yØH@%îëŸ+2@>E nØH@—ä_O0@ÕûjØH@nx¬ßm.@ÕûjØH@t'Ø+@ؘøpØH@rÞÿÇ)@øÚùŸxØH@ ? (@P‹à†ØH@sjã_6'@?„‘ØH@öcQà¶%@PÊÿ?©ØH@þ®¶ÿT"@š½ éØH@Ý0Àô @,@ýØH@|âο< @Wþ¿ÙH@f–±_@ötùÿÙH@0ÈÈ-@Wþ¿ÙH@EMà@‘Û ûØH@v àé@,nõÿÙH@Œ;@(@iö€&ÙH@ÓV 5@¤Æ`'ÙH@IúQ`C@XFú&ÙH@ƒ‰Ü_@3— àÙH@U#`M@x¯ÿßýØH@+… ˆ @müßðØH@Y¶ÿ– @´éàæØH@…ñO€“@gi åØH@ÿ1–@š½ éØH@ù€¥@TSõŸóØH@hÍŸã@t> ÙH@ ôG w@ ÷_!ÙH@Ã:ÀYÿ@À“õBÙH@¶‹Ä_îþ@(åÿŸTÙH@ÏLî™þ@/¤`jÙH@BÑ<€Eþ@ú( —ÙH@–Êü7þ@û¦úßÛÙH@‰öÊ€þ@²Â —ÚH@ºlSÀfþ@MþþÿÅÚH@/v±þ@*3 óÚH@S“¿ÿý@ÂcàÛH@3®4†û@} ýuÛH@gá_Âø@¿ÀÜH@šÀB vú@Y¬ú¿—ÜH@ëH`9û@Ê ëÜH@iŒ÷_¾û@¥üÿÝH@bwËü@'ý÷¿'ÝH@d Bàý@¶µ JÝH@…²S qÿ@À¾à‡ÝH@s+çÿÿ@58ø_ºÝH@úØÿ­þ@œ#@ÛÝH@Ë™³_óý@Y àÿÝH@/ÎJ Fü@˜€FÞH@/yòŸ$û@È:À„ÞH@/d;^ú@|ùøߥÞH@¢P& Où@RÀÇÞH@CÊìÂõ@PÊÿ?)ßH@ç꿵ô@ñ…KßH@—+€ïó@"ÀkßH@(OÀ¼ò@,€©ßH@× Ïñ@†lÀËßH@SIàÅí@ ÿ¿=àH@,Ø ì@r™ ràH@ƒŒà‹ë@§ àÅàH@:¾¬?xë@–L`òàH@ÖâSŒë@&@áH@¯âÀ×ë@j5àHáH@·I ì@$t`]áH@3þØøì@@ê ‚áH@¢·ô?+î@Šž  áH@ˆæðÿ™ï@Š4ù¸áH@’¬äß>ñ@¶µ ÊáH@Þ† Âô@N=û_èáH@Ôÿ( ?÷@¾¯ü¿ âH@²„Ö?_ù@7G€6âH@«)kú@hÏ@WâH@by> ¿ú@š½ iâH@bàáú@œbþŸ}âH@‰tÃßÄú@÷€‘âH@Ÿ-1àvú@ô¨ø¿£âH@á%ƒù@. ÅâH@Ìî à÷@ßWþßãH@ƒû¿òõ@dÀ)ãH@¾EíŸ#õ@ ®û¿QãH@È#ÙŸ›ô@V¡ý’ãH@e™òß‹ô@æU¾ãH@„qä?¬ô@v àéãH@>³$@Mõ@Ó÷Ÿ)äH@HåÃ?®õ@ ÿ¿=äH@Ù°_¨ö@@«@`äH@¤ßßù@ý3ÿ¿œäH@¾¯ü¿ û@\÷£äH@KÅ­îü@<¸À­äH@H @¹ø_×äH@LBØßÈ@êŸùÿåäH@E `@ÓÁú?åH@ïv÷ßÎ @ÇÔ åH@è» / @ötùÿ†åH@¦¿°_$ @@«@àåH@ S  @ ÷_!æH@u  @ñ…KæH@€П‘ @”§`^æH@×´ÿ¿¹ @ ÀæH@g;®_@ZU@¢æH@-VýßK@rZ @ÐæH@p À?¥@Ju  ûæH@ BP @•% #çH@Oº% Ã@x1 9çH@ë3Nà)@ueàUçH@Ž¥ö¿¯@ZÓþÿfçH@=ö/ æ@×2ø~çH@ô“A ]@úöŸŒçH@‡|áß±@WJ  œçH@J‰ò?Ø@О€®çH@ÑÚÀ_Ä@Jó`ÀçH@:g¸¿‚@›zö¿ÐçH@×Ç`¬@>E îçH@þÝà@¨z €7èH@ ÄŸÙ@ìý_XèH@WîŸ@éâà~èH@ Á`Ä@÷³õ_©èH@e„;@Å@(åÿŸÔèH@ï>àä@SW êèH@ÎdæŸl@¥üÿéH@—3>@µ@MþþÿEéH@2²¿G@2îþ_’éH@_€."@2àÔéH@PK9€ú&@. ÅéH@œÌ Àå)@W‰¿éH@íG@à,@¢@¾éH@Sù?Ñ.@y-øŸÂéH@´ýñÃ/@eúÇéH@»Rà®0@2p ÍéH@(’ U2@@«@àéH@'?5 Ö3@½ À÷éH@; n7@sþ_7êH@ÌXý8@DsøÿLêH@ëXߟÖ9@™ UêH@÷ ÀÄ;@@«@`êH@Ø¿Â<@’˜û?bêH@IM7`Â>@Ÿ.ÿß`êH@­A-@º@@ iÀWêH@aà¬A@„]ûŸOêH@¯8A@cC@þ 8êH@-×6 E@`, êH@raster/inst/external/rlogo.grd0000644000176200001440000000061614507510157016201 0ustar liggesusers[general] creator=R package 'raster' created= 2010-04-16 14:57:47 [georeference] nrows=77 ncols=101 xmin=0 ymin=0 xmax=101 ymax=77 projection= +proj=merc +datum=WGS84 [data] datatype=FLT4S byteorder=little nbands=3 bandorder=BIL categorical=FALSE levels=NA minvalue=0:0:0 maxvalue=255:255:255 nodatavalue=-3.4e+38 [legend] legendtype= values= color= [description] layername=red:green:blue history= raster/inst/external/test.gri0000644000176200001440000010770014507510157016045 0ustar liggesusersÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀbæ#DUDÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀitD-ŽD:D¦æCY„ÈC, ´CýB CŘC©–CàˆCùƆCÞ½’C}·™C]F™Cª‚›CÞ£C#«Ci±CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÞñD¿%D—DÛäD$íC¨ŸËCÊ0³Cì~±Cÿ?§C÷ZšC{(ˆCµR\C©LbCÙ’ˆCõÄ—CTÑCÙ¥¡C€ƒ¦Cß ¬C÷W±Cg`²CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ¨DùŠD·PçCå¢äC¬ÊÜCo`ÄC ™±CÙ0¯C|'¨Cwõ•C«¤oC!_C…qC; ŠCì÷–C® žC’âC9§Cdæ«C¯Ñ°CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÈ…D;9D*rDâCVÔÜC“ÔCÑsÁC—§®C‹‚§Cd2£C ”C¡¯pCbnCz„C0cC;–CN¢›CáQ Cõ?¥CWIªC_øªCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÝnD1.DiÉ DØPD¾–ëC)øÜCûìÌCR¾µC \˜C·ä”C×÷›C5è—CÝÈC£¯ŠCIŽC©þCp’Cuw”CÛñ™C‘Ç CÞú§CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ3 DÕDöDªûùCÖªæCbpÕCNÄCh¬®Cö‘Cå C—€—CÇÆ•C2å‘Cå‘C«‰C ŒCc)„C~„C°¤ŽCÝJšC‰Ò›CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ»DÐ(DDœDuòCÒÜC *ÈCæù¸CýͬC}ó CºšCÖ”C#“‰C*M‡CÞ€ŒCgCKƒCÖÑ]C/š]CsíC1µ”CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ§îDÒFD·L DÊÑDÔ“èCÞ„ÍC–±Cð£C*½¢C\æ C£šC¨zŽC‡ uCofsCxº…CíMŠC:€C>ÅRC¹oSC½F~CO?†CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀT¥"DçDn˜D+výC õC*œÞC2'¿CI©–CÄN†CÊQ“CSV™CÃ;•C%ŠCJ vCññtC†¹ƒCk«‰C»†CBëzCRn{C>‡CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀI”0DI DÔóD@0ûCèhîCƒ×CR¼¸C³’CÕ‚C4ð‹COGCò}Cé„CLmkC¼ÏlCÀ(€C÷ôˆCbåŒCóàDN|DrçëCzÈÝC‡FÕCzµÇCÇ·Cƒ ©CðœC} “CÝ’CbýCK@†C5{CP¿„C¼ØC'5šCuœCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀëfZD>AUD£’GDé92Dó\DL¤ DÏâùCúäCbÒC™f¾C¼a¬CŸº¡CÅÏCår›CÂ¥˜CÒ¨‘C’C¸È`CÍÜyCeuCá+›CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀì÷|D|jVDÖJD2ÑHD²Ë2DêØDÁ¯ DÔcûCà7âC úÇC…­C–˜“CwB‹CM‹“C†=™C’´™CyÔ”Cã‡C?}{CÁ†CÑ`”C¦™CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ) D]è‹Dgª[DÄÖ?Dʉ5DÛY$D D:Q DŽùC !ÜC«ºCèK™C £xC÷ÆlCO‡Cã‘CÉ–Caê—C»Ú”CJ’CýÏ•C…¶›CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀïHtD¤–DCb†D8l•CמC£Cö¦CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ'rjD¿]PD,öHD¬SCD©`>DÒn8DG1(D D XçCˆ°ìC÷CVõC'8äCòyÈCÀ±½C9÷·CÍ׫C1¼žCCCΉjC{fCt‚„CΕC–ÆŸCc¦C넨CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀL³ŸD}¹DK’˜DÔ÷nDrŽQDG6KD…¸BDÐ:9Dî80DYDxžëCö°CxOÈCÆßC\~àC€öÎCRD°C¸%¯Cy#·CéŲCÉÏ¥C3’CÑuC·±nC]ç†CΗCS^¢Cí©CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀBD Q±DÛÙDC¦®DËŸDg´DÇ¿ DÇf{D5°TD*ìLDnùADaÇ7Dz².D’àDGíC϶ÅCçÂÆCÉÍCÝÏC·«ÈC–a¹Cž@·CþºCýQ·CßÜ«CI*™Cä¥Cá¢{C~%C‡NœCä’¦C¢›©CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ#cDî‡DÔä±D[?›D_ÄD~ÖªD ÎDR °Dn8ŸD Ñ©Dˆt™Dt·wD·xQDM£BDœ7Dt8,D@âDe DCÞC5±ÇCq.´CöѬC“¹C-4ÃCÌÃC/ÂC½ŸÀCEû»C|ü²C¬¦Câ#™C‰•CÕ œCÊú¤Cù/«CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ^x[Dü³aDWî‚DgÞ¥Dàˆ–Dô[‚D‹fŽDg5¡D”–D|t–D`ׯD0æ—DÉlD6ÚFD·7D/D9!D¹r DÃÞÕC \¥C l¥C¤ ŠC zC´ŸCmEºCþëÃCì ÅCˆ$ÄCz7ÀC"í¹C·²Cf!«CsB¨C|ªC}?®CF»°CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀƒÔZD0`DSDZDxdDÙ¶sD56_D›íMDåÖWDÂ\jD]qnDXuDµ8‚DA²kDl+JD {5DÞ$/DïË0D+DâßDÚ[±CIVoCɽC®‚CÐPqClÏšCŽ ·CÚÞÂCbÆCì ÆC‹yÃC¶f¿Cl§ºC…¶C9P´Cfi´C9å´CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ}Ð^DŠtYDîXDDÅIDÁ AD õ9D»Ž0D€!Dª®+D(„=DÐ&AD˜t1D‘ DmÎD…LDJ!D«@#DŸ(DêDB¹óCk ¿C‹'ŸC…Y£C¬¢CN4¡Cƒ]­CK»Cp2ÃC‘ÆCÂÇC¤ÅCí.ÃCðIÀC6²½CÐ ¼CU›»C瓼CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀLGwDð_xD¢ZDlAD U/D‰¤ D, D§ê!DED6¢DÔ¢'D”%DÙy DîÀ·CyxÏCÆD¹ D|¸ DÓè DGÖþCn`ÙCÒ‰»C×Û±C›{±CIJC º³Cn²¸Cøë¾CܽÃC¼kÆCrFÇCÎÏÆC¢ÅCvÒÃC7ÂCDÁCôÒ¿CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ•»sDçƒDÈ5SDÂ-DýDYŸD×:DžÕD&D%DQLDÎ\DDñ ëCåéC_/øCßòüCQ`øCMÈñCEZàC\ ¹CsœC Ó¢Cª”«Cv.±C̶CUìºCÙz¿Cœ)ÃCÿœÅCUÚÆCSÇC©«ÆCÝÛÅCbùÄC¥CÄCgŒÄCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ±ŸDDQ•KD^æ=D®¥DDBDùéCÑ°êC`Dïø DíåD9—D( DRúD;aóC ¯åCæÌßC¼øáCl~äC¶ÔãC½ûÒC¸¶¬C#CCu0ŽC/˜CR¥C¡I°Cž·CÒ*½C ,ÁC¸úÃCo¾ÅC»§ÆCgïÆCÚÐÆCG„ÆC–õÅCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀoJD;-DÌVòCÚ ÄCƒ åC4ªèC)¼ÊCÿÖÅC-þâCJÞüC÷(D»WDÌwDÔ²òC,©ÞC ÄC'ó±C2OÀC¬¥ÑCþHÕCmÈC°C×Ü‘Cu_C_QtCü*•C>W§C^²CŽ!¹C¾C' ÁC$ ÄC'šÅCb„ÆC ýÆC"2ÇC÷HÇCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ.÷OD,ƒ+DC¨âCg×·C>0ÓC!ËCùé‰CD?€C¦ºC›~äCE¨óC~–ôCÿìCˆkÞC·LÇCý²¡Cj¦‚CüpŸCmÚºCÜŸÁCñ²»Cµ´ªCï ŠCu>CãtYCM-‹CFVŸCïÛ«C§c´C4rºCí;C7ìÁCaÄCÅšÅCu™ÆCLÇCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ¥7Dc8DCt DæçDu7çCAäÞC‚tÇCõ/C÷i†CéµCTØCØäCëRãC4RÛCç*ÍC}·Còƒ—Cr0„CÝøšC»ÿ°CçǶC槲Ci¥CZ¼ŽCwånCðklC1š†CYI˜C”Ò¥CÍ•¯C‘¤¶CBÌ»Cº”¿C¬YÂCv]ÄCFÓÅCGöÅCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÁî%Dæœ DÈhDÒ DÆãíC!áC ;ÒC«¸¾CøBºCÈC1¼ÔCBØCØ ÓCÈÊC¯‘¾Cé;«C“SŒC§W‚CКCwç­CÐr²Cþö«C†¹žCãˆCPnQC»CCÜqCsSCw4 C)«C ³CúÛ¸C5½C>zÀC›ñÂCBÅCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀUZ,Dâ/D¬ D,MíCÅ8ØC‘¢ÔCù¾ÓCR%ÐC²yÎC¡LÐC¦ÑC2šÌC#¦ÂC')·CÆ2¯C"€¤CJäŒC꼄C˃˜C¿¦C“¢§CH Cˆß”Che€C[‚3Cœ1$Cœ`Cþ"‹CiœC€§C‰ë¯C»/¶CõºCÀŸ¾Cè¼ÁCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ†Ã2DvR!D" DðVÃC3¥¨Cõ̹C·ËCâÓÐCµIÑC„¦ÏCËCã¾ÀCÓB®CY™C)à—C ÖžC&CÕ7›CµC5ôœCŸ;˜C±C·C†C oxCâUC³dOC•¥oC{ÊC¿™C>õ¤Cõj­Cíæ³Cð¸Cã¼CÈn½CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ'MD¼d#DœDþìCèýŸCe¬€CJM¤CKÂCpÊÌCõIÎCÈ‹ËCþºÄCæ(·CÇC ësCp®}C“–C²³ Cø¡CžœC ”Cú‹CÅdC\NaCÌbC¯ÜDC˜9KCKipC‘YŠC´s˜CI:£CÙŠ«CÍ ²C¦4·CÉ™»CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀú×DöDg}D&VåCѧ³CÎJCÆV¯C×ÁCª/ÉCGâÉC±¸ÆC’Ï¿CÅ7³CiÖœC±¡€CêƒC}—CÝÄ C}õ¡Ce‰œCß’C‡3‡CóéBCü"IC¢]SC=$CYõ2CvˆiC%܉C|ê—Cî9¢Cg;ªCL°C¿ÅµC¦¶CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ¹D»¼DDà8ãCÔÈËCÇ ¿CPð¿CÇÙÃCµ¸ÅCŠðÄCEÈÁC6¼CÚô²CE_¦C› šCdu˜C7œC*ןCw¤C_£Cªy™C²ŒCYéuCMmC\^gCÊŒMC>ÆTCïxC®RŒCz˜C Û¡Cùa©CŽ‰¯CдCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÞóDS DwFàCãÏCWËC4ÆCß´ÂC,ÁCtBÀCÔß¾CUE¼Cïÿ·Coë±C°‡ªCÇl£CI°CAá—C½Ì–CJ‰§CU­CÊþ¡C…••Cd„‹CÇë„CÈHC˜2vC™ºyCÝM…C›ÃCÉw™C‹Ì¡C6Ó¨C»®Câ¯CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ{Dñ(ñC ½CVjšCl.²C"ôÀCbÀC`{»C‡<¸C2D·C«ç¶C¤—µC2ϲCe£®CîZ©CÖ£C*¡šC¼•ŒCºüC¶cžCV/¬C£CîÓ˜C!¡CK¼ˆCà€C‘âxCÙo~C»8‡C4»Cm½™C@£¡Cc¨C½8®CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÌG DóC&u¾C-¥CrŽ±C™s¹CÂö´CC|«Côð¦CS©C–¬Cz|­C^$¬C‡P©C„U¥CØŸCñh—C~ɈCK§vC]ý‹C⃚C¶,›C„–CÁfC,„C—gCùªRCìŠcCºGCþ¬ŽCŒ ™C´D¡Cq¨C˜l©CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ©Ö D0‡DyïòC5ÀÊCõ’¹CœWµCïײCW]¦C kCȉC¢ò•C CX-¤CŽÏ£C1ö¡CcUŸCX›Cs•C’˜ŒC÷¿†CL‹‰C ½Cø“C(ó‘Cñ¸‹C”õxCݸ>CúŽCç×*DÛ˜-DæD‚`äCÍSªCÜœ C…`¯CŸœ³C2 ­C•÷ŸCcyCñÎ…CÇôC"2|Cõ-iCì´7Cº0C}^C÷©{CóýCêtCCÞ]CoVC‘gCQAzCSЂC1š…C©ó†Caí‡CŠË‰C—C¡“CÇa™CX&ŸCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ(«-DD5D Š+D9öD·` D5uáCô¸¡C|ƒšC˜²C÷Cö«Cvé˜COK~C÷åZC=8_Cè0YC=…XCw„EC¦xDC][bC¯jtCæ‰uCÄ{qCƒ£lCûœjCÁynCûtCaDzCwCkÜ‚C^/‡C;ó‹CË ‘CÆs–Ceÿ›CÉCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀZ+)D€2DKt‘CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ™?fDI/DD?0Dï@$D­~Dr¹DÂDšgDïBD' DÊGD‡ÛDËhÚC·Cá CÖ¬•C¶ “Cr “C°‡’CM·CYÞ‡CóiCÛÄ-Cu%0CðXC»JoCD*rC)"kC“„`CbyVC áSCóC\CgmCÛCšˆ‹Cî ŽCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ´×eD:š}D ?wDX,KD0h1DfH#D~}Dx^D/ó D,UDÀãDE»DÕD šéCîLÍC‹~±C°;™Cñ|‹CtF‹C•ŠŽC0‘CêðCW™ŒC„‚CʬiCÔ¯eC½uCÖˆC5CÃõtC_C~ºAC«Z=CJ+VC´sC.…C àŽCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÞörD F€DxlD+3jDЮ[DP>*D o Dó(DKD:ìC‚báCUoÜCÑvÖC\ZÏCú­ÈCsÁCÀü´CO¡C›¾ƒCØÿcCI¢|CÊA…C©Ÿ›CÔ~›Cp0“C*šCCž•CòƒC,‰Cìï…CÃq„C”~CbÂlC~‡jCíš}C/x‹C!b–COšCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀá„.D×9DFD~HDó–;DˆÇDIÆ4DZÍ.DMY%DPlD[ƒD«ßC‘½Cš^¿CEËÆCÊÂCúGºCÅ‹·C]†·C‰Š³Cšõ©CYÒC;˜CÅòC2‘¯CAAÖCèíC lÐC­ð¯CÍ”›C’’C«ŠCÄæyCõFuCIÅ‚CãJˆC>R‰CE‹CÃwC˜CwËCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ6›*Duä>D ^DéDQD¸~4D—›'Dí;%DͱDž D^u D‘žñCð¶CLÓ„CËœCŸõ³C­CX›C<_ŸCä¬Cap±C â¯CŠv¬Cد¬C½¶C›?ÒC9o D8+(Dµ0DTe¸Cq¢ŠCXC†C%Ý‚C*”]C@µZC¦„C¾tŽCŸ¤•CÑšC’žC¦Ë£Cd§CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÔDÎù%D˜¼Ý¢Cæ£CÉצCÕ}ªC‡Ã¬CR ­Cq­CÐf¬Cb«C’Ô«C. ±C¡u·CJù¹C#¸CžfµC&1µC‰·C6»Cif¿C›ÄCÆ×ÉC,ÎC(ÑCZ×ÒC}ÓCsfÓC(µÕCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ²DF£ DüÊ DçGDD®ZDö\DÚêD»°D=tD°*D³°D…>ÙCÀÎC^íÍCÉLÉCÀCÒß®C¾P”C6‡C“C7 C8¦CÍÁ§C±z§CçÜ¥C›j¡C…=˜C«PC6Å–C¸'¦C„ä²C|ºCˆu¿Cx_ÄC4ÊC4¬ÐCÙ×CÑÃÜC¬áC¾ãCmÅäC“fäCÏïâCó»àCÛâCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ‰Dsf D7T DP DTˆDß9ÿC.fõCPTóCbžöCf­õCoíC mêC6÷·C•ñœCÅðºCgFÈC,ÅC½ÅºCyz¥C‰|CônWCF«ƒC}˜C±žŸCSÍŸC¼žCãœC€”•C\=‚C+>XC¦ãnCöŠ•CÊ­C|ž½CrrÉC:kÔC•¾ßC©þêC}±ôCÜUûC2gþCþC¨–üC½DùCìßôC–ÌïCjºñCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ?¬Dh^DÓ–DE DMvDèèÿCÌqñCíäàC_ªßCÆÊèCèÃëC¯´êCÚ2òCX×C¢¿C±ìÀCÐŒÂCôɾCD%¶C]'¥Cò ‰CBŒvCüˈC†•C#q˜C3å“C*vŽCBC‰,CÃzqC¤9C åUC¾óC!+®CÁ¦ÃCºÂÕC3ýçCÙyûCÔ`D¹D(ÆDr“D=DOž D!êDÁÇD]SD¾ã÷C«^øCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ¯¥DpœDjLD wDøDðÔþCÀ®óCR\èCm0ÜCú2ÛCÖ]áCEœãCßæCaEóCSÚCÛKÇC׿½C+^·CZ£´CUаCÆ˧CšC¹³‘C9cC©ù‘CäDC›Ý„C7ÿoC †~C¼n‰C²$„CÈqCò‚Céì›C”+¶C¨µÍC›˜åCȃDΩDÙ¤!D‹.D–2DðÊ,DÅA$D>ÚDܸDWD„s D‘ÒDÝ(ÿCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ®D~aDD—ÇD÷EúCbðCeÍåC—ÒÞC̤ÛC-gÛC)ÉÛC_ÄÙC¯2ÕCkêÅC²´CcîµCl©C…†œCUë¢C̨Cá,¦CFYCn<‘C‚„†Cçé…C,µ‡CæóxC$UXCÍ#oC« ŠCR°‘C™”CûnœC×,­CN\ÂCl®ÚCLiøCZÕD´*D’þHDJaD}ôbDI PDì0:DIv,DüŒ$DHDùšDnR DÑDZMùCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ«ÔþCyêD¤UDGñDgÒDÛ£òC±YâC˜>ÓC¬ÍÌCÒVÏC8‰ÒC/ØÓC<ÑC³ÜÊCq~»CIë«Ca–¬CéÓCÊFsCZ[C¶ Cª!¢Cñì˜C¿õ„CÆ>ZCÐaCd0CÒ^C¼xCý”ƒCAøC®!›CMâ¢CÁ§¬C-òºC>JÎCväçCI¶D‰ïDyyGDaj}DRa–D]X•D¯³{DÝCMD=º6D™//D™s&DôCD•jD‰ÂDßÄúC¶¨ïCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ¸ üCg=DŽÆDD‰ÔüCdMêC ÂÕCã ¾C±…¶CU¾CÏ4ÅC­6ËC‹¨ÌCÆ9ÊC¼ÇC‚}ÁC—Ž´C¿“C}CÐÈC7žC&ŸC«‚•CŒ*}C°˜@CÑNMCxvCÚV…Cô‹‰CîÓC3Ò˜Cb!¢C-o«CŸG¶CËsÄC¨×CÐòCM Dg,D&y^D‡0•DàºDi˜·D6ªDF6YDk:DœŒ3Duƒ+Ds2DÝDÌòDY.ûCÁÜîC½ÆãCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ4Ö÷C:úC;EüCUúC¤ ñC dâC)¹ÏC͹C‰°C® ³C3Ô·CU;ÃCIÊC ÍCO1ÔCeÖCÙ6ÃCäýªC* CÒŸœCI¸žCöþœCŸ•Cùê†CšbmC³ejCíuCC’CÎQŠC·¾“Cÿ6CŽ¹¦C²°C¾#¼C@}ÊCþ¢ÝC(‹øC+<DÖr/D¶{aDéÁ•D³;¹D#÷¶D]†‘D¹w\Dù¡;D}y2D®î)D£)DD5¿D4{÷C÷ðéCFãàCãÊ×CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀvóCÖÛóC¸óC{·ïC³èC8ÞCóÑC@ÄC“¼C —´CDjµCÑJÀCÞÚÇC$ÎCáJßC8$èC¤QËC³¯CT¢CÛvC—?›CA™C¹h•CyŽCZ˜„CysC.Y[CæácC¡‚CþR’CΘžC+A©C5Ò³C'‹¿C¹ÄÍC…=àC„‹ùC\åDâ¥)D~ºPDð”DñD¦žD’…Dc“XDŒ&;D,".DÒ$DexD…} DïwDdÙïC@½àCÛ,×CÆ’ÓCŸ!ÑCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÚÍïCH*ïCj>íCâ£éC öãC0mÜC™ÐÓCBŽËCDâÄCG ¿CUê¾C ÂCèÊÄC(YÈC}$ÑCŸeÑC÷·C7C%>”Cø’CufCžßC5æ‘CÒøŽCn†CN'iCó¦6C/fBCS0vCÛsCŸCB©ªCÚ’µC ?ÁC•îÎCdàCȆöCÚk D¶Š!Dö?DYÛ_DÀÀÀÀ¤È1Di)DY³D­÷DõDéPúCI$æCqçÔCø‚ÊC«êÈCþrÉCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÍ(íCJìC ÄéCiæC¨ÒáC+ÜC–îÕCÍÏC’`ÊCMÆC§JÃC##ÁC¦§¾Cv¯¼CQ,»C¦²CfŸ˜CÛoCÊuC9¬ƒCл~CìE„Cdø‹C¹ºŒC°†CCqC-ÇLCZ¥UCÜCmf’C^] C×Í«CŒ¶C ÐÁC`ÎCºÞC*ñCz÷DÀÀÀÀÀÀÀÀÀÀÀªáDõóC$pÞC€„ËCçÀCdšÀCqYÇC]ÐÈCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ±ìCµëC;$êCóçCÞýäCž7áCø·ÜC‰»×Cb‘ÒC]xÍCwÈCM"ÃCƒ¼CÊ´Cò&¬C)î§C¥| CYgˆCJC%]CžóxCOtlC¿&{Cà‡CÜ(ˆCû®ƒCÞV~C¬ËwCÓeC²¤ŠCä"—Cˆ¢C·ï¬C<·C©ÁCwcÍC–ïÚC`SìCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÖC4ÒÈCS¿C‹,ÀCþäÆC™FÉCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀXÉëCvËêClQéC*gçC“íäC•ÖáC‹!ÞC†ÙÙC’ ÕCo©ÏCæfÉC{gÁCË÷µCù¥C)“CP‘CË•C´ C|CRyCÆu€Cù €C}Ž„C,†C×#}CØ”jChÈqCäcCøB‰CÓ¸‘C(›C\r¤CâέC¶<·CŸÁC«³ËC GØCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀô­ÃC ƒÆCàHËCyÍCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ@ZêCXiéCzõçC§æCÁÀãC?ÊàC®ÝCõlØC\™ÒCçËC†íÀC¥±C ™CÚˆwCÏ{C>CæÕ‘CdψCcxC\ vCÔ"„Cõé‰C–å…C!±cC'Ã"D³Æ,D¬œ(Dà¹Dw DBbD¤WD¥ DÓ£DéðCåWáC¦¤åCppöCõ¢ýCf¿ðC4àC‚PÓCÛjËCÈCêÑÂC—à»CDmµCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ‹Ä D}D\D»¾DGßDm†DÎD}¤Dæ3 D†eDYÏ D¡tD¤KòCþhúC>¢ D,bDá-D£AëC(½ØCŸƒÎCFóÈCC ÄC›b¿CÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀºé Dœý Dâà DŽÀDºCD<DèUD- D2 D…bD„µ÷Cü'D D)ÿDÛÿDÂðC;ÝC«­ÑCS ËCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀ)ÔD}¨D¥uD“DѬÿCfŠD;ÛDŠïD¢ÞùC×ÐõC¦£úCÕ¼DÁ£D%–DŠÚíCYˆÞCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀV~úCM‚úC¸fûCÙ‚ûC§ÜøC:ªôCÙ~òCß|ôCgøCÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀÀraster/inst/external/rlogo.gri0000644000176200001440000026621414507510157016216 0ustar liggesusersCCCCCCCCCCCC~CCCCCCC~CCCC|C~CC~CCCC~C~C}C}C~CCCCCC~CC~CC~C}C|C}C}C}C}C}C{C|C|CzCzC{C}CCCCCyC{C~CCCCCCxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCC~CCCC|C~CC~CCCC~C~C}C}C~CCCCCCCCCCC~C}C~C~C~C~C~C|C}C}C{CzC{C}CCCCCyC{C~CCCCCCxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCC~CCCC|C|C}C|C}C}C}C|C|C{C{C|C}C}C}C{C{CyCzCyCzCyCxCwCxCxCxCxCxCtCuCwCuCxCyC{C}C}C}C}CwCyC|C}C}C}C}CCxCCCCCCCCCCC}C}CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC}C}C}CCC~CCCCCC{CxCsCrCmCgCaCZCVCSCRCRCRCQCQCQCQCQCWCYC]CcCkCrCyC|CCCCCCCCCzC~CCCCCCC~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~C~C}CCCCCCCCC|CyCtCsCnChCbC[CWCTCSCSCSCRCRCRCRCRCXCZC^CcClCrCzC|CCCCCCCCCzC~CCCCCCC~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC}C}C{CyCyC{C{C}CzC}C{C}C{C}CwCtCnCmCfC`CZCSCOCLCKCKCKCJCJCJCJCJCRCUCYCaCgCpCuCzC{C}C{C}C{C}C}C}CzC~CCCCCCC~CCC}C}CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCCCC~C}C|C|C}C~C}CC~C~CxCoCeC[CUCICKCHCFCBC>C;C:C4C4C3C3C2C2C2C1C)C)C*C*C.C2C5C7CECSChCyCC~C{CuCCCvCtCzCCC}CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCCCCC~C}C}C~CC~CCCCyCpCfC\CVCJCMCJCHCDC@C=CC=C:C8C8C8C7C7C6C5C5C5C7C5C1C.C,C,C-C-C6C.C$C!C0CKCkC~CtCCCCC{C}CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCCCCCCCC~CCCCCCzCwCpCjCaCXCNCICFCDCBCCCCCCC@C?CCCCC;C>C>C>CC9C6C5C5C6C-C)C"CCCCC#CCCC9C`C{C~CxCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~CCCCCCCCCvCjC]CRCJCECJCJCICICICHCHCGCICKCNCPCQCQCPCOCKCKCJCICGCGCGCFCFCCC>C9C6C5C5C6C-C)C"CCCCC"C CCC9C`C|CCyCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC}C|C{C}C}C{C{CyCwCtCiC]CPCGC?C:C?C?C>C>C>C=C=C?CACACDCFCGCGCFCECACAC@C?C?C?C?CC@C@CDCECDCCCBCDCCCBC@C@C?C?C?C:C3C+C&C#C!CCCCCCCC(CMCpCCCCCCC~CCCCCCCC~C|CCCCCCCCCCCCC~C|C|C}CC~C}C~C}C{CyCsCuCyCwCwCuCiCTCGCICEC=C;CCC@C;CC:C9C;C=CACDCECBC?C?C>C=C;C;C:C:C:C5C.C&C!CCCCCCCCCC CECjCyCyCyCwCxCtCvCyC{C}C}CCCC~C|CCCCCCCCCCCCCC}C~C}CCCCCCzC~CCCCyCgC\CRCKCICNCNCICICOC_C_CcChCaCNC;C4C0C.C,C)C(C(C*C,C.C/C0C0C0C/C.C-C,C-C/C3C7C;C>C@C>C=C=C;C7C0C(C!C CCCCCCCCCCjC~CvCtC}C}CzCCCCC|CzC|C~CCCCC~C~CCCCCCCC}C~C}C}C}C}C~C~CyC~CCCCyCgC\CSCLCJCOCOCJCJCOC_C_CcChCaCNC;C1C-C+C)C&C%C%C'C)C+C,C-C,C,C+C*C)C)C*C,C0C4C8C;C=C;C:C:C8C4C+C#CCCCCCCCCCDCkCCwCvCCC{CCCCC|CzC|C~CCCCC~C~CCCCCCCC}C~C}CC~C~C|CzCtCvCwCwCwCoC]CPCEC>C:CACACCuCCCyCyCCCC~C|C}CCC~CCCC~C~CCCCCCCC~C~C~C~C~C}CzCwCzCwCwCuCkC[CLCFC@CFCHCHCDCICWCfCOC?C,CCC C CCCC CCCCCCCCC CCCCCCüBþBCCC C CCCC%C'C%C$C&CCCC C C C CCCC8CoCwCwCsCsC{C}C}C~C|C{C}CC~CCCC~C~CCCCCCCC~C~C}C~CCCCCCCtCeCXCQCPCSCZCTCTCaCsCmCFCCCC C C CCCC(C*C+C.C,C&CCC CCCðBÞBÒBÊBÈBÀBÂB¼B¼B¶BºB¸BºBÊBÔBâBôBCCC(C)C,C(C CCCCCCC CCBCqCCC|C~C~C~CCCC~CCCCC~C}CCCCCCCC~C~C}C|C}C~C~C|C~CCtCeCXCQCPCSCZCUCUCbCtCnCGCCCC C C CCCC*C,C/C0C/C(C!CCC CCöBæBÖBÒBÌBÈBÆBÄBÀB¾B¾BÀB¾BÎBØBæBøBCC C*C)C+C'CCCCCCCC CCCCpCCC}C~C~C~CCCC~CCCCC~C}CCCCCCCC~C~C}C}C~C|CzCyCyCwClC]CNCGCDCGCNCGCECTCfC`C9CCC CCþBCC CCCCC"CCCC CþBôBæBÔBÄBºB´B²B¬B¬B¨B¦B¢B¤B¤B¤B´B¾BÌBâBôBCCC!C&C#CCCCCCþBCCC>ClC{C{CxC|C|C~CC}C}C~CCCCC~C}CCCC~CCCC~CC{C|C~CCCCuCnCcCWCRCQCTCWCWCjCqCXC/CCCCúBC CC#C/C4C5C0C,C#CCCCêBÖB°B¬B˜BŠBpB`BLBPBC9C1CC CîBÈB¨BBlBHB BBàAÀA¨A¨A A¨A¨A A A A¨A°A¸AÀAèAB B BB(BDBXBpBœBÈBðB CC&C*CCCCC CþBC:CvCCC~C|CCC|CCCCCCC}C~C~CCCCC~C}C~CCCC}CyCaCYCQCQCYCdCjClCrCNCCúBêBôBüBCCC(C3C;C>C9C2CCCúBÔB´B–BxB`B$BBBðAØAØAÐAØAÐAÈAÈAÀAÐAØAàAàAB BBB,BCMCSCSCTCSCSCSCSCSCKC7CCúBÄB–B`B4B8B,B0BDB4B BCCàB¬BxB B˜A`A€?@ @ @à@¸AB°AØALB®BîBC'C;CLCTCTCWCVCVCVCVCVCNC:CCCÊB˜BdB0B0BBB(BBBBPBpBšBÄBêBC CCÜBòBÊBþBFCvC{C{CzCwCC~CCCC~C~CCC~C~C~CuC~CxC[CYC[CWCZC|CiCCCCèBÈBÈBÎBCC?CXChChCLC+CèB´B`BBÀA€Aà@€?¨AA AàA$B„BCCCmCtC~CCCC~CCCCCCCCCCCCCCC{CgCZC CâB€B0BHBdBDBB8BlBšBÈBøBCCCàBCàBCVCCwCCC~C}CCC|C~C~CCC~C~C~CvCCyCZCXCZCVCZC|CiCCCCèBÈBÈBÎBCC?CWCgCgCKC*CæB¬BPBB¸ApAÀ@ A @À@¸ABtBúB>ChCrC|C|C~C~C}C}C}C}C}C}C}C}C}C}C}C}C}C}C}CwCfCYC CæB„B8BTBhBHB B8B`B”BÀBðB CCCàBCâBCWCCxCCC~C}CCC|C~C~CCC~C~C|CqCyCsCUCSCUCQCRCtCaC;CCØB´B´BºBöBC7CRCbCbCFC%CÞB¦BDBàA¨APA€@€A@ @ØA(B†BCECoCwCCCC|CyC|C|C~C~C~C~C~C~C~C~C~C~C~C~CvCdCWCCàBtB$B8BPB0BBBDB‚B®BÞBþBCCÐBüBÖBúBRC{CsC}C}C|C}CCC|CCCC}C~CCCC|CcCTCXCWC]CvCqC;CøB°B B¶BìB C8CWCoCsCcCAC C¾B„BB A€?€?ˆAADBäB>C|CCC|C~CC~CC~C}C}C~C~CCC~CC~CC~CvCwC{CCCCCzCC{C{CQCCÀB„B`B‚BlB`B‚BžBÆBðBCCþBÖBÄBCJCuCCCxC{CC}C|CCCC}C~CCC~C{CcCTCXCWC]CvCqC;CøB°B B¶BìBC9CVCnCpC`C@C C¼B‚B BA€AADBäB=C{C}C}CzC|C}C~C}C}C|C|C}C}C}C}C}C~C}C~C}CuCvCzCCC~CCzCCCCUCCÄBˆBdB„BlB`BxB˜B¾BèBCCþBØBÆB CICtCCCyC{CC}C|CCCC}C~CC}CzCvC[CLCPCOCUCnCiC3CèB BB¦BÜBC3CQCiCkC[CCòBŒBB@AxB3C|C}C~CC~C~CzCxCuC{C{ChCuCxCxC{C|C}C}C}CvCvCuCvCuCvCuCuCwCxCzC}C}C}C{CzCoCrCtCtCzC~C}CzCqC~CCTC C¤B†BšB BÖBüBCøBÌBÒB CkCCCyCzCCCC~CCCyClCOCQCFCPCmCZCC¦B’BBªBôB(CRCqCzCnC:CêB„BB A|B6CCC~CC}CC}CCCCC{CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC{CCCVC C B|B’B–BÆBìBúBìBÀBÆBCfC{C{CwCxC}CCC~C~C~CnC^C]CRCVCqCgCC®B¨B®BÒBC+C^CCCmC5CðB\B¸Aà@€AÈACtCCwC~C~CgCwCkCrCdC8C8CFC4C:C:C9C7C4C2C0C0C:C;C:C;C:C;C:C;C=C;C6C2C/C1C3C5C=C3C*C0C7CCCOCYCyC{C}C|CnCBCþBŒB®BžBÔBCðBêBàB°B&CpCCvC~CCCC~C~C~CoC]C]CRCVCqCgCC®B¨B®BÒBC+C^CCClC4CîBXB°AÀ@`A¸ACrC}CwC~C~CkCCuC~CoCDCACPCC;C:C:C8CCCBCCCBCCCBCCCBCFCBC?C9C8C9C;C=CEC;C3C6C>CICUC^C|C}C}C}CnCBCþBŒB°B BÖBCòBìBâB²B'CqCCvC~CCCC~C~C|CjCYCUCHCJCeC[C C–B”BšB¾BôB#CVCwCwCgC/CæBHB A€@pAÀACuC~CwC~C~ClCCCCC^C`CsCcCkCkCjChCeCaC^C_CjClClClClClClClCoClChCcC_C`CbCdCjC_CTCVC[CcCmCrCCCCCpCDCþBˆB¦B”BÆBöBâBàBÖB¦B!ClC{CtC|C}CCC}C}CzCgCPCXCLCsCzC#C®BœB¤B°BC3CYC}CCkC9CÞBtBˆA@@€?€?ÈAŒBkCwCCC~C~C|C{CtC0C9CZC@C)C3C,C/C/C/C-C,C,C/C4C.C.C.C.C.C.C-C.C*C,C0C1C1C1C1C3C)C'C+C.C(CCC)CC9CZCuC{C{C]C;C¾BÀBªBÒB CôB¼BÐBÆBTCCyCCCCC}C~C{ChCOCXCLCsCzC#C®BœB¤B°BC3CYC}CCjC8CÜBpB€A@€?ÈAˆBiCuC}CC~C~C~CC{C;CEChCMC5C?C8C:C:C9C7C7C7C;C=C9C9C9C9C9C9C8C9C5C7C;CCºB¶BœBÄBCêB²BÆB¼BPC{CwC}C}C{C}C~C}CcCRCRCMCpCwC*CØB¦B‚BÆBòB/C]CwCCuC6CöB`BàAÀ@A'CCCCCCCC~C{CwCCC7C_CQC+C;C:C>C=C:C:C=CC1C5C1C&C"C#C CCCC C6CpCwCrC{C\CÜBÈBÄBCöBêBÎBÀBêB}C|CCC{C~CC~CdCTCRCMCpCwC*CØB¨B„BÈBòB/C]CwCCtC5CôB\BàAÀ@A'CCCCCCCCCC~CC$CACiC^C8CJCICKCJCDCDCHCGCBCGCFCDCCCGCKCGC@CGCJCJCFCDCFCHCICCOCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCzChCYCRCLCICFC0C1ClCC~CuCpCCÀBÔBÊBCäB¨BÄB1CzCuCxCCC|CgCQCKCRCkC`CCºBŽBŽBôBCEClCCyCTCC€B˜A€?A¸A\C}CCCCCCCCC~C{CoCC CðBCCöBðBÖBØBÚBâBàBÞBâBêBàBìBúBúBòBîBöBCúBôBðBðBòBòBðBðBÜBâBðBCCC,CC?CLC`C/CÂBŠB„B–BC#CRCjCrCVC!C¬BÐA€@ @ BVCvC}CmCCCCCCCC~CCCECJC>CSCECCúB CCCCCCC$C(C.C5C:C8C6C7CC;C8C8C4C-C'C'C)CCCCCC+CC-CC C,CCyC}CuCyCCÞBÞBðBèBÈBœBKC{C}CCCiCPCFCOC\C\C C´BœB®BÞBCRChCvCjC=CôBLBA€?€?˜AUCCwCCCCCCCCCC~C{CpC CCòBC CÌBÖBØBÚBÚBàBøBC0CCC`CSCICHCECAC@C@C;CCÐBžBžBÂBC)CfClCqCVCC¦B¸A€?1CCoCCCrCCCCCCCC~C{CwCC CCC CÒBîBCCCC2CXCjClC>C#CCþBøBöBòBøBøBòBúB CCC#C1C+C&CC CCöBèBÜBÞBèB C CÄB®BÈB¾ByCwCCCsCwCCCCúBÚB²BkCCCyC^CICHCTC]C>CÐBžBžBÂBC)CfClCqCVCC¤B°A1CCoCCCrCCCCCCCCCC}CCCC)CCðBCCCCC:C`CtCsCEC*CCCCCCCCCCCCC*C8C4C1C'CCC CCöBøBCCCØB¼BÖBÆBzCwC~CCtCxCCC CüBÜB´BlCC{CsCXC>C;CFCSC4CÀBŽBŠB®BôBCZC`CgCLCCšB A1CCoCCCrCCCCCCCCCCCCECTCdC_C^CSCEC:C6C1C/C1C4CKCBCCöBüBÞBCyC|C}CoCrCöB CCìBÌB¨BgC}CCpCRCACECRCYCCÀB’B°BàBCHCdCiCeC9CÞB0B @ AâB{C~CC|CxCCwCCCCCCC~C{CqC CCCC CÄBÚBúBCC&CLCcCICCœBLBèAÈAèAàAèAøABðAàABCCCqCSCCCGCTCYCCÀB’B°BàBCHCdCiCeC9CÜB,B @AÞB{C~CC|CxCCwCCCCCCCCCwCCCC%CCâBøB CC C1CUClCSC C¨BdB BøABB BB0B B B(BTBŠBÊBC#C3C5C&CC CCCCðBC#CüB´BªB¤B(CCtCCClCoCöBCCâBÀB?CC{CkCMC8C:CFCOCC°B‚BœBÈBCCFCRCTCôBÆBBÄBC,CcCWCcCXCC˜BA0AøAkCtCCCyCyCCCCCCCCCCC}CCC CCCòBC CC+CAC`C^CCCUCKC&C,C4CHC[CrCCC+CŒBB A€A˜AàAØAÈAØAÀAÈAøA$B0B@BˆBÀB C6CSCQCHCJCHC=CECLCECECCSC;CèB¤B¦BÌBCECXCaC[C[CìBTB°A€@CCCCCCCCCCCCCCC~C{CwCCCCCCÈBæBCC C7C@C/C–BèA€? @A A€Aà@ÐA@PAˆA˜AèA B8BžBÚBCCC C CCC CCCÌB€BŽBªB^C~CCC|CzCfCCCCÆBàB~CCYCCCCHCPCRCSCKCMCFCCÀBºBÆBcCCC}CzCvCaCCCøB¾BØBzCCUC?C8C;CLC1CàB¤B²BâBCICWC]CZC0CÐBHB@ABVCCCCCCCCCCCCCCC~C{CwCCCCCCÈBæBCCC-C5C$CŠBèA @A¸BÎBÈBÔB¶BÂB®BÊBàB¼BXB BHBhB4BŽBÎBCCCC C CCCCCÜBˆB†BŠB?CzC~CCCCsC-CCCÌBÒBCCVC@C:C=CNC1CàB¢B°BâBCICWC]CZC0CÎBDB0ABTC~CCC~C~CCCCCCCCCCCC~CC CCCCäBCC C'C6C?C-CœBBPA¸AÂBØBÚBàBÂBÎBºBÖBðBÌBtB0B`B€BXB¦BèBCCCCCCCCCCèB’BŒBŽB>CyC~CCCCtC.CCCÎBÔBC{CPC8C/C0CAC'CÐB˜B¦BÒBC?CMCSCPC(CÄB4BABUCCCCCCCCCCCCCCCCCC:C8CGCUCRC#C-C:CQC\CoCtCXCÞBhBÀAèAÈBÞBØBÜB¾BÊB¶BÖBôBÒB†BTBŒB°B®BòBC;C@C;CDCMCPCVCOCQCJCCÌB²B¨BFC~CCC}C{CoC(CCCÄBÊB{CCOC9C6C:CFC%CØB¦BÂBúB%CNCUCVC_CC¼B$B@A¤B~CCC~CCCCCCCCCCCC~C{CwCCC CCCÈBæBCCC%C)CC†BB$BlBlCtCsCzCpC{CzCzCuCyCzCiCCLB|B†BÂBôBCüBþBC CCCCCðBŒB`B`BCxC~C|CCC~CJC$CCàBÆBCCPC:C8CCHCPC]CVCTCQC"CÐBžBŽB"C}CC|C}C{CzCECC CØB¾B{CCJC4C4C9CBCCØBªBÌBC+CPCRCPCUC C¦BÈA@@BC}CCCCCCCCCCCCCCC~C{CwCCCCCCÈBæBCCC%C%CCˆB BBLB{C{CyC{CxC|CyC|CzCsCpC{CzChCÔBžB¾BâB CþBòBC CCCCCþBŠB(BXBüB|C~CxCC{CCjC0CCúBÄBCCKC5C6C;CDCCØB¨BÊBC+CPCRCPCUC C¤BÀA@BC}CCCCCCCCCCCCCCCCC~CC CCCCäBCC#C'C.C/CCšBDBC&CöBÄBÜBC)CKCJCFCGCC’B BøAàAWC~CCCCCCCCC~CCCCCC~C{CwCCCCCCÈBæBöBCC%C%CC†B B@BœB}C~C~C}C~CuC~C}C~CCC~C|CwCdCCC C(CþBÊBîBCCC+C-CC|BB8BôBzC}C~CzCC~CC=C CCÞB~CCKC-C%C+C@C&CöBÂBÚBC(CKCJCECFCCBBðAÐAUC~CCCCCCCCC~CCCCCCCC~CC CCCCäBC C C'C0C/CC˜B4BLBšB|C}C~C}C~CuCC~CCCCCC{CjCCCC5C CêBCC C)C2C5CCˆBBC!C CàB~C{CEC'CCC3CCæBºBÒBC#CCCBC@CACøB†BBàAØAVC~CCCCCCCCC~CCCCCCCCC:C6CECTCQC!C-C5CNC[CfC`CECÒB†BˆB¶BCCC}C|CsCzCyCzC}CCCCCC:CGC@CaC:C&C;CHC]CdChCdC-CÄB€B‚BCCCCzC}C|C{C8CCCÖB|CCLC+CC"C;C'CüBÊBâB C+CKCICDCACîB BàAB\B[C|CCCCCCCCCCCCCCC~C{CwCCCCCCÈBæBCCC%C%CCˆB$BB„B{C}CyC~CyCC~C~C~CCxC~C|CwCdCC"CC1CüBÀBìB CC$C/C.CòB`BB4BCxCyC~CxCCzC~CAC!C CìBCCMC,CC$C=C'CüBÈBàB C+CKCICCC@CìBžBØABTBYC|CCCCCCCCCCCCCCCCC~CC CCCCäBCC$C(C0C/CCšB4BB‚ByCzCwC~CyCC~C~CCCzCCC{CjCC+C#C>C CàBCC%C/C9C6CCtB B8BCwCxC~CxCC{CCBC"C CîBC{CGC$CCC0CCìB¾BÖBC#CCCAC>C;CâB”B¸ABXBZC|CCCCCCCCCCCCCCCCCC:C4CECSCOC!C-CCVCMChC9C!C8CMC`CgClCdC&C¶BhB€B CC}C~CxC}CvCyCC>CC´BPB0B4B0CCC|CC}C|CCyCCCCC~C~C~C}C{CwCCCCCCÈBæBCC&CC#CCBB,BœB|CC~C~CxC{CyC{CzC{CxCvCwCyC:C1C(C@CCÞBÌBðB C$C3CIC*C¢BBAB3C~CyCC~C~CCC8CCôB>CC|CmC)CCC C-CCöBØBC(CBCEC=C=CC²BLB,B0B/CCC|CC}C|CCyCCCCC~C~C~CCC~CC CCCCäBCCC3C(C,C!C B4B8BœB{C~C}CC|CC}CCCC}CzC{C|C?C9C1CIC!CúBêBCC2C@CUC4C´B B AB2C}CyCCCCCC:CCöB?CCtCeCC C CC!C CÞBÀBîBC8C;C8C8C C¨BCDC8C=CCÐBˆBHB4BCCCzCC~CzCCC|CCCCC~C~C~C{CwCCCCCCÈBæBC C"CC$CC˜B$B8B BkC{C{CzCsCxC{CyCwCyCwCyCmCbCPCCDC7CCÆBàA€AàA¢BtC~C~C~C~C}C}CUC:CCCtCCCzCMCC CCC'CCþBîBC2C?C6C7C'CîBžB\B\BºBhC~CvCCCCCCyCCCCC~C~CCC~CC CCCCäBCCC*C%C,CCÂB†B¸BàB_CqCxC|CzC|C~CzCjCaCdCgC`CXCIC[CmC;CàBøBCC=C`CnCDCÔBB¨AðA¢BsC~C~C~CC~CCWCC_C~CCdCChB B,B¶ByCC~C|CyCvCtCLC1C CCpC}C~CyCjCC C CC"CCCCC&C:CC)CâB?CrC}C~CyC{C-C CøBCC CCC CC5CAC5C5CCÚBB’BpBêBvCCC}C~CvC|CCCCCCCC~C{CwCCCCCCÈBæBþBCC CCC CCCC"C+C,C*C+C(C7C;C8C1C8CQClCtCjC?CþBÌBìBC ChCuCrC0C”B˜Aà@`A\BfCC~CCvCzC~CgC=CCÜBtCCCCzC|C.C CüBCC CCC CC5C@C4C4CCØBŽBBlBèBuCCC}C~CvC|CCCCCCCCCC~CC CCCCäBCCCCCCCCC#CC,C3C5C3C5C0C?CCC@C9CACZCsCxCnCDCCØBþBC+CpC|CyC5C˜B¨A0AˆA\BgCC~CCvC{CChC?CCÞBuCCCyCtCtC&CCæBúB CCCCCC-C;C/C/CCÐB†BˆB\BàBqC{C{C{C|CtCzCCCCCCCCCCC:C4CECSCOCC+C7CKCRCNCNCFC@CDCNCNC]CbC`C\CYCTCcCgCdC]CbCyCCCCdC'C CC.CACCCCHCÂB(B¸AÐA|BkCC~CCtCvCyC`C4CCÒBpC{C}C~C}C~C\CCúBCCCCCCC-C=C;C0C$C CºBœBŒB¤B/C{CCxCCyC}CCCCCCCC~C{CwCCCCCCÈBæBøB CC CCC CCCC#C;C@C;C>C:CBCNCYCdCmCkCSC8CìBêB¶BØBCPCnCqCjC2C®B ABC~C}CCzC}C}CtCOC"CúB'C~CC|CC~CC]CCüBCCCCCCC-CCøBöBÂBæBCXCwCxCoC7C¸BPA€?BC~C}CCzC~C~CuCPC#CüB(CCC|CyCxCyCUC CìBðBüB CCCCC%C7C5C*CCC®BB€BšB*CwC{CtC{CuCyC}C}C}C}CCCCCCC:C4CECSCPCC+C4CLCOCKCGC:C;CCCKCWC_CoCoCfCgC`ChCwCCCCC{C`C CCCC8CkCCCCJCÞBðAPAA(BCCCCxCyCxCoCHCCðB"CzC}CzC~CC}C~CCCþBúB CCCCC%C7C?C+C,C#CàB¨BªB–BÄBbCCyCCCCCCCCCCC~C{CwCCCCCCÈBæBôB CCCCòBìBìB C C0CZCgCfClCiCkCaCGC"C CCâBÂBÊBÈBC:CgCjCvCUC C¤B¨APA€@ŠB|C{C|CCoCCC^C6CCCwCyCC|CCC~CCCCþBúB CCCCC$C6C>C*C+C"CÞB¦B¨B”BÂBcCCzCCCCCCCCCCCCC~CC CCCCäBC CCCCCCþBCC.CAChCvCtCzCwCyCoCUC0CC CöBÔBØBÒB CACoCqC~C[CCªBÀA€?PA @ŽB|C{C|CCoCCC_C7CCCxCyCC|CzCzCyCyCCCîBêBCCCC CC1C9C%C&CCÔBœBžBŒBºB^C{CuC{C{C{C}C}C}C}CCCCCCC:C4CECSCOCC+C2CLCPCOCGC/C(C*C@C]CoCCCCCCCCrCMC5C,CCCCC*C]CCCCiC CÐB$B`A¸AAŒB|C{C|CCmC{CzCYC/CCCsCwC}CzCCxCyCCWC CòBðBäBC$CCC(C$C7C2C0C)C CÐBªB¨B–B ChC~C}C~CCxC|CCCC}C|C}C{CxCCCCCCÈBæBþBC C C CCCäBÜBØBÚBâBêBðBêBàBÒBÔBÂB¶B´BªB¬BÊBìBCHCpCjCGCC¶BPBà@@@ @€?xBaC~CCC}C~CClCCêBìBæBÞB C)CCC0C4C2C2C.CCþBÎB¸B®BÀBCxC}C~CxCCCCCCCC|CwCwCCCCCCÈBæBC CCCCCC$CCCC C CCôBâBàBÜBÊBÈBÒBÒBÖBòB C:ClCPCC”BB¨A€?4BOC~CzC|CCCCiCOC*CþB!CeCC|CCCC~CxCC~C?CèBêBäBÜB C(CCC/C3C3C3C.CCþBÎB¶B¬BÂBCyC~CCyCCCCCCCC~C{C~C C CCCCäBCCCCCC C'C,C$C CCCCCCüBþBúBæBàBêBêBîBCCDCuCXC C BBÈA€?0BOCC{C}CCCCjCPC+CC"CfCC|CCC}C|CvC}CyC:CàBâBÜBÒBC$CC C*C.C+C+C&CCîB¾B¬B¢B¶BCtCyCzCtC}C}C}C}C}C}CC}C|CC;C3CECSCOCC+C9CFCRCWCRCICKCPCHCJCICECCC=C1C*C*C(C C C'C)C+C6CBCgCCoCCÀBPBB`APA0A ADBMCzCvCxC}C}C}CeCKC%CôBCaC{C|CCCyCCCxCCrCCÔBêBÒBÞBCCC'C/C2C3C1C)CCCÎBÚBœBÞBCmC}CCuCyCCCC~CzC|C{CwCCCCCCÈBæBøBCC!C/CCC]CnCqC`CLC?C:C;C;C;CCC CCCþBCC4CTCUCüB0B@A0AàA¬BrC~CuC~C~CCzCrC^C/CCúB]CCC|CCCyCCCxCCrCCÒBèBÐBÜBCCC&C.C2C3C1C)CCúBÎBÚBžBàBCnC~CCvCzCCCC~CzC~CC~CCCCCCäBC CC!C*C7CLCdCvCxChCUCGCECFCFCFC+C&CC CC C CC>C`C`CCHBpA€?@@PAàAªBqC~CvCCCC{CqC]C0CCüB^CCC|CCCyCCCvC}CpCCÊBàBÈBÒBCCC!C)C*C+C)C!CCèB¾BÊBŽBÐBChCxCzCqCuC}C}C}C|CzC}CCC:C5CECSCOCC+C4CDCUCaChCmC~CCCC~CuCrCsCsCtC[CVCLCCCJCGCGCRCqCCC!CBB€ApAÐA@ABºBvC|CpCyCyC{CvCmCYC+CCòBYC{C{C|CCCtCCCuC}CCcCCØBÔBÖBÖB C(CC&C1C5C0C.C*CCîBÞBäB²BðBCtCCC~CCC~C~C~C~C{CwCCCCCCÈBæBôBCC)CICjCsCtC=C&C CþBC CC C3C7C.C"CCCC#C,C@C(C¬BBˆAA BCrCeC~C~C~CyCCiCRCDCCîB>CyCCC{CCCtCCCuC}CCaCCÖBÒBÔBÔB C'CC%C1C5C0C.C'CCîBÞBæB´BòBCuCCCCCC~C~C~CCC~CC CCCCäBC CC#C3CQCsC{C{CDC,CCC CC"C)C?CBC:C.C%CCC/C8CMC5C¾B,B°A€?€? A BCqCeC~CCCzCCjCQCCC CðB>CyCCC{CCCtCCCuC}C}CbCCÒBÊBÌBÊBC"CC C)C-C(C$CCCÞBÎBÖB¤BæBCoCzC{CzC}C}C|C|C~CCCC8C4CECSCOCC+C2CECUChCCCCCVCDC/C'C-C8CFCPCiCoCjCbC]CTCWCiClCyCXCüBŠB$B€APA°ACWCmC%CCCCCÞBðB CC,C.C.C#CBC3C5CHCRCPC.CCCCCÌBšBC\CxC}CyCzCC~CxCCCCCCCCCCCCCC}CCC{CyC}CC~CTCÐBtB¦BB\BˆB˜BªBÄBàBöBCC#C%C)CCCCCCCCCC CüBCCÈBâBüBCC#C$CC|B$BBdBxC~C}CtC}C}CrC{CGCØBÀB¦BÄB CúB CCüBÒBÌBöBCC´BÀBêBÞB´B.CkC~CCxC}CC{C~CCCCCCCCCCCCCCC}CCC{CyC}CC~CTCÐBtB¦BB\BˆBšB¬BÆBäBúB CC%C'C+C CCCCCCCCCCC CCäBC CC,C.C.C$CB@BBdByCCCvCCCtCCNCæBÎB¸BÖBC CCC CêBèB CCCÈBÒBúBìBÂB3CoCCCxC}CC{C~CCCCCCCCCCCCCCC}C}C}C{CwC{C}C~CTCÌBlB¢BŒBTB„BB B¶BÎBäBþBCCC CC CC CCCC C6C=C;CVCNC!C+C8CKC`CdCaCMCÊB†BDB‚B}CC|CsCzCzCsCCXCCCúBCAC3CBCGC:C%C%C:CKCC;C?CC5C>C:CLC1CLC.CàB¸B¬BÐBCCüB CCCþBþBCCæB²BªBÂB;CwC~C~CzCxCC~C~CsCCCCCCCCCCCCCCCC~CCCCC{CCwCzCcCCœB|B\B\B\BhB€BŽBšB°BÆBàBCC(C,C)C%C%CC!C C C(CCîB C CC,C/C.C$CB@BHBtBACCC@C8CAC?CQC5CQC4CîBÌBÂBäBCC CCCC C CC$CúBÄBºBÐBACzCC~CxCxCCCCsCCCCCCCCCCCCCCC}C|C}C}C}C}CyC}CuCxCaC C˜BtBTBHBDBHB`B|BŠB B¶BÐBòBC C$C!C C(C*CC^CJC&C5C8CKC`CeCaCLCÊB†BpBˆBDCBC;C1C8C8CKC6CWC@C CCCCDC8C6CECMCFC@C=CLCQC!CCèBôBMCCC~CyCxCCCCsCCCCCCCCCCCCCCCCC~CuCxCCCxCC}C}CCRCC¨BšBdB8BPBdBXBdB„BªB¨B®BÊBöBCC"CC!C CCCCÎBÎBüBCC$C$CCxB$B$BtB1C3C4C5CBC@CC=C=CCC;CJCFC9CDCCÖBÒBªBÒBCCCCCCþBC CCÒB B¼B†B?C{C~C~C~C~CC~CzCCCCCCCCCCCCCCCzCzCCC}C{CC}CCC{C|CCxCUCúB°BdBdBhBCMCHC=CHC%CäBâB¼BæBCCCCCC CCC&CäB²BÐB”BCC{C}C~C~C~CC~CyCCCCCCCCCCCCCCCzCzCCC}C{CC}CCC{C|CCxCSCöB¦BLBLBPB$BBC9CMCNCRCGCCCIC9CCäBúBCC{CC}CCCqC}C}C{C}CCCCCCCCCCC~CCCCCCCCCCCCC~CCCCCCnCHCCÄBhB\B4BBB4B4BB˜ABCCCC CÂBòBúBCC)C(CCŽB,BBXB´B®BB–BBŠBŒBdBhBTBØA,B®BÄB¼BÄBCCCCC CC CC CâB¬B²BÊB-C}CtC~C~C}CC{CCCCCCCCCCCCCC~CCCCCCCCCCCCC~CCCCCCnCICCÆBhB`B4BBB4B4B B°A4B&CCCCCÞBC C!C)C2C2C C BPB8BlBÀB²B”B˜B’BŒBŽBlBxBhBBHB¼BÔBÎBÖBCC CCCCCCCCúBÂBÀBÔB.C}CsC}C~C}CC{CCCCCCCCCCCCCC~CCCCCCCCCCCCC~CC}C}C}C{ClCDCC¼B`BLB,B BB,B,BBØAlBCC7CECQCICC3C7CPC]CiCeCICÚB†BTBxBÀB°BŠBŒB‚BxB‚BXBtBtB BpBÜBCCC:CJCCWCQCC3C6COC\ChCeCJCÖBxBpB–BBDBÈABBèABB°A BTB¶BC CCC'CNC?C;CSCMCSCJCDCGC:CCèBîBúB}CCCC{CCrC}CzC{CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCyCyCCC~CCCpCQC%CâB†BB|B CCCCCÂBêBþBCC&C&CCˆBBB`BØAB°ABB B4BÎBC9CfCxCcCöB¼B¸BÈBC CúB C C C CCCCîB¬B B®B C~CoC|C}CCCC~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCyCyCCC~CCCpCQC%CâBˆB(BŠBCCC$C$CÞBCC!C%C/C0C CšBC!C’B,B0BŽB|C~CCCCCC}CwCCC~CxC{C>CÞBÒBÒBCC C#C0CCCLCC5CYCYC*ChC}CCCCzCNCÒB€BdB¢B}CC{CwC}CuC|C~C~C~CCC{CCCC C C C=C@CYCCCCCtCbCIC CèBâBÖB7CCCCC|C}C}CC~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC~C{CyCCCCCCC'CACBCECFC3CC”BBB¢B{C}C{C~C|CCCCCC~CC~C{CtCCECGC?C-CCCÆB®B˜BÈBnCxC{C|C}C}C~CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC}C~CCCC}CC C C$C$CC1CKCMCPCOC¢±&bmĺ߆=fNš¿xÜ¢¥ÿK›x 4qÜì)“èÏ鍊=qÒlüÓmä´™ —ÓÅôš0uá¤ù³Ç9¾ì>tÒ¬iÿ²y={Œ›;iæLÇ–íµ`ÂÔ& ÍoÒmæòI Nú_›Î}À¤ùðYj6¶@Ç/so86·9Çaxùsçrœ‚ŸÓðvbÓñóSðï9Ž³ ˆØžÿ³û»Í7kÒlK7¾=Õ-èôvÐËñWñ;-ÿÇ;ô—k·¡½ºýÓ{ÍŸ³¤) ”ýfñÿ9ÉŠ%Œºâ/ÊøÀs/¾+Å-YüÅâ–‚%þùl'Ì·€Î–^ô.ÁM'χãÀ_EÿôϹsf.›2gvñ·*ØOá¯s€çàÿù§¿ùŒÛÌqãç.Ä»äÌD¯þçz†g¾^Þ¾_Ÿöϓʸù“ÆágTÇ+6ª{äجþÌÔ93'áu:ýÍñ˜?mö”žÓæcÓ9ñÿã#îæÌ™?ÎÚä¼›‰Uê£Öîe¢²š"hÉx&ÖÖ©#ïe0±‘Ÿ¬Aú &6þª½°‰-&$¯uLìÜÕæ;†‰]>iº\Ð0QÚl¼ò©M¶\sYÊÄ¡÷YçELœb3x¬b⬠¦îµ™¸bˆíµG µm ƒ&êÆZ½»õ‡¿Ó•]Ûg1q•+Û Ž¿"Yƒþᯈ9òÚý™¢è˜ç(åùПf©Â,p>3 ­¬*´óÔUL•Ãp_=ôŸVû3q\]Õ¥ÇC™¨¨Mòƒ~<¶•"¾®ûÇLUøöLü!ÄPF»œ‰£ü5C®dâÈÆ–Op_‡U]žç9¬¦uø—CžË~×3ø’1è*œï@ë¼Adbÿ6¯†J&ö=£ì;à;&ö ÑÔ:ß„‰½»©Ó/4fb%¶ÏÞLd»dN¡ó™Ø¡¡þ®ÿ&¶ëÅÂï¶9¨}áÂÄÖßÛ^^†ökµÙ0´|®Õ÷–§ý ¿3ô½õà'Õ•¹¯Ãlq L€çµ/{Âß-£lIn0´®.Ú ã¦9ôõê®LlöƒílÌl²ÁWƒ˜Ø°‹®B× ^ªÌ_ž¶Ô^*ifbý õAŸ@×p4|®žÎÚ±sëìQ‡®¹ óRYC‰÷˜Xã˜>äô{Åo&÷éoà ´oÿÊÄjǵ¿n¬¦ë±±+ ›¾°\Oµ¾Æd#ô£jç­ÕÆÁ¼P½–1ç4\oõŸ¬Wu,²½ƒëT¶³v«ã VÛ£½0ïÕ¤)ós;8¿Ê¦6±»à¼‹dÊ­]`>ŒÖç8Ãﵸ¬q= ÷©Õã[žLlÛØÐÇÚ¡Ý]“¨{Åí«Î‹‡~Þq¬ª §0Tå¿îC§–ÊR÷`¼t:,s»Þ0PkÒn|$«T æƒNu5lV&¶ÏT]=´~o¦fðh¯6”•ªÃç[m´z>€vo¾˜Õjã¸édKxÌã XÝ(&Ö=ª/Üò ®£ªÑÖ Æ¢¡Ir­ ×ÿ½þâèÇU¦Ë~øž‰>‹mwoÂùËw(‡mÜÁD!Ké<ì +¯ÖÞôkÈIJ/U߬Ðÿʨ,‰VhÇRë,¹µç0±äNíÛ~™è}Äj†ûêzÔZqh&:_6¾Œ„•Y‚ÌÕ=ˆ ï¬U,®LÈËRÝ|Ï„ìr¶OOv0!³®µÂÉLHMÓ~ñŒ _øx¾L´­y 8Pé»x`´ê]h,'+}V^dB\*Äm b·ÜýD&ĸhãY2¢ ¬®3!òºâüã½L°6— =ÉËUðsg&|¸ªº`„Ï…úŠ˜ðv€®ìø×'ÔYêÇLx)Y{­Ì„ÀÆJùò|&ø?Ðßš¹ ~´7öÀù<þÎZb/œ‡©¹ÅïÅ&&<ÐésÖª™pŸÏÂ=|ýÎ%Y«FpÜÛ ƒØL¸¥Q]~ ×í²iˆ±#®*ŒÑ[0áÊ8ÅÙ]*&\zkhÚ› ™öYâ&\PË*_ÄsÆĉð{gùsJ8;Ê´ò!`9Í C!`{}Øñ£€ïu >~…ÏÕÚvà÷túçÛ»1áòr¥Óép[⇀>Ú÷+ðzñâù:€ÓÔ&×òðùt]›9Ëàø¯•ÕBÎÃïüa|Zo üî1ýù°r€­u¸0áŒÅ˜²'pk]ó NGÌ›ÈûpÚS£|íÉ„S¼? '2l~ ˜p,Éru$üî‘kÆ¿TbÂa£Åö=Üÿ½:X¡v)dÊq¾Lø]¦=m~­¨Ž—Å„M— ]7\0 - ­¿¯l±4€ kÃeýÎ`™6ää&¬œl,Ü°š +~68í8Å„åõ#;0aÙEe‡g0aéO7h—%c òŽ¿2aÑ$Yë°ºLXØC3$Ž;g¤©ùè®L˜5ŒõˆdÂŒ*ã˜cL˜šh ¾gÂØßYévL=DWg8÷Çf²jW¡ßìjí¸#˜ ƒ¶”þý˜0ð¥1h#œÿÀ2¦Îsõðú[ãñ5™0â«1­œ ãK)‚ëî„ßϳºm»Á„ù#Lƒ ÿÏí¢ð¡?Î)Ô‡vœsOÙ¸×(8¿ :Ù ´1&Ï}ázª_d@»n:b¹Ý®û×FJUÇÓLØžÅJݬńß*YËÕì íxC•0`4ö¹X®­¸Tñl œÇ«×t_lÚ× 2AßÜ’þúé5ƒêeþL0 ¶üÜ6L^®øÄ„W%5Þçá¾E„³v«àx‘%,áŠ÷LøvMS±3\wæi«çïÏa¼÷“5]V†‰•ššÜ?_€yd£*ïáÇzÒ·ò}«÷LÆ|+µbžaðw%'æ®À|+^Tçu:h°ÙÞ•\¥ó\š ØRçúÍ°žFæwй½ÕvÒÝZ¿WN‘3+~'\éT¯àïV÷»?ÂûÑ–ÜA°¨®pYé2Â8\o‹­ØÝä²ý"ó- q{Qp…ÁkQ_æ[î˜}þ÷-wH}s4à$ƒó´)€ÍlÙ_§*´91Ì·lkm®õ;æ[涪°JuÀ?ìëOßÒ”.ï—2¹›n3ßRoùñJ–¹{7kð̘Ë|KÆÚrõI€V“WÏÀ©ÌmØ)æ[â«*'QøEæ¹móõö¶å4ô49o+€ÍÁ¯Æ—¯€>Šßû€;ÔE)-áýRúükp~^|^÷õ<¢sžýp˜:wâGÀú¶¢U ëê ¬e%«Kø¼çXmáo{è 5‰Ì×㜢è9Ç£ÖVÁð‚ÉéVg@þ<óu?l±­[ØGæÚâóu{iËö_8Êä}ð7æëe,j íèjUäKÞÌ×%ÅV¸â! Ìä·ÐEãþòóuþÙ˜½r à&¥w‰C€e î>ýKÉ\š—`¾N5ÔÙ%¶Ö²åf¾d¾²s™O(`sû}”l7õ¶‰ƒo¨ ý>v6æ¾ÛØÍf;ëä"~_¥"~ýR¡U]°30\›3&°ªÕ{O+@¹"»rÀ’&§èfL*H¶¯÷¥‚C&×)³7«óËÿ¸Ê>¥‚%–ÌŒ €‹mµë¿.s³t\oòœÝp—Îu~#ÀóV'À;&ׄ>€aV·Û§ Õ…•Lp<_UÞŒd@þ¼ ©²Êt|dÉ]>¢ø<­n¥>&èÜ kÓÔ¹±7seî[¼sLn]›fª‹f}˜hpº¿Ðhòšó¹ø}Ev7×?Ñ>OHEmeN´€•,ù§/Àû÷•îëÏÖµ;¸ —Ï›Rá EÎãg€YŸ‹_aÌ^|Þ2KîK8Ï‚›VÙ•âëªÏ\]|}îYú^&å¬^Ÿ'ŽPåLÝȤ¼T¬ÒrÀ!¶‚¼À~ú¯Á€=¶¼£€­¬N£³«j< ás¹6«we8^nšÎMJŒ4¸À!åžWå~®xHçâ³póº< pž¢ð™/à“ˤ»€ý™·{WÀÚ¢)y€>Ìãü7Àݶ¬§OèœSõp¼éVÏ.Ðòvj¼FÀïæVåí¶ª37»~3ÉþØ ×á©ÎŒ€óȯep6” N ¿NUä¦ÍÜfunuð•*·â0h‡ÊÌs”0Q›õÃ$h¯^÷å)€ó ²ÉÐ 7Ørf0¸VŽ|¨ñ¨ ç]ä¦È›×p°Õ)üàtÛqèE«,¶KK7ñó(Ú'sj|ð”Á¹ôÓ¢ ™Ëút@¾®’lx¾¶ÆÚüv©€ÌàÂêŽP:¯†ë³iE×jžÓf¹B°¥h\s`~”ÖyK\mpÙ ó®ì7™ó:àa“×~˜×d'™Û™_Ï(½¬gOXrra>ýªÍ»YpóÞ(ú*]×ô¬Îç YeEAæÏ€¢Á+«Vñë:Ï΀õìçï+SÙ2{t£Ê.›Èǧ¯,WçUûŒÿ2¶ÂÁÁ€ü9äëTSçq´-`+Eáâ €•NCaþrê«Ïzg\jï÷¾Nëííéë´Çàúè* _¾N/ež¥vÃ<ÓÍÞî¾ÎSõ?Ãüê|ÚXØžCÎi2çK0Ÿº ×yåÃù¹ün+8çëâ§Îj ó+>g\[˜œJÂüì:Pãýà$m¶{ ÀÙÆ‚¦Åïã<íŠíæºXãbßO®-õyŸÎÁïÞUÎ8 ¸Ó$Ûçå²ÆêÚ®*àtUË”d^“švÂϵ·ºÅÀóÑ¥ƒÁ+ž'.Ýíñ_—~ŠÜ9pþ.ãUù{w>Rdþn|oÉRŒüdòJƒçK¤-¯ß€á¶¼ìµÿð¾Iãô æm|n¸üªtÑý8K›y±øwûË x‚ÉW\aÉ”öüÃ8áýJ²5·Öç†?ç%[Kј?lùsÃv\•ßý<à)Uæ„âã7~šˆÏ ŽsÛ`ûóQ²uPz´(ÇyƼF:Àx“ómŸEáç…0‹Â ®3a¾-Š°¯¤¢OŠüo!€¡2÷…ðý~&™ŠÇ«6/Ê ®s¢"ï`WÀÏaã pÝäT¤Íií|H&Ó…Á}âëD_·/ü>z¬µÙ†·¼®t>ó0Né梀çÿq›­Œ¯EzÛg^›uî‹àùëõÐêeZë 7G X•ðbnõ¯VQ:­‚ûQ’?O|K¾7x÷‡ó*UNçV-?ï|K—´d?{ØU&뤥öç–oÙêÌkð¹r•ùý,‡ïWúd±}˜ˆëŸÊKT…ó`ÝWy‘Ì£-üN彪ÂÞп„ê¼ß*uñ­'ÿ)šé2qÚ, vÂËNý0FŒ]Wüùa_ ÚþsØtî¸ 3ÆM™ôOAbçsùoý%@ì5w朅ƒæOœô7‘VÛÿÀ¯³oÏ: SsþOú‰Šÿåzþ!]ü~)Ûÿvÿór'Ì™5kÒì…stø¬#Œínûkhû/nÍŠ“Wòݘ”~¶R÷9óƒ²ß²~<Þ…¿îeûkÔÚÛö×Æ+aãi—…Lüã„íââEL¼Ÿ¢lzø8féÃò61ññNÖuìÏL|f趌‰þm­e³}™hVk´11 ™Úè¬fbàPÕý`¡úÞ™ L šÏ:|WŠ‰Ïv[Þ%ʘøËä•·ß÷ìÇý¬ixp¾µÏÐ|8®A×å´|ïµÆël“—x®l°‡É½Ïï‰ &÷œÃ†_ cr–ÈÂqLîò‹²Ã†±Lî<Ã$l¼ÂäN+T÷Fmû.™Jõ{ÌÄ¢ÅƼè…§•>uÍ€þ¶0± =k?ü&æ󃘧·ºÞÌ‚~ÔÅ–ôi$ô«²¬¢Ðp¡å¥u-àxýÕñSË©sïŒããúO6ýª©ÎÅÃù?©¬¾ÿî6Œw<ÎãŠÖ)Ï+[+¸8‰õÓÿŸ+«é;k+ü#Þïn|\æ§{-7½{0ñ.ì+C¾1ñ¶É4¨¬ol2†ˆ`âu¯nÑ|ÇÄ+L=ÏÀù_î¤Oì Ÿ¿ ×ßî1Š‰§³µ^0ñ߉G×Z«ÇTe¢áŽúfÐf&z¬úØæŸ}çuuÁü²{¿•„ßÝùÅÐØ5™‰¿(kl‚óÜQB•WÚi‹ÊPßö–‰›ëß aâ¦eÊ¡?Àç6ä³z·¾câz£þ¾ÎsÞ¯µ•-ŽÁ¼²¦´žßLÔ)õWo bâªoŠ¯·0q%ì—ÿj‹Q1q‘ŸÒ{ô‹q¦ 28Ÿù*ð¯éLœÓʤL¶2qæ kùZ©Lœ¾QÙ«g'o6y<šÉÄ 9–üzp^jÚ,ÒK&Ž»jí¼»5«­®Q‰LTïQå”?XBõ¢fÇv0´~0‰c¾˜ÚM­X]}o5Ì“£±þÐQÖ(~gTKm˜-Ž‰#~”ÉÞ›˜8\PEí+ÏÄa<à'‰W%<ÅÄÁ¿c#ö0qPˆÉ'ê`IÅ·¸nLØÌòð ÌãzÙ×=`b$úéÊa^÷=a…;ÍÄ^‡”mCš0±ÇÖ­=|¿üÙÖ¤ô—®4íÀ}êüÈz^ïôÄT*ûW&vx¯·ŒúÌÄö…²*£ µ›m¨òà9[½7´QAh9Âà³£>›_´½ ŸoöX›^x‰Mù†Plle} bM¥ždbÝ<]‡~ƒ™X³©®ŠÏ¡ª}ŒW[Âù GuRé(&VäN±ìac@Ó–L,½Çò±ê<&–<¨t¿|˜‰Þþ¶k«á}÷ÛÚ„¸/.um•gBÑ íSLÈ»£ëé)2!3Zÿ¼ÌT&|f(Û¨7Rúº™Í„/³­-×·gÂçÕúÇ 4LHÐC¿-aB܃pË… ±Û•¾ÊËLˆþ¦”ô!Lˆˆ4ôøÉÊ„(NH 1?꣭ÛÛ2öÌ„Ïc`>–/ø„¸rÚ Ãàï'jÓ‡W€|A(D×”5Ë?¿³Ée«ˆê¨)ºnaF@ ,GÙ”îÍžÂïËl—´<"cÝîÀï–a¥£˜×–™êÆ„Ôj¬±é Ò]O…þpåYµo0!c®¦ãÐqLÈþUשÖ#h‡P“²²^ÿ¬È(×p·6âê*ÀqŠw›ÆÖv<¸Ë˜Ök)|¾‡ÍR-œ Y<(d×Õúm¾¸Ôø¡_YÀÙ¬ö¦~€¥4e¬ÕŠÛ™™7u^Ëáú3¯Ù7Bf”%âèxø®2öîO 9Ϊ >p9OM]«W‡ûõ³6«Ù|&غêŸÇA’5W„Ž_ÃD§í£ÐP&º®ÕóÇ.MmgèÏ^~ê nW™XB©?÷¿äuJ!ÌO%_ê? “™Xê7ãåu{™X¦¬Òóº+àM}bŒ«ÒÚÏóÏŽÕ[ ØRõ¸Ã ÀɆj•á{¥£,×.Á<\6\¹úe¹uê =ûSÔ©«a=Sþ’âþ ˜7*ÔVßKÙk¿ð­N±¨,üÎj³osÀ,õãÖÕàø÷-6X¯O ¶…Ä{Àó«¦fhèÓ#u¥ÁºzæÅë‹íá9÷²Z#è7sªò¯gâ¼ ²†ó¡ßÏ[kª ƒçмºnÐçêÀºb®Éêú ܯ¹‘²6ë`]3¯óþÏïy?«“žÁïÏߦó.lÍÄ…œXe˜Üa<.~h¬ð»KöÙÒâ`_²¬¦Ó[x¬âëeQÛÍx? žûº$]§<è§kfhÏ~„û¾6Xûn\÷z¹µN*ìW6¼d¾þp7U1Õþãwó"«“ôï-ôÉOb™øËVkM#<¶+Õé¡ &îâ¸û›åV0^÷`¿ÜÇ .qÿ9åðëí˜xଦÓph{C¸_‡ô2ïxXÏ~¨+¿9‰ú鶢zÛ`óÙµº#@¼qOû|—Á±“Ò:™¼«ÜbRê,µíÉW@NDH©þú‚Õ³T9]vÂçcÞùï‹?o•¹oõÚ¥ô³äoü¿ŸV¤ÊŠÍgRzUû8—ÒÛX²úödª¬í•yàOJßÅ\ê ¼*sþ¾?àGKÞÉâï%¨ó»¿Ž„@z:4§'3×S­:œª€/ìDôµ£}~‘¾ò€¤”þX籤à«ÇýÒp>ï4.A÷Cõ¶£5pú'ØR*'J¤Ôo–,Cs@¾O”R×h³7–äĶ”²W[´#ðˆÉåîx½¶]Ø ¥6•¹¸¿Ï‰5)¥§Æ©ÏjÀŽ–¼Wðù/ ž öÙ…Ò—!Ú¼qpœä¯×þ»y HJžmõØQ°s} ˆ÷%Yið<ü3`I•Íw  «:ëç?˜ô¹€9åœÌ3¸v ƒ×½8a’ÌŸûR2üJɵ•nß»"ÜJç]î{rEUaz|?À8–>¯·š¤Ïã•n“»ò€}R”ͦ­h’yßóLJD‚$ñ­`\W"¾¢ÕY7༸ÀKJèaò|¢ln̵1)‰šø5JÙ`hßø!VrÝù>UŠ{kÌ ~xÝê¾}*à÷E`çêá€H´Äb€/vŸÉ­BG@–byàXŠÁö‹yk8K1W9Ý¡ÿÆ,Td) ˆ„SlEƒ÷‘T@¦”œ 8Ýàžý"V«*Ïû»âÏGj³¯~Ôçþ×{EŸy¦ø<Ï*r÷oÔÛ O)v¿ºp÷¾âëPçLhÈ×£Rì1möhñ¾Ç×gRì;ƒ›Ÿs¶´¥¸3öý—÷Ř•¿Ú±:'žâgX²³¡=⟜wB¿‰OQºœƒñ€×„–¬E]qü'N’yÅynÀûË×ORâ&}v#hÏĵvB[J\ÀÇQb ¥çær€ ƒË 9 `ߧH‰¢ÆóL@N(H‰ØÏÕÌi Ü×Ä9úL›p·ÎëÄÀ&—2ï¯2—“õoÛÛRâVû|+%®ÐxÖ‡û’¸ûÛl;±"%òõ±”ø='‡(]B¿Hì(srºXZ ùFÛXè? O•nMË_·ÒÓ³àӬ⿙=@/%4bÞ-Zâ¼–PBéÚX(Sd&ž*n?ƒ{¯®€&>ÏÅë³V 7æž= Ÿ+­(P°¾Æ-ÞOhirWY‘˜K˜fÌ>ýØLæÙ~3 ‰ eÎ.“‘ÀL|a)8 ç“ä©sêý)ñ™Á©3Ìk‰Hà%nW: ¸Ìä=úOâ<µM^ûA"'>¤ÄYVç±ÅŸ[¤óz¹­¸ùù$žQÙá<“ðº“Ú+Š<éóǬir›÷-Ic±5-ž78!3÷s0/&àý2©?IíÔE̳‰Ù0±ÀüœhåŸK|npŸÛÐ_‘W¥øúésš,|ÀœŽ>4ÊÜ6Cû'âýJ|kujé È yxß.höPç•=ýó/ÁïóçB¢É–·ÆAâ.Eö£âþ¹ØêÞq  Š¹‰5ø<ŸÄÛ%!ˆ z[Þ‘ƒ€H&l×Ú’Š_ß®ñ–ßÏ=vÂLJ@‚7á¢>ÌÛ ø|LÇÇ}"'¸¤Ä“êüß[¾2æ_„y' ‰Ì¤c§ùó`Æyõ󪂴F€Wí–ô9ŒÏ{É".%wçí”<’Ï;É3T¶…Ó±ûRòmÎ5èOÉœ€’9±&%s¡‹ô¥ƒ]P!}auŸχ/øÜûd)ü® `ž*û7˜ÿSªXÝ&À}HiªÈIóLé®Î²)sZ³PkßGÂsRŸ3 æÇ”æfƒûœ’ÍçÓÔŠÌ×Õ–Üü¦€¬.[ _¥>5^ëM}gÌwVÆqB<ûGš‡Æ½Ì?i•Ô¹¥3ó~ÖÚ˜ßî{šJ‘?¿‰è4|n¤!AÆã”R®Ò¸àCJ/ouÚ˜T¼N1É4Ç%æ}Ú+}ŽªÈ וŽÄôW7KÑH `ûºMúŠãõëNþýúVæ1ÆÑ×B.Lø6œÿý ÇÛ·cJY]LʨÅç팪\Œ—Œqœ0ËXÇdGÊçÏë $¨3p]”ÏÅ̪ÚÂø€œx“2û0·ÕûGhso@ûf.¶ ¥LPd^±deUfRVY“S;x?‹ n¤,K‘ôëì*¶üÓñ~fTçÜ.¸‡¯÷²Ù;Rv¢ÕÅ{1“r°}s~Óç{ÀuåÜÑ箇q˜ÌŸ«9iv‚ðO H @‚ €$8  P @‚‡€ $p Á HA L8(¨ …CpA d@ƒ$à@A <‚€ Ä!ii)hçS€ÏŸ|$,óë(½·BûæYL®å`Ý“·E›?ÖWy\/åqÂNÊÕ©³Û®¤s[¨4m‚çRÎ3;Q,åèUYwaœä`ÿÍ)ÁÇqv¾d#›½RçÒk=`}»pLʲqBöÿ¬zVÍ@\wfɸ`&Ÿs™uö¸Åö¯ÌY'˜W39‘.e.àBŽÌŽ\ˆ“ÙÐä±æ§L™»¦øó^v¢SÊÈe!q€a¶ücƒ9¡*epb^ÊàqP)C§sÞëጅ:×CÕ‹ÇÕu<ôÓŒ|¾ÈèfßWJõ´Y—ûzÛ…NÒ·Ïú¬³0¾Ý²åwÔò~ô­¹Õ£3Ì»ßÊ3/W˜·¾Éx»~Í´±Ò×»0LúÊy!éë;.äøúÀäÚyàQuªøõ5ª¬Ž0}E¢ø+wK_ñ9™Žók:®ÿÒ#ìĹ”þÚ’ëóô'¶Ü@¸é7™gèg鸿HÇu–c¿„ÏÛ´(mA,¬wÒÎñõHÚ» ÷qœ¯+I^1ûzçÿˆ}ýßÉJúÒCþßeþùWZükfòÿ§Zö/‡û?#Q…-þÿQ¼™˜ž4ÃåÈ_NÕ°Ç­íÄ–Ñÿ‰ê< 6ÚtºøN²å1/I{·F&üo «p Û"••2½™°ÝÄú/Ì„ó˜W3-´vU¤EÂçwcðxwžµùOo˜°g‡¢ðÈw€!Ö!àõ½Y÷»_«ŠúqZα–|º… ‡y‡ Ÿoh¾u; ÉvÇ« ¥1±ôQÀãú«%×0ራ1´ÏYÀaêàyùbL8úÂTµ£Ä„“‹XµÂnL85ÞÚ×¹ `¢²â¡yL8]µyYp°åá¼Ú€GA»ÃlwÛÂïŸYghßSÅ„³±ªýO3á"ªk¯¾‘u?àÆ„ëÝõ7MϘp#Øvþ["nÖÖ]ÖŒ ·:(®ôëÌ„Û~†v)ß3án¾Âov,î¯ÒßÏLeƒÁêÄÀÍL0ê”ý^D1Á”­ºï:Š _±Úp^¸ªExR×Úuß>&<½dê¿% ~LKC;šÝ•#~ÎfBÀÅõ‚L>oh±­;^úTƒk2áÕ)[ôË…Lx3†Õt-É„w\]%|8k¼r¥ >­Ð ËûÑÅ,™ú·þ"yÖ€}K),vHä!ù€nà¾ä?ƒìt§ <å)HOA{GŸ‚úäÇ ?‘D Ià D RH"ˆ„ R‚H "-ˆÄ RƒH"=ˆ!R„H"MD!RÅA²éB$ ‘2DÒiC$‘:ò¬k«=Lgêã&Ãû1Ö®©ZÀ§¬ÓºI€O4•–‚÷«èS Ó?‘)á{Vm¸küÎy«­1ÞšÒ·—X-Tõus_À+–È•Ç(»ýžŸS6ËêÂÄ*—ŒY'¶1ѧu`«ÏL¬üXYçÎ &VªdÜŽWþì.æÂù÷³/ªÅÒÔ;Mëã$¾Xâ7ýËŠ:À*ùöEpý?†*X[}Ùx°™Av70Ø’½8•‰ž®š’®½˜èl¶„vïÏD'o™W‡)Š Oû1!¿„±àŒÓܪËñJLÈ:­¾\îwæEÕãXø\æVûZW&dœWÅÌ[¸Åòuß$Àú°Zfx¿–þK/ø~&ªæ³9Ù+䮕թ ÷o±µE=àËã…0Îò"íe!Ïhèºl<à YŸsðyžÝ&ds’UÈx¤Tnˆ`BzWKÌùÐßy°VHi¤Ê¸ ý69GZÔ °ªÁ÷&ô«Ïœ|>o• ‹z¸TuþAGÀ-Öj[×Âç<”®¡¡¿=µúþ4 ~÷…¡lôû¯÷LeÕg·T]#Ï=pÜƤøŠp=\Ô ä2Ô ÇË+ë4æ“|œW z+û~S_Ûýó‚-´\llñÎS»ºÞ/mín˜ŸçYšBþuöÖi€4ÒgYqûØE$BÎ#uä”Òpüé¦òÃaH_.ëߨ\ïdVÇ ç?Ñ$’*µ‚y:q¯íó5˜'bW[ÂRáøÑGMž©åaü…ª “á9î®l¸îãÇÑֆϡÝÞ+B£GÏG¦ši½`žÚk´Y`{VK}n+Ì+ ¥OüáóúS .×ôóùÝ媛uªÀ¼:E©¸¬`•P›5kÌÛŒçO›`^^f¼¾®ïxš¬ÉQ˜ÏŽVÔ©ÎMçÆ*õëšÐ~1 bfü6žuvƒù|ëÛݨ9ð<Ë5TÜóÎF¾)~J2¾ŠßÉ„eŸ-7·Àsa^UõU>?•‹5„‰5¥6Àü4Œ“å°ÏÆ*®€ªóåg1a¡×J y¹ ª úÓ¿Âqjp5¸P£³åC¯+L(Ÿf複ùØ3KÖÿý7&xX­ kÜ4›j> ØG›ýÓu‰NÕð&¸|o_ŒV¶ñl¶Ê…÷‰¿®`•‹’ U§ÃýtúÝxçó2xÿ¦âÞ˜$x½©²Vä'V6•gÔe‚¬£ÎåÀ @¾‰\&Ÿ«Óy6®à2ÕöÍí/Ãþí2MWcôc7¾ø<’mß*Â<ë¤éÔ®Ïs²Æ}P>`_ë@O¸>¹ÆË—à¹íÙ[ÿl<ÏËólSAÄç•ü°fè+O&Tég»úúY ¼jl–õ”`œ×¨¢|¶”œdj7T¥®kÉ„:¬ sV2¡Þ4«¸ž;u YKE;&4<Ëš¥ÁxmÍdÏàó-ƒô¯*Ãøl½ßx]÷·­“µA<ŸÚ{Ê€qÑa¤:Z¥cB'¥nX x~t®OšÏWöEmýsà­qh<ÜONZ#27ÚÁx¡¿Vúëh>¯ ãÓµ×wCœÆƒÅ¬†ª'¿Áø]¸ÝöÅž;Kúʆ·¿ýˆ»…åí›aE{eãô:LXY^‘PÏŸ «.럮9ÏÝi{ðMXÓÐèßæ±µ\Ü"¬ªJ†ãnÀ¬ \ŸI©ãdÞ¿½l's·¦âæ.µ¶¦v3ÍPêp„JÅàcê[albR/(½ZÃâ>õß”¦rÕ§”Vžo–ÒPýš†A’ôz¶Ü¾.€]Ts†jìÙRúaEþ¡t@žÍ"¥·ã›Öt &¤åª Â&&«<¥´&§_`sÖQÓ63iuíjh)gƒH©˜-‘:Ë–# DÒ"UÎœ—­)âðMR ãAÿ”F§)×= ób˜ôå£"Ë›Ñ/¨¦Má*U)¥œ¥`8lºSê)lËÌÿBR!³3R‘\lW…K©s”ž°iJÅ n*KRÏÉŒàÙ/RÄ:“KG˜_"zëœöº3)ƒƒá™s-¸®ð;|Þ çYÙRx_~þáõŒÙ…õ±¿}ú¬ôúù1 ;?U2¹=‘4ý„íù©¡¾ uÀz<ëà^ß'A›«^Ť<{EúˆóûÇ·ŠÂ~s‘\ûx‘¹öÿȳ#¥©<8÷³é>ð}¨ôƒçx6†ô¡Ò†Ù8Ù¶ÖàYí fY|@2øžçžE }äÙ¥ÒÇ&üùó‘sï·ÊšC¿JÆ ~2¶SòNr|éÁÉ‚/ÜíCú²Ìž%}Ál®/T™Ûàyÿå³Nö°÷?<çp¾wˆ08˜ÚC‘çß°«}Ÿ ¥v¶åׄñœŠóZZm«— ÆcZS>o§µ2fæÂñÒF) ôp}i¾ÆB·Åȳ,Ójp’% Ç]Z.ÚHû^•}¯˜ô Í/Yȳx¥´RÌue<ï¬ÝAJ]©ÎŽT||æéˆ×ŸŠóa*ŸSqÞLåYiR*’iÃôyWnÂ:×I_‘tþŠóB:>‡Ò/X²D®àdk:/g¥ÁúÅ–Õž+iô»‹ ®_ày”ÖCæóL*Š R/Ú³š¥ÔŸE9©´>û› g›ÿlÐóo† z¶üבÄÿnÐS<ã;>&µ¬˜ÏO»9ýåT×þë˜]dõ½”‰ñ\Ñ*ÆW4¾Û Çrk 1ö½*¡æ4&Æñà§øeŒ¬D—#LLMÖt,jÊD ž‰É ½?EÀë•4VebÆjcðÖ]Lüš ýxaÓ–Y™:üÝGõaËJÀ=¦Á;vý™ñB0”C2”1C4”QC6”qC8”‘C:”±C<”ÑC>”ñC@”DB”1DD”QDF”qDÊ5R²‘²”n¤|#%)ãH)GÊ9RÒ‘²Ž”v¤¼#%)óH©GÊ=Rò‘²”~¤ü#% )I)HÊAR’²”†¤<$%")I©HÊER2’²‘”Ž¤|$%$)#I)IÊIRR’²Ò¡´Då%)1ÊLTj’r“”œ¤ì$¥')?I JÊPRŠ’r””¤¤,%¥))OI‰JÊTRª’r•”¬¤l%¥+)_I KÊXRÊ:”³¨¤u(kQiKQdERd)ESd9ETdIEUdYEVdiEWdyEXd‰EY8Oþiq@–d@–d‘@– ¨˜$K‡ÅZ.0æÉŠSè½íÖ,R>.òPWƒ9Õ€MV~y÷Ø ä—±zLãæs«)ù£t^ƒnÀçQ‘™J¾7´bÀÍH~€Õs*¼Ÿ—mð®QPÍã<žÂ-å¡¢)©¹¸IÌå™tR.³rÆ?  YÜŠDÊÂÅCfgH3§ >\eRn²2fêó#Æ0éÛK÷©b&¸<ßt~E†ýëeνÂÏç+*`HQJ S‡â”¨E**TI±J VR´’•\RÀ’"•d¤˜u(hIQK [RÜ¢—¹….)v1hAŠ^3LL12ÇÄ$;΋˜fbž‰‰&fš˜jb®‰ÉÆà1Ý曘pbƉ)'朘tbÖ‰iGæ˜x3OL=1÷Ää#³OL¿ƒù'%)H)@ÊR²€”¤< %*H©àP.’” ¤t å)!HAJ V’¡¬ ¥)/P‰AÊ ‡Rƒ”¨ä e‡CéAÊT‚2Ä¡Aå)IÊRšà¸ % )SH©Bʇ’…¬OÈ …¬QÈ*…¬SÈJ…¬UÈj…¬WÈŠ­YȪÅaÝBV.díBV/dýbŸ'ÿº ü+þný×M@«½²þ/+N¯ÞÜ¢<,rš.­Ýåþ_÷+Ö¥§É.ÿ›Ê‡Ð?}ãÈGÎá+G>sè;G>täKG>uä[‡>väkçð¹#ß;òÁ#_<òÉ#ß<òÑ#_=òÙ#ß=òá#_>òé#ß>òñ#_?òù#ß?ò$_@ò $ß@ò$_A‡Ï ù’!ú’O!ù’!ù’Ï!ù’"ù"’O"ù&’"ù*’Ï"ù.:|Ñ—‘|¾äãH¾ŽèóH¾äI¾äI¾‘ä#I¾’ä3I¾“äCI¾”ŸJL£ô1G:¥—aº¥ŸQ:š#= ÓÕ(}ÒÙ(½ÒÝ(ýÒá(=ŽÒå(}ŽÒé(½ŽÒí(ýŽÒñ(=Òõ(}Òù(½Òý(ýÒ)=Ò郔NHé…˜nH釔ŽH鉔®Hé‹”ÎHé”îH锉鑔.éHŸ¤tJJ¯¤tKJ¿¤tLGz&¥kâø§tNGz'¥{bú'¥ƒRz(¥‹:ÒG)”ÒK1Ý”ÒO)•ÒS)]•ÒWIiCÊRâ2‡”:¤Ü!%){HéCÊR‘2ˆ”B¤"%)‹HiDÊ#R"‘2‰”J¤\"%)›HéDÊ'RB‘2Š”R¤œ"%)«HiEÊ+Rb‘2Ë¡Ô"å*¹HÙEJ/R~‘Œ”a¥*ÇHIFÊ2Rš‘òŒ”h¤L#¥)×HÉFÊ6Rº‘ò”p¤Œ#¥)çHIGÊ:RÚ‘òŽ”x¤Ìs(õ&¦˜˜cb’‰Y&¦™˜gb¢‰™&¦š˜kb²‰Ù&¦›˜ob‰'¦œ˜sbÒ‰Y'¦˜wb≙'¦ž˜{bò‰Ù'¦Ÿ˜ÿº/í¾hBíCíš¾L§ËjÅC»{Þ·ö …ñâÞUÔ«œÇý•*çÍ7Æyý XU{ùBV9×fUüšÀ*tÕ}¨a‚ËSmÁÄ]Lð®bè¹æ‡rè‡Zî¡ôзL¨ÐÛrkÜ'&nÆðU˜Põ•®Ìè?ÕùæR¨VÆТÔ4À˲R3r™ x¤ì·¬Î{“"cGi&4 ¿¹+Œ -†XÒ÷\…ë<¤JóUë@Ûc9´OסÊVCàü{´4tò…þÙƒ+„ž½UïFÁ¸˜© ˜ãkPGe»QîLøÞU'Lõ‡z¯®bÉ•€[3áwÕ«XÕ§ÿô%?Rò'%¿Rò/%?Sò7%¿Sò?%?TòG%¿TòO%?UòW%¿Uò_%?Vòg%¿Vòo%?Wòw%¿Wò%?Xò‡%¿Xò%?Y‡¿,úÍ’ÿ,ùÑ’?-ùÕ’-ùÙ’¿-ùÝ’ÿ-ùá’?.ùå’.ùé’¿®Ão—üwÉýyɯ—ü{ÉÏ—ü}Éï—üɘüÉ/˜üƒÉO˜ü…Éo˜ü‡É˜ü‰É¯˜ü‹ÉϘüÉï˜üÉ™ü‘É/™ü“ÉO™ü•Éo™ü—q]íðÏ#?=‡¿ùí¡ÿùñ9üùȯüûÈÏüýÈïüÿÈüÑ/ü~‚ä/H~ƒä?H~„äOH~…ä_H~†äoH~‡äH~ˆäH~‰äŸH~ŠÜ_‘üÿô_$?Fòg$:òoD?Gòwtø=’ÿ#ùA’?$ùE’$ùI¢¿$ùM:ü'É’ü)ѯ’ü+ÉÏ’ü-~—äI~˜ä‰çKþ™?Mò×$¿Môß$?N‡?'¦ëPúŽ#‡Ò{(ÝÓx(È‘DéB”>DéD\¤t#Gú¦#9‚$”®DéK”ÎDéM”î„éO”åH¢t)JŸ¢t*J¯¢t+TLQ:–#=køÿLßr¤sQz¥{Qú*,(=Ì‘.Féc”N†ée”næH?£t4JO£t5J_£t6Jo£t7JÃt8Js¤ËQú¥ÓQz¥Ûaú¥ã9Òó(]Ò÷(\”î‡é”èH¤tAJÄ`ª#½S¤ "E•CaEŠ+R`‘"‹Z¤Ø")ºHá…Š/R€9a¤#Å)ÈHQF 3Rœ‘i¤PCÅ)ØL?µ)ÞH‡Š8RÈ‘bŽtE)ì0¸I <‡"zؤàs(úHáGŠ?R¢"‚Å )IQH CR¢‘‰…"*IÁèP4’‘¤€$E$)$I1I JRT’Â’}bø1¨H ‡"€H‚À¡( …)0¨NŠR(b ¤hp(Hñ@ RDB‚¤ @E),Š R`"ƒ¤Øe•mhçã¤óxÞƒ_1mý+’>_‹lyÏ~…yŠ?¥oüù,}Ã~þÍlËUÏw'uîY0ßf®:kß@8^TÂÇeŒåƒÏæãÎ=Î|¼ß±RQ•áz|ìòJ¹­•-òy&/ü¤x%» ˜¨Ê,µ¾?Çò‡e0´G[æœ÷#¼®Ó~Q6`ò¼æêÔú_˜<©ŠñE©9L«?¿¶“G]d=aò«uíõë˜üí}U\æc&i[‰É_²²¯1Lþ2@‘êy¦h Ü—`ô‘?+£lºà “t6È'Á}õÛj|¸ðé`MÅû§˜üIGC‡ôLþxâjÿT&´CYçB&xOñ^]ÉM¼¨žÜȽá亰¡#~aò{›”}—úB¿yj­¾­-“ßvÒ'téÆä·jhú§1ù³Tãî1ùÝú¤Jטüz°Ip…þ6Z×j;“_n‹q9kWí®¾ÏÊ%ÀõŒ)05[¯eòѵmîídò‘ã,) pœÔ3ùP.–÷í­M®¾„É{gåÊ×`òîmÔ×zÄ2¹ª6 T>“wùÝ’Þí“w¾jjѲˆÉ;†hêû2y;oÓ€ñ›™¼ 'Ÿä­¶["OÁï6Ÿ®©R úCc®À’×϶*ãá¸õš)‡{Î`òÚ\9(¯ÆýroeÅù«™\¬lù<þW&/?ZŸXÚW˜,ëXr7“Ë×°¶'?2y®°‘Ë´ÖÙ/V°ËÂåòŠ–?<áþÈ›[ûœ†ë–ÿ¡ú¢ƒó­ÒOwÚ£ ÷”Wݤëv^¯š ì8¦:|N¥)ßî—§¸TúåëÖª^ÙL^)À–úp•²søÝŠóm/2™¼‚QÞ,ί¬íüa¸e¾YÛ• gòÒ£”C×[˜¼÷–—ܤÖþ4“{ïcMf˜Üc—uȶD&—­°ökúš‰EèU[pVÿª[]&æ×T¥} bb.—ƒ‹¹S,·Ú&21çºÁ­ÇÖ?½’É;™¼”É[™¼–É{½˜É›ÙáÕLÞÍäåLÞÎäõLÞÏäMÞÐäMÞÑä%MÞÒä5MÞÓäEMÞÔ¯jô®&/kò¶&¯kò¾&/lòÆ&¯lòÎ&/mòÖ&¯mòÞ&/nòæ&¯nòî&/oòö&¯oòþ&/pò'¯pò'/qòï9Üò¾kà ÅåL=oi£ï@;uåiær•Ÿ>Ê®o¨öZ¸Þ!×UÑòÏL>Œ{ËG\7•=ùÆçb㋘¦Lþ}†µ3Àä?Ž—Õé ï=ɪԂyn WzÉÜ0UúÐ’ÉW<0¦®è´,ãi6–)–œc»GpK  -®<ø¡ç^F,ˆÄ=â"xÍ)‚+×¥pôÖ ?i/R&…óts)ü˜]á.…c:PøeîÑŽi`á¹wc8zk†G<¥ã€12׫°)GÃpì—Ῐ<*Ãø _®qÎ(,noÞOÃy‘^)¼¯%§æ½â4-Lû´Ã–=úc8¶OøÞ.áÇìÅɤðû+W”KÖÞŸ"1--ûS$z\FæÈœFîƒñ[Í^TFŠê©ÍnïGñ¢oRzßEš¼ž¾†ñß–÷“h^ÔNŠ^/sÝ÷#ú7æò Ú%ɇèÓܳ3ú²Á-uàM[ÖþW€FtŽF¾èGhŸgîÅÃÅR *H^™äI^šè­I^›ïMòâÄ  yu:¼;ÉË“¼=±ÈûÓáJÞ Hw¨ÃK”¼EÑk”¼Gé¨\$¯R‡w)y™’·)y’÷)z¡’7ªÃ+•¼SÑK•¼U^«ä½J^¬äÍJ^­èÝJ^®äíJ^¯ïWò‚%oXòŠ%ïXò’%oYÉx’q¾øŒÏ¯¤tN>}.ÍɥϨôþ|{é~~Àç‰Ïèi™¬Ö9?9¸…§‡&£ú /(}AÒëKm{Q#)ù¿þÏ,æÏñ¿Qjæýgƒ(€øk¥Í¿ŽLü—ƒ(ªŠc®¿€‡ìÓ°áoÕúË©nŸV=Èüðì¿DÙ‹¿&ßæ°yíU¨«ö6Û}^j-×›3¹Ä .ÈûéMƒ:0yÿ±º Þ°XPÏòè,ŠhÚ„×ýlj—‹îÁEÆÛ<`‘(êl(Áäßý"kZ 6ùßw‘•=è‹ÃJŠgÁ°È­P¼‹€Åï˜Ú»GáúÆþhèàÇW/QøûÀb_óÞÔ¸“ÓëÚ/üÉÇOÓ¿\Åä꛺ê ›GÎLɧFjoö›ÍX…íÅE&ŸWÂ4tœÇÂJªÐ–°y_²–uú›Šeµ4'Áu¬lÄúŠ`òÕ6ãƒÞ°yÔõ±$lšÎä?ñ·| WÈ׬ÔGß8ø»"$ò à8uò@Ø,þ”`) MÂO\a*×qCY¹nˆ²i58ÿÕ<½G¾×ê¤öJYؼ¶À_ͺ¨¯$Ã|Ñ䤲ŒÆC#®x‘×û¦zÓ৷"#6ãµG+ËÍš ç1NÙh6üžb‘ê›w-8ÏpKêNèwÕw?—‡y°:÷x’W_omзð•-þ§ïáó‚6x&ô{Å2‹1e/\׫üò9&¯óTÍ-Š‹½kÃqj+{=½ Çåi‘òzܳI^ÿ¹åk-\Ÿ›®Ï6W yz‹¼q»‘²¼ÉÓPV®§®±w_¸¾n¦ ïŸA¿åxä­°d.ø™ÉÛŲ¶uaþí°ÄÐ÷—ÇLÞ¥PY÷ž÷l9g Ÿ¡Ñÿ³†–Ÿ”€¸}†‹½ }n³F€I\‘ôĘ³cA'-EaQ„Š’ T(õ2xøC»56¸¨X“§U¢×I ¯­h(,zУ$`‰¶è~$ n²¹øÀ7#¸ 3°3ƒ’ßfôxñOÖ¹eÀ¢Ðÿ'}áðû~¸¸÷C†Ô½ üp±ç‡íøì§ÈÀ?E¯—§<-Vz‚Ìð“ŠÜ`þ1ÞçǽyÚÛã…ú¼ O˜ô° ÿ¾ €GxpÆhPº»ÂfçzÕÜÇÍÚ}4–¿‹÷ï¹‹Fõw×é³Cv"Ó÷¤É³G/@,üp×ÉúÁf÷îcîÑp—WÔ–î7x|…þ|½vîñ`·tï ßäÝÇEüý-·e1§ç°h¿AûQ<ïÁ*¾I{€Ê#2ÈÆ%\Ác|mW8J& ˜\¹Ç‰ õn²W"—r&VzˆÞ#¾(Š–V†öÄã=­Â7yOy…qéé6TòCŽö ?ôHñCfÝW8•üËro ÿ5<Øâ¿‹+Žü1xäÿ…+RÌ­íA]ÉœÉâ0m3 ‰ÊV½¸q&W @%SõOÎ@K8®¹âO ì`É< ×ø#WÊâ¦ÃtÀgßÙ+²JÏVÙ2÷Áx{¶ ç‰ý\a÷ ûí3 ²<û`Ÿw¥çt{Þ\•«‚ßy>šß—瘞ùü€Æ9ЃjϹ‚Sz¡tÿ6ƒÏñ¼ƒ=ù&.Û57µÁ\)c.ƒ¦Á× ²²°y ~k/´$½ÀÍþ T(½è)ó.[<_£âåÅžÎûâgæ=6ñ/ÐóéEŒ¾°M=þf“÷ä?¼Éû» Ò_7ymÿõÎ鿼ÉcШ!0ØC  «öû_Nuÿ{£Ç¨É³ÿÍt¼¡2ÄHCIŒ%1˜ÄhÃIŒ'1 ÄˆCJŒ)1¨Ä¨ÃJŒ+1°ÄÈCKŒ-1¸ÄèÃKŒ/1ÀÄCLŒ11ÈÄ(#ÃLŒ³ƒ.Ë7>%(åƒ=kë:´a>ÌTúØhæ#»jûZ®¯ˆ§È KÊ*,†M¬­HÙ(u>ü^e‹iÎ<æãÒ]SãÍø›ËáåO¬òž2y&2¼_~V6H.Åäñ<Ò(™¨¿‹±ˆ@C s“‡royh¨åÝï>L椽çýþ¼ÒÕ so=UI+®ÃõSÊV¬€vñµ|Míí6@ý¡y{hßHý—Ç¡½wX’K,¯~“‹¾‡y¶Ø¢çL~Ó¨ˆÍ…ö¸Ê=Bä×Ü5ÝÆÂæùÁ]Örܯ!L”²á~®´Ö™‹íK*›~ “_æÆSòË[eõSoÁëÙŠ+Gj2ù…Fê³­2ù¹¦–øaQ{Ž%ÉOpÃX¹A°ö^ ÷ñ¤«±t1“äžòýk•Í—Tfò½ÔïêÝaò]?É|ÎÛ˜ü×"uò‹£°kðç󓿦îcaó;]uûí€?7Å´I¦M3m¢iSM›lÚtÓ&œ6å´I§M;mâiSïØäÓ¦ƒ   (ˆ@A 2PЂ”  -(ˆAA rPЃ‚ ¡ M(ˆBA ²PÐ…‚0”¡ m(ˆCA òPЇ‚@¢Í@Wo]&Ú#ÅòÎLWóe&ïØ—±’ÞLÞöºêV]èw­^šúkB`ÓiÌ)ú›èÚÖÖ-¡5½iê×Ú§É/†ra¼4>­÷ûÐ 6Yõ¬bX2lj6Øn{Âø¨û£²d‡L&¯³QŸž3°­âÙqOØ =µ/Šåµw›ú©‹7G]L `sYë‹Nyä@7Õ¥ø=ÅDUÚúXØ„‡¨Ÿ?Mliû´ï0“WY ©ž ãP^Ý.‡•WL–‰oa>+ŸoÑ«1lFST·ëë`sª1F ó.ó½¦ÇVè¥yºƒ¼Oo“—Ø¢¿lͦ'¯ž#wk¤µþœ›n“¡Çù7LŒ\©`ÞÂD‹Fÿ:å? ¡ó» {W|ÛHY±¼ÿz¬©Á«6L|5K3â\&¾àFÇâóŶ¸³ûŠ½u”ζ;L4/°Öø} ý~Vê3ñÑ<Åë°FL4ÔµHÜÈÄû—Xõ¢ &ÞÞ«ÏX¹“‰7Öëã[ÈÄ«»QÒÏL¼Â‚ÅË<²,^h©¸ù¾7à9S»L¼8ÒxiM,¼ïb¨¶‡Áç'é“SC™x픡»ÎëV9cZzOÀóú§=Šcjø:ž‰wø¢T¼3EÿlÂÀº†-à{w>k¼CôL¼û“"¿šçWAWf¼nÂ*»°*ëÓö¬Ô¸.LôoÉz– ×Y‘Õ)`bÀ5õƒïvÀõ7Q½m4Ú£¡Ìå2œ_p€êÅÒÐNëf§­L|hmÿë4h¿úººïà=ëا¹>´z™@;óÅšøÎÄj¬mÉÄ0nD'~Ü¡ÍÏ[&å–fbÂ`ƒl{&?W4ô+}‰ÉÁÚ³?´`â—}Êš^Ó™˜Âƒ%rçzºþ»72¹G¸öùôóLî]Zu-æù’ÕUW|>ÿ©!E)DH1B R”„'¤@!E )TH±B R´Â…/¤€!E )dH1C RÔ†7¤À!E)tH±C Rô‡?¤"E)„H1D "R‘ˆG)’P¡DŠ%‡‚‰M¨p"Å) HE )RL‘‚ŠU¤°"Å)°H‘E -RláúéOæ—˜`b†‰)&昘db–‰i&晘hb¦‰©&æ™lb¶L71ßÄ„3ŽL91ç&˜udÚ‰yw0ñÄÌS›bòÌ>1ýÈüÂtžOÇypà½_Gçô6ÝᘦîÍ7ŸÐsäScžVñ±€Ëé?¢çÏG”×Dù‡RœAÛÉ«ò… ç”ax]¡È …¢¡dè)®t]$óhûp.÷$ õ²ßw)eî!hìø¾ˆ'Þ#Ãø=„Þk¸Ð{ž†(½ãýBz×—§ÿ¼iÉê8GãÝè `µ-5–IoÐÃéež-éh@Tž¼ôàƤ/ryúÑ Üä½ÀÍï /Káy¸Á|}"#ãŒé@ÁÈ?G¦ô9O—”žáfüÙ\“û.¸Ï~äÕƒ°ÿ!3MÁ#G0‰‚Kl¢à£(8EÁ* ^Q0ËÜ¢`¿(FÁ1 –QðÌL£àÛ(ø†Á Î9‚u¼£`÷(ØçþQ0ƒƒ,t)˜HÁE 6bPŠ‚‘Žà$+)xérbp“‚ô:C)8JÁR žâ¦ùe#Ì'õ—Oy:à«V|sþ ƒ¯é~…U _õ·{“I¯&œ§MÄ´·W§¸Ò«t^åïuoÜz ïkLÃxýˆ§/½ÁàÍ›‡6ÛYè‡o°zÖ[Lcz‹A·{íiÒ[dtßæñ â;œ·Þ½äéï»)ÝÂ`<¾_ÆïÃ{ƒÍö® àód*B°šW¦Ç„`%ç¿!X5,½«BÐS+dŸ%¯ ðKþ*è!Á:›ˆé+!‘ª¬I5ãìFúRφDiÜóa…ð R/à!…`p&«n†ì±º—ùP¯q®ý+•X!¨ yÆÇ{¨“}}#…¢as(V ÝÈÓ¾óÑk“,r%Ì[h†UÇÂÐ 6  a—•.#`¾ùp‡ßï-¹·ØG®Œ”>r²NúˆžU1HûH?© Yñ÷by»¢7Ó'œ‡>¡í'4¸ý„Ïð2×ç0ï„£’-ÓÇÜžLÄ4×ðU\ŽAÏpT D¸+lÇïÞÒ¸ôÌ´e¥Ý‚çM}ƒGïbcg|X0mЂW–¹Üø×ÂÓ3$ *'HyãPâ2‡”:¤Ü!%){HéCÊT‘2È¡"å)‰HYDJ#R¡É¡LÂyØ¡\"%)›HéDÊ'RB‘2Š”R¤œ"%)«HiEÊ+Rb‘2‹”Z¤ÜB%)»J/R~‘ •a¤s(ÇHIFÊ2Rš‘òŒ”h¤L#¥*×HÉæP¶¡Ò”o¤„#e)åøúéoÒkü‡ƒ†pûkаݿŽÄý—=¼> WŽv†É]±×G/ûË©î9óK™›¯5ÿfÐp8Šzé:¿ê¸O›Òÿ`ŠúÉ–?˜`ûÞÔñ±‚‰²%Ê>ÞLtâUžD—öÅŸè¶[ÖÂæÄDßuƒÒ×3Ñ{·íïE&–Ú¤T¬‡Ík™·Z#˜X^«þ´y-+r ±Reµï`]¹>ëä›<çž‹ÕÊZxÀ&¶z…ÙÜœ‰ ­úÊnØ*;ƒ£Vf˜š‡Ãï×nûãbëüa2!‹‰õÚª£§Ãf°¾—²ŒªøÛ"æ—cb£CÚÐz°In:Ër~él&6¤ŽÙ#gbËFúÏ)u˜Ø*Oêdabk”Ûò ©Ø.Öx3n;¢Qmçm¶¨c°)ír]7È6­]?YY8^3XÅ/Ð’ZŸsq(ûM׾܋‰ç«n­¼ÎÄÁSU4›™8´•fø™Lü®–Ì»S G¾Òu|þ‰‰?D+•?~f☱ËÀfLÔð´"qÂm}Æ#LÇ7¢¦¬"ÜŸûlû9‡‰£÷s®2ñÇñª8… GRŸµÂ&ùûRêÛ¹°þ~«í‚ïKÀ(õ•Jо?,TçvH€ïñ`Ž8ú¶®ëÛSð{3´ï‚ë3q¬“º`Ú7&ªeÖA,ãIºþ3~gâøu²áxïšZ ='É íÓJÂß…:)ö(àcMgÝÀUšúžð½[Ÿráw®/°Žµôè7cCu­»Ãý;KÖê§_%Cãçàø_m÷&H€;4§<„óâÁHqgÅ‘|Q$~Ç=SÄïxéQqD¬L¡ÞÈ7mâgõû³½™8ü”"IŸ¾Ô{úÑp®‡÷PÄ8Zü·ñýÓêLÆ9Ð_‡mµ¾Ø îÏEò¥L2ÔÚÿŠîzÌ 4êeÿ‚ML¬5ÌTeŒ“šm_'Ü`bþª€}Ð_•"ërõŒ«iºþÌÀĪÃ0?>ÍLíÊw‚ñ— ½|îC%ôÔ«Àƒ„bÙ®†ÆŸ`Ê„È®Ú/‹áû–=–Ë †1!Ü¢lûSo&|쨿-NbBzv…žT=íÉ„õÇð›Lx[Ã|µ!^X´!¯¶1á™E{>b.‚ÐC*PRؾc‚y¤ÍÏw0MV_žfb‚i¡¡¬ Žc\c{Ñäœ6T5é˜p¿Œ%ýË>&ÜB¯›>ú‹˜pc¶*øh&\õWçOíÆ„K¬‹¶ÜŠ‚û¸®¬¦ï¬­LX3^ñán0VqRHXZdhºîÊ_­-èÅí<ý»ùpZn$/hÛXnÀ‚WXÖSYi!ô‹eôQ›²™°=·¦rrL˜6N#tƒë˜¾Üör=\ïü£²^‹àw—¸šš6×W–RÇ$Ûà8&]{ßÃ€è µb«©û Op.ç6¼P¥\˜ˆÕØÖ‡êÏÚ½„ÍZk/O»ßhŸü8Ú«Ì°ŠÚ‘³ªKÂzøû†þúö‡ðw†rÀ›âjØöo×UšX‰ »dêg= þºÖxÿ9hžŽ"¬j¡µ‡óýÙöü}I8¯ ²vpÜ XenkWc˜ï˜?«½Qõ7ªGÕá¨ZU£jrT]ŽªÍQõ9ªFGÕé¨ZU¯£jvTÝŽªÝQõ;ª†GÕñ¨ZUÏ£jzT]ªíQõ=ªÆGÕù¨ZUï£j~TÝ/Ÿ?„Ââæ‚ñX$*®,n8Ù4l&œ_‘N˜Ç/jgß¼Ð:J Û£t®Ÿˆ›ª0Ü´„u·çÌKa˜–ænpîº6ßô™Ã†âæ%4–oþC㬞‰×±zJh!÷$ C𰺊¼Þ£Ñ@;¬.Z†U·{H¡¨hs1yŒ,> Ðß¡…Ì£±üŽ‹éM¡ÜsI ÅMWèR}â`ßT†N×æÿòî7G¡XJ;ô'ûzB Å L(nzCÑØ; ÓÂÚ¼¢±u˜B){5“1R¯~)…ap!¬œÝƒT «fÉRK…‡ àŠ…Ðt;™+…^5¹«¬ÿp>è…ŠA²ÐÒÜ‹&$ÑžÞ'…ðê›R~/d:¯ZÒžoÖÞc0àýQ™›ç*Àå<(ù^©ÊOûñ={Þaú×»•¼ZÍ;þ¼”Þ5×æm­Å¤·6mád¸ž·œx‹i$oðþ¾ʹ_gÚ H¯1Èøƒ`¯ñûo0øûƒžo¼­Îh¿7<}\zSZ›¹ö`Y}æ[ØĽÁö~ƒio|¾p¾oªª ö÷ÄvƒAÝ7ÄyS_éz¡CñßÜ#ë I¿éiu‰l 8—¹@»¿Ù¯/Š^x‰y­ŸˆãŽëÂt²·åxZÍ[4J«ä%ÜߢgÉÛÊVÙ§ê€^ÜKéÍ+t|càÆ×oÐÓéM#nþ=R^s²Rz-×ç^vcÒ«÷J«C1MâÕ&}v#?ÀÑú¢_~eÒËYƬ|w/‡1—m1ýã%=_¤ðô‹/í¤‘ô‚{ïJ/¶Z²Ÿ½ÄñüBÉ•kÁ\ æ…¤à¨LœÉwÁ轌 ªàÊ2Ñ€˜®òÓŸ£Áös4Žé@ÏÛò ØsLy†üÏÐKìÙEL|ÖEãñz#`5uöÍÑÅŠ&îÍ„Þ^A!¼*XÐ U¡ßg@Lw ¼epÝßÄö ÀªO¨<2cpÃŒé„f3÷*3£²ÎŒÁ sW„™1ØkŽ´‹$3År#` 7œXªsIR¬pä^9kù¼€P™0‘U0XfFï%óyä0ï7y÷>ˆínþ…§1š7ð •Ó/Íü0sчdƪQf žùc•)ôlóGŸÿ%^]˃žþXMÊ·ÎëÜOÿíÜûÌ£¶ ô%@Lò×ÈÜÆ+îP¹æžl~\ñÃà¥C‰‰?~§xÊ=˜ü¦rÏ:¿a<¸âÇÓÇ%?Æ|~XPÀ¯‹Ò}=´ƒ_7ôõÃööÇj„f þ™Ñ@Þ<ž+"ÍØþfTXš±ª™y/¯fh>Ë òÍ&×0O`=`WÜ`Ð'¯;ç o[NÌ÷Ah8„žmAèUÄÓ¥g+y°çî<(ÿ¼—ÝSTz¾MmÛgÌæ Ç`|o·d×ð‚ñ7žÙ^bŠ—“Œ9Ãàþ¼Ä ÖËæ|æ¥Whpÿ @¼zŃž¯0¨ÿÓãÞ˜¹‡ÓÛ±\÷®'¯ööÓ|ß;q%îû–|^yÞo!{¸r“Ȩ0,ð{àHÎÛ _ú‡ªlh„OUÛUܨªUyêoTÎQÓȨjœ£ŠV•£*sŽªsT…ŽªÒQ•:$E¨Š£ªU¹£ªwT«âQ•Š “yJ˜ÈF¬ß›çêÀéߣ”Uê/ÿs3M›kÚlÓæ›6ã´9§Í:mÞi3O›{Çf7ÿ  à (x@Á .P°‚Œ à+Á fPpƒ‚ü `G(XBÁ ¦Pp…‚-|¡` g(XCÁ æPp‡‚=ü¡`‡(XDÁ# &Qp‰‚M|¢`§(XEÁ+ fQp‹‚]ü¢`Ç(XFÁ3 ¦Qp‚m|£`œ#8çÅÓ¬Ä2\É)–ÿE{)z+5U…}ó@Ieõ0x½J¨½ •Xí³¬ëÎŽL¬ÑXVZðcbm1ôÛ˜_ eUF=cb“AÆËV3±©¿þž4—‰ÍÍÆì×­™Øª‘íV‹Ÿ™Ø†{b‰mùýÛ§Èju‚yˆñàŒØƒ++Å^%´±‰Ã˜ØûYÝݳ·Ú&Ÿ¼£ëé)r&_ìÓBqõè;ÀUš¡ùð½>ÑÚdý`&JçŒÄ\d¢ï [شߙط¼í¦k `ëÀVŸ¯)^¯íÅÄ~rEäÁ€K­eL<¤ph/ WœˆýxÚ‚Ø¿”®J¡€ÕLÍ~Ø ØHWbu)À†¶ðôv€ÜÐOì_N{ç ·©æœ™€eµo³§ÖÕ”+ ×ݘ̹é÷€—ÔoW¤0q ÷v®–µu ¼®«ýf!`¨²KI¸ŽñºÆšæ€I¦¡¦/€Xbà í¥_àþ ¼#«¼¢;à^kÛ¶Õþü½|þ“+ÜâÀ[Öæ!·™8¨œ©JÌx&>¡°ìÅÄ!Þª€Ô¥€ìŠqg Å¡H¶ õ3õ²‰Ãø?Šcšk|ª–l¬ ÎÎ,¥M ¿?¦’:z´÷¬–8æ;M«¯ý±:àX…Õ§ÅzÀ¦zý¡?fí±Úi,WD‹co(>%ÕäÏQ=W›úâÇb‡5Ý×0@ýá“+ ^Šê|Ëõ0®4u´É¾Ó¹!·¨9hhÝú•&FWõiǵ¶ÅËt€ãtövÄB<ã,W×è³Y—ð+Lœp@Ö_ýcbkVkŒ‹‰ÛTm˜8é©Õ÷'Ÿ“ËêoLß™<Ã:%ð€¡™7œÏä8‹yUqU¾š~sT€4ÆDÖ”5Ë?ï§)K—ŸxÕZîXeÀzÊøÞ„ã“W?î´§«‰ú*"ícâøûjÿIÏhJ4ÙxÖP¯Þ8Àªäp~*+ë%@Ðј:ûà<]ßD8þ„߬BûM¸¢c‹É;®'º¯n„ñ1±™êšÖ5שL­aüOü ¾: Æý$\ßLÂBD“ÎÙrÃ8Ÿ”­6OùÎÉ‘É9º¦1Ð?§|µ|üãtjËõ pÓ*š­†uÔ´q¦ÒKaüO»¢Mê]ü:÷ô§K–/wáz¦ÏW§¼óœ~OqnÌÓ ×,»™8ƒoNÄstl œÿŒƒÊÇî^P¶®óÜ Ägø«_.‚þ2ã©åÛW3þP–* óôŒ“Öáên+6A¯í6£¦uøWÓ-†>ÅÇ3º.ƒñ:ýœþýB8îô⽶/ V!ŽUI§P½*„ùnzžêÙá³ð;ÕeUš„1q&/¼!Î,Pß\tŒ‰³FiÍÑ0¾f/34t‚ãÍqg%<ÒP {ÍĹ¼@‹8—+ŒÄ¹¯µÆzp>óxáqÞM&í_ÆÄù^ú¸ØÓ€M,7Û´ì'kº Æé|¦‹Ìoó¯è3ÏÀshW¨Š žèCŽÀxZXRaþí±¨Š½ú¢¸h¼ÚïWXï.:¤lÒðœ6¨ô›%<!.Ãq¨Õjã“aþú‰+ùĵ]5¥Ür˜¸±‹¡ú^˜_¶p¯2qÛ*Ög/¼ÿÛlY©‡V&î(§ýÐÚa'/Ø#î|¯ødlÅÄýHäJyñ¨‡©ü;xî S_è÷çxu]5èW'f+{Šðù³sÕ13á>Ÿ+aOkÏ °ÝïíxÎÇÚ¨ô¯³» eÞi˜x†o‚ÅS©ºFž°.?É ›Åc8nŽu6澃ñr4W3ì”p‹Æç+ÌÛG—ûO^Ó¨š%Ãçp|œÄyýô~õýð|9§W| ÷éj¶l¨7ìnôÑú…yõ eMkC&ÞzaW¶ˆwü_Ãóì^€¡ê.hçDZjÓ%˜WžFÛžô‚ç«ÿ+kKW˜Ö)½oBÿö@Yâ6ì?^Ôߘ˜øv ¬k¸¡—µw0¯‡oѾœã)怬F)è¯ñ<(èH¿§t|JϧtýtLãàÊk1<•UìóàÍtÛÍfÅ z$á ¸î9ÒX×éøA@®dõ­Tß4Þp¿–ªB®Œ„ûWI9àôp¸ÏÓYÇ 0¿¯ûÃÔ[ç» [­”MªÂ8›­ÐÕ̇ó™<ÕPoUŸâyM{ån`sÖáÜ·âùÎP±e1)ÿQõû5˜W*k3Ãódloãù"øÝQ#ôOÎÁ}èË÷M¢ï>uT"<;\UlÐÖIdÃnF3±q5ûã¨7’50&'-wìç¤Û}aäc@ô¤¹ŠØÛ¼€‰tƒÞ·ùþNºƒŠÞ;¨ä¼ÓÅà¥˜È ˆ¥;ƒ…Ù‹‘+Žnû)½Ç­Dƒå;˜6yƒ w0w Çïî·Û:HwÑ‹æ^{áé^2Oç¼iÌ÷5&¯ž9€¹±þ£¾¨äL2Ö±ìŒÌepw@ ú‹¸A¸ƒó¦6Z[ÿâô]^•ÐˆA"ã~[–~×TßV´j! *öqféñ${Fô›yµYGšôÓQ¶¬9€XHàÉ=³^€¿Ñ3î)V›|ŠJà§&mö§t@³Ý8оޕžòB>’]û]”¹¸‰€¹Áºß¯ªÜé™äßVŸ×Žçi¡æ Ü< ¾½À‘€FØÔ£ Ÿ#èGA@ R‚†D¤ ")èHAHGP’‚”´¤ &5)ÈIAO ‚RP”‚¤4¥ *U)ÈêºR–‚²¤¥ -q)¨KA^ úR˜‚ÂØ_(hì"SP™‚Ìt¦ 4¥)HMAk bcP›‚ÜŽ 7Á)(NAr šS‚êØÞtwá)(OAz ÚSŸ‚úäÇ ?‘D I8‘Äù  ö1¸˜Ä3 q\yó´ý ²Z[ÒÀ2¼!)ˆJÖ &&§[0?aFE’.Aܨ\ ♓RÐ%«³ç@4žB’&覺H€ó Âq„Áß ôü B’&è Oƒ2k³ÖÄjÅA¨øâÆçRVÙ BeqP”ÝðÞç6AVæ~®8mÝ"“5„~n/#¡ CPÏ$zËI£ ç¶Â“×±*pÐ&·‹ÏŸ“¤A¼ð¢„¶ A˜®´y].>O´=šl÷d•‚¸Aº„vAƒx&CP{ͼ €d¾ÆÇ…É3f8™1ÌŒ™Of,XcF¥³ÙÀɳž“çf^¸þ¶{!Ãûœ´6ã̧¸HÃ|Å.¾‘Ì7”áÐÿͼ0„d~È3,ÌÏy‹ù%óúÚÏüŠ{$š1CÃŒ¤´ãzxÆ)\÷Ž5cá$ó]î)h¾ÁEæ«êÜ_‹?‡wÌXàÂ|@é´ªøø­ã$ä#, ô3pã:à1Úñ<ÆuýcÌ°zŒ¢ŽÇ˜9ñ3¿á…{âB“xû<)¥Ï¿çùEO°ýŸh¹æ ®“Ÿ$Ú ËIOòùüD¶9d£C¶:d³ó ¬=Ä‚d&]˜<~ˆýÒ„žÉF,øcÄÌ#¯• =ÀL°³•.ç`]ó`*§üÀpƒËC f¸ÜãâWéÞ&×ûÃaÿbT?Àþ¦)·{ºƒÔn#i}ÇIæÖj`I¥—ºø}Ì»ƒ…~îba¬»¸¾¼‹¶Lw¾ZÝãŠ÷Uh tÏûöcþÅ’´ŸûRõî–Tý[Bò¯¤j‡ÍTþ—IÕs'4m ÝŠíÓnŸúË©nzeGÐëTumËDýuKzå0&«Âj~ÿ•‰'†[Îõ `â)n"žÙªl=4Îc¦ö£Ó¾?ÓþÉ€lÈ&€lÈF€lÈf€lȆ€l Ȧ€l ÈÆ€l Èæ€lÈlÈ&lÐFl6 d»@6 dË@6 dÛ@6dë@6dû@6d A6dA6d+A6Û ´¡ [ ²© Û ²± [ ²¹ Û ²Á [ ²É Û ²Ñ [ ²Ù Û ²á [òì#?òô#?òü#@ò$@ò $Aò$Aò$Bò$$Bò,$Cò4$Cò‘úDò#éO"‡(€D( CT€"D $R щHÔ@"‡èD$Š@‘‰&HDA¢ YèÂ!Â@Q‰4H´A"‡¨ƒD$ú ‰BH$B¢‘¨Ä!2!Ñ ‰PH”‚"‡†D,$j!‘ ‰^HC¢Éh†D4ø{$²qˆnH„C¢éh‡D<$ê!‘‰~PD¢ ‡HˆDC$"BQ‰Œ¢#!‘(‰DJ$Zrˆ˜PÔD"'‡è‰DP(Š"‘‰¦HDE¢*Y‘èŠDX$Ê"‘‰¶HÄE¢.y‘è‹D`$ #‘‰ÆHDF¢2™QF(eˆRÆ(eRF)e˜RÆ)e RF*f¨RÆ꟬˜ÑŠ®”ñêÈ€¥ŒXÊ¥ŒYÊ ¥ŒZÊ°¥Œ[ÊÀ¥Œ\ÊÐ¥Œ]Êौ^Êð¥Œ_ʦŒ`ʦŒaÊ vdc†1eS2e$S†2e,S3e4S†3eh‡º‚ƒP¬­úw ÝÁ¼\¡Ÿ†bí°Ðµ\¼Šû…ÐÙÆ‚¦Åv¿ßY²#‹ÝBù~-Å@!¸ŽAqtÈ#&Ë‚ñr—?x<㯢ç*ÿaQÍß Rþ"ªqnÑü_KUþ˪š…Cã‹C/²~û¢yí÷—S=ô²ôìmu^þ›~§/™Ø YRßÖ–›Lì[¤(¯ÀÄþ t G1qO%6³<<(0qPIÅ·¸n€!&Ÿ¨KLü»16b‡Ä«’Nžbâ°ŠêˆqYL.¨¢ö•gâ¾;Gñb6âe2ร‘S]}oµð‹©ÝÔLÛÁÐúA±of Õ‹š €\B&j0j9óîVLœPÓf‘^³q–üzo™8™«9Ä镽z§Ê ²–¯•ÊÄ9­LÊd+ç« Ã¾¦3qAœ©‚¬ñTqù¯¶øW~o{y¹W}S|½}€‰:¥þê­AL\SZÙ€1&®E6t]6íd&®7êaÂÄ ¼X„¸ ‹}l¬w(„‰[T†ú68¯%Ty•Ý™ø{²Æ¦ß˜¸ó‹¡±+|n÷~+;XÄÄ}çuuÁùB„áŽúfÐf&]k­S•‰'nZeW1ñÔb6°Ö &^ëo÷ÅÄËô‰]¿1ñÊSÏ3õ˜xu‹þãë<&^÷1„ÁïÞØd 9ÁÄÛ&Ó ²pžw52Ÿøü=¸ËÞ=˜xŸµ ì¦ËânY >žÄúéá<W¶Vq°¢µDÊ3Àåê/+fÃç*«ï¿»ÍD¿jªsñË™è\ÿÉf`b€·þa|&-V‡^8ÏÄ×w¬ºîgâÛ\cFN&¾?¬¸Û¢'CÖZ¾¥Áù…ͱD¾žÅij՗ÊÃù‡/ÔÔnídÁãD.±–˜õ•‰ÑjÖxú&Æ´5Ô©UÀĦN^v—‰‰ÍæLdâg¥¬ÎÎ;LüRÙÔ&vSÊê†gbj¶¦ú€&¦áýJßbêRu¿¾2Õ=Ò‰ßLúGoàü3°fŒ×_?p¡å¥úEFYVQèÀÄœ.¶¤O#¯Û£2bîË­¶Ðsãì«C1¿¦*í#Œ“‚³úWÝê2±ˆ÷?¹l…µ_Ó×Lî±Ë:d["“{ïcMf˜¼ä&ý³ö§™¼¿>yéQÊ¡ë-L^曵]Ép&/_Övþ° “W0jÛí™o+x‘Éä•V);·Ù`K…ïU¾n­ê•ÍäBœâRÕ&—«4å;Lcòª ÊŽcªnÒu»øŒÉ«dªÂ·ïä»j¹üÕ¼.onís:³ry{J“\þ£µÎ~>_^ç=d*ü½†µ=ùŽ3YÖ±äî?‹¾P* CEb°h ‘q•¡"3Tt†ŠÐPQ*RCEk¨ˆ µ¡"7Tô†ŠàPQ*’CEs¨ˆÕ¡";Tt‡ŠðPQ*ÒCE{¨ˆõ¡"?Ž¢?T‹Q‘ *DE„¨¨¢¢CT„ˆŠ‘Z‘Ô‹¤f$u#©IýHjHbˆ] ¶Øb#ˆ ¶‚Ø b3ˆÝ ¶ƒØbCˆ!¶„ØbSȯ™ü›ÉÏ™üÉï™üŸÉšü¡É/šü£ÉOšü¥Éošü§Éšü©É¯šü«ÉÏšü­Éïšü¯É›ü±É/›ü³ÉO›üµÉo›ü·É›ü¹É¯›ü»ÉÏ›ü½Éï›ü¿ÉœüÁÉ/œüÃÉOœüÅÉoýÇÉÜáOîð+'ÿròá$_NòéDßNòñ$_OòùÌ[¬ìnÚ¯wÐHŸe€¼8‘PPM´d<|¯´µ»a"žrØÕõ€lñÀï^°…–˃÷¿©¯í ‚Ï÷Vö †ãä×Ö]˜7VÖi"`î CÝÁG™ùH›؃ 7ŒIñ™ð«Ï„¯÷LeÕgBú CÙ LøÂU1B2/ê#|Þb­¶u- WÝ Ÿ·Ê†E½äë!¹ªÁ÷¦ `Ž6´®+¥‘*ã&/uŸ--nünWKÌùpÜGJå†&dóç´«V½_wÎs†¬Ï9@®ªò"í»\!ï‰åñÂÍÅícmÑDŸ_+«S!¾ÏŸB&/ (dÖÒéõ~ÿ€>¬–p‹åë¾I€çU1óÖÁûXík]/ªÇJLÈ:­¾\! ~¯ªÅr¼´W cÁ%ø~AŠâÂÓ~pß¹ï§èŒªHOWMIWègÞ|7 zsß4ÑÕÅÞ?†‚q[¢ŠA¾ÆG‰ßô/+ê˜X’wKWP_ì4…‰eyÔ[,Beòš ý´’apwèÿ•+ëÜuª(ªp¶P¬§l–ódµ1Ên¿g^±D®„y¾Z¨êëæ¾€OÔ¦¯×oMéŸ?¯ññ‡ãÉ­ÚpW?b˜þ‰ Öyb}Ê!xž O4•Âñ„§¬ÓºI€1Ö®©Zx¦>nb0|ïëÚ Ö•Uû¯¶„ù·&ÎÏuótú †qk*õ ž#az`}ДïêÅfµé…0Ÿ4çEþÄ–# >;êÃ|ðÞÐFëŒv³ Ußù‘1ôÐv˜w¸ŠXdwX“n°êvÞZm¼ÞcëÖþ’cÝ,%•Pº6†ÝV"úÅ&nÕÉvî-qgs¹š[JÄhW"²s‰ó8«˜¸Œ§¦&nW*þ¦À&b”2 £Z‰\*%ãÅ1ú8TŸ¹º`3™gûÍ€><•6áºÆ%ë2 žOFÍúq69¡%ßU&`êsBiEÑ€šLŠ7æž= ˆE¶â±èI| ÷µM)2Oâu'` ¡ónÑ£“ StN³ÊîTzz¶|ªtkZü7/N)%¢b"²¦‰XL&£…‰-Ek^"Ë“¸H]4ë{ÀÏú³‹Û™WÜN¼Í}‘5OÀYËèߘ˫*€ÈDOenà_F·å¬qT!¯H…Ѽ¨Q&öÔf·¨ X³q‘92§‘Ð^‘o™ÁÐ?"‘eˆÄè“5·³>æE‚¬ÅbZè‡VŒY{ ¯ÌÄþbõæV–ßxT̲Üê¶ ®×‚Ñe*öCÅÅ€¨8 ¢âATL‹ Q±!Gñ!dé¨8‘£X/¢bFT܈ŠQñ#,†DÅ‘Å’¨x¦öSq%G±%*¾Dب8k¢âMTÌ Sù©Ørƒ¢âPT, ‹GQ1)Gq)*6Eŧ¨©bP%ãPÍŠ†T5¤²!Õ E­(ŠEQ-ŠrQÔ £`sDÉ(jFQ4ŠªQ”¢n…£¨Eé(jGþÜä×þÝäçíð÷&¿oòÿ&?pò'¿pò'?qòÇ()ù;üÈÉŸœüÊé|ÈÏüŸ}ÎÉÿœüÐÉüÒÉ?üÔÑ_ýõ_'vôkwø·;üÜÑßýÞÉÿÝáOþðäOÇE?yò—wøÍ“ÿ<ùÑ“?=ùÕ£ï*ù°:|Yѧ•|[ÉÇ•|]?í1æ‡ù᪘Â+Ø N8ÓâóIx_¥×âñ¹‘I GµFøGæ\ë  Ï/½9±ÎäÒÑ xÂ’“ ã Âßä)B±4àíkéÇUL´œÑ9 ÅÅ/ƒL3áycíb´yÁ}´"Ûj}jõªó“ç¡H´–‰DµD$ª-"×pL¤³h‘X¬+2ŸdW#DñõªÕVçÚžóQ#ùs#joÿ(´êˆúMçV žkQÇŒ9§3q=Å-£Ñ'7S3£w( Às3úL6¢x¾Gv'Ç{ ^W ²Ë1¶Vð܈ÁçbÌÎJÅ„¨sn—Œµåê“àùä¡Ê{ßÅù%vȺÅaÿˆÃv«ñ8Ï󸟸ßqÜQæ>žßqÈþÇ!Û_‹i‹ï ôhý2YÐøɶ¢7ÅÏ{d·â·rÖ8þ _7Å_ä)¯ñ¨ò‰GeÇz«Îk9¬‡Fq¶!­sp€¬bBg ±¿%öâý5Sañ9˜ˆížh”¹m†ã'>`NG¡'>Òç4YèoÏŽ“ñyœˆí’ˆìER;Î&õç낤|}’„÷!iÃÚ·V6š=G=qÒäÊF“fÎœ»€^]8gÉ”í[wiÞþÿ¿ÜP—C‡ý?ísù²8lÓÆͤNÑsÜÂq½çC»ý[½ÃuøнŠßÿ¿®ç¤‹7raster/inst/external/countries.rds0000644000176200001440000002133414507510157017106 0ustar liggesusers‹í}ÛsÛXšŸÃ)êb·»ín»w²»˜Úɺ'%ÏÖ&‚$D\h¤,½¤ -¡Mj´W.?ìË>¤*ÏyßJURý‡Tå!µ¯Êß•ä;ñû$AIvÏTeªÆ}Îá¹|÷yŽÞî>zô¨òè7[[*¿¡æožÑ?bìé£GÿêÑ£­G;ÔÞ“¼¸ôFÁxâæCßÊï¢pDäÎ¥æ¥ÿÎÞ£Gÿ(>¬ÝþÓ†çS·åá)-ö¸{áGè>‘¯¨wæ$Ç» yÒè<Œ¢¤[“Gá0éÕ©7 †èïÊ£‰Mh—ùÈ3 .¦Þ ¸†NÏ“väè§OG|Ttå3xU9šžòäéxyÃðb à“?úÑ©üºl7¼Kïʧº‘$Ÿî6¼ÑÅÐ;÷Ç— .:ï<äþЋ¦éîE0½Jè@Ýࣟ€Ú ¸ù`?ºb4kËé$U8 Þìß5‘DþÑ<M$•ò&Át<£—ãÿïá˜H3îøÑGÿ"|Ï”«7ÂÉøƒ‡þãF8}ïO$mœâ~­yƒá¼÷W(˜ãKIÄsȩ̈]?¢á0ºÁ±óYƒ ºFó Ǽãtäb:¼ð˜%ûiôŽ`”ZÞ8úSZrŽ%Šwužc‰èûQ&Ôª)„(¹«x×¾4ð£ó„î{Š7¾Ð;>¤Xñn®¼<¤/’4Iþ1qÛ¿žžƒ³ùç[Ê¥—Щª\C?ÕYŸ*—© U–²_+ÃàúÚ&á(ûÁc%< Ç9XêJ8 ¯NY’•ð*Œ wûJ¾Ë-ÙUB’ Éz+öåöN|éü•ö>$ùÁVQHâã+¡@ñ‚º2¼Ûÿæ… íÍ5K÷å£v™§ŠÔô¯Â³ˆv<ÃGRø£4¹ô%%$CÛôGW^ô.A°ùSpN' —¿i†WÁ¨ˆìõä“d#õlJ*%ÄW/n®' ¯Õ!)Äð}êó¯ÕŸ§Ik@ŒmOƒ‘ÏûØF©î˜XÃR¦N.ƒðý§-oøN;GõÇ-/ ýÜàV+ø)Al»ŒÒ ÖŠ¼Ñ™Õ‘?"š`¬˜O烽px3òÇá·óq‡ÈvéG¬ˆŸ\m{§¬m/-Am?$õLu#R,¼dvÚÁ)éYiìù>€Þ½4NÛ4VÁ6ñdžÓëdÅ\a5±Ã¿òØ?´§„ÌØO@yséu#½) H³Žz7 nµã£ßu|/J˜4³„ÆY“ìç0ϸz'“¸'ýê_H]ú'Áª3‘©JÀÚÖÎüÎÕ™ILÖR'L³jK‹`ÍEûgl¥7Ù#|¡,f×´qäùCœ2ñ†€à\ëAõлæe‡~Ä$¬†Ñ9>Ûíz½w—©p ÚõG7 —â‚S¬uÃqø& ;ý@äÅV7ÑÅÍÇÔV[º«TÓ½ »­mݧ@ÒHÝq8¹„9ЃÓT\Q¥. z¬dh&þh<ñá1wô`r9ME&»úô|ò Ó(áXÕðÎ`»v¨ãŸ§4z× ½ðÆg,ÖIáøÑ»aŠþyðºµEý€O"õHôÕð¢ñ¥7æ 2Säü<õydJ›Bb' 8„0¼›p2ñ¢ÿÁYˆõÁY”´m#ž‡ï¡‰:¦× a‡) „#¢ª…é‘1™oÂFáYêÄð£°"ŒÃ¶Aªwn›ÞUÀV¦j>Stük/å=ÓV+c;Mÿƒ¤xà ›öÄà‰ï¥ÔdÇ$©<Š±q@A) Òê–Ö'fýßeîN.IÕÙø565ãñ^bØ1 …)¹Ø†>ÿà%Z·e]A-ê=ï]:¯ö¡„.;ÔñÇ© ¶Ö£½¯ O=ïš‚aA‡ŒÕûªGD #”7d½˜6£çƒ{= S(ì ]ÆØ=˜œQ8¹§‘»aÕ{„ùô‚¹×›ŠÐED‰hTßxì!¾N»þŒÛ·ýé(`+`‡W)ñ¯ÙÓñ8Õ£ðô< F¾žE»¯)âž\Þþ2ô¯÷ãbíÊŒQÔ;ôAÕoã±n0™Ä¡²é¿t÷âõéŽÿ>ê¤~ì:„Üü<þäÀé¿b†ˆrbï—"q5í:^,>£á %7¼ŠÏèÑ'g\%!2=$9òR®ÛJ ^ÔÊbX©ÿæìÒqü¾#0ð$Ý'S‘ˆœ3»#>G bxDDBë É”¼c (ú©dë+G¥a^r¶â)[™ýY|2¢çcñØ<åâQ"Ðù‡€›ì¶{ñ§i59SvnU皶¯œk²dÛÜN;%¾º7zû‘Þ¡î&õK(óóÞ£8Š£‡Ã÷n@£çƒHRóÁ?ÇÇ{·`ò16s8솭SÍõ‚ì™]ï§ c'ê®7ú˜Rº{é¥OÛU½ñDrƒ+Ä·[nÈÊ憔ØÃÎT]RD$Ù.aœ{1Znx꥖‘Š¦ÔÐ¥œ ±Ä¾è‰”;åK1ë”BÉBöB; »õ/fj=?¬ÿN¤Ø µŸ÷GÁÄ?Ÿ ¼¤^Ä?ò“ùg]’Ýó0 ?u&b*éè(Œ$kJl§iùè<3DÓ”½Üí<õ3LØx# Rø÷"¹!9P‚I²hg@*ù‘ŒÐþd„(÷y6>útþ˜ØÊ#Š‚˜|­éd ƒõ䈼‚ð6Žwé¡šR=ö¯ _µ“tL_? ®N½Óþ£lè7r«4ßÊMŒê27I³y£Ž¦ÉËÚšÏuSMœ&Û©&oÖ8B³ïpÓEóDMšŽÃMÍ6Àiؽ¡óUçÑ5Ñ4úhº¨Þ;FSvÑlË CÛঊ#š*°hwx_çÚ 7un‚fm½Çà€Pm—›L¶Éû2Bí>&t\`Ü1pD‡-A§ íîô±ƒæ2çjMž`§šo¸ÉËŒÔfO-Ì¡ „{˜{¨ôC ˺2Ô¿ËêßÕXì»`@÷òÐmc™.c‚> z›éOhØÜ8º×]ðXï¿Mš† Æ]ÐÌh‚¾Æxa;<nèbÐå&oÆáŒÃþâ$…[tè2r¦:8í-7õ.#ÏöÌéó‡ ÙÑ 7Ù¿u¡c,s°™{„\ŽÄ\v®Ð]ŽÄÜ.¤Äµx3—'°v^· x]f¬Û‡Yé³õ»X&ÛÀ¢Í¯o@&û/cY-ö,¿–‡ÉÂŶúH UûXe³c=!ªgãà Åêÿ—þ‡‘·h%¬4O0æ ÕDËBKCë Zm´l´ ´ŽÐê£å¢…s8·ÑA 4h£¥¢Å»¢8­Áx˜“ѤZÀHÃÚðmð.<ÖB ´ê#PAô*Ê Ï¡.pT°› ZÀT`1+ÊÛüŠ‚ ïòé]´€¡x;<ž) ŽÂÐî¹+MìÜ/š€  TÀ§‚vèÞ†tÁWTTð[GáØ*-œÑ¹-`ÔÂ.mP´Ç´E ª_iÒ6Îm¢ÕGÛ8£Íg€CÈÙ*0å•6hÚmР :·Á]°•V cªÀgU: FghÐ+¼ Pi,ß 8·Š†34`¤ØýÊ!p;ÄÚC–:HIŸvAµ·€¹ ÌcW®W×Tàè*p dÁ´BtXApXÑAð€ÀÀ¹`1°Ÿ PÃÀÎ$Â% TyWŽyìp ”DÎQ1 ˆÂ*ègs$„t6°‚˜Š XëULàP°bbôCŒ[AhW1‘ íéöòVÈà³@oD'•(ß½{À¬Ø{íü¾=p¥Øzàò£ êJtïoØ/¸ù òà "ôŠÍ>‚eøÃ=Wº€@e:V;¶!+HÐ+ˆ(*ö³yvAöYqØ–BºPÙGèò¸Ê Û>œø§â`LuòÜÐùȯÃ+aȇŠš9à© *»Xëb-ªx£üVq ÁŠ Š¢ìUq*u¡ë}ìÜ}dö #JäÔ*}@?€,!¯® °âùʼ:‚|©Àü+NpîÉÑ£ü¯àZíŽljŽKáN²ùïbnÿI—ͦ¤9â? ÀÛ²Þ ù2wÛªîÙ ž"›’#O2›–’PM6Û¬vz}MGW6]ÙV\ ÑÏ3ÑÚ}YÐ4d»ÑGƽ#Ûm•>5ù(ÛP¼ªl÷<¹ï¸¶¬§€Ÿ|¢Ú Y;Dä·Ý;²pWtm>r—ÑÖå&‡ÜuÜ´xªËœ\Šn[ƒÔ¨«¡ÆWmÜ|°jŒf­Ñé»)¨,]ìß5,SÖlõ€h®™®¤R²«õ½ø×°"Íl¸£Ú'jÛ0åê ËuŽdô7¬þ@uçì ¶|GÿW [s5§#ifS#ž[ŠJÿºªMÃò›”¨´53‘£i¾jþñ× »oªšÔ„rdiA½Ñ×Û2³g¿Ñ·»¯Ô’a¶i¬o¢H\Wd£a5±DôUÛBæW#É”AÕ]Eî©Ò@µ›jÎZ=QäcC6s¢ÿR!Q#ù‘äV,ã¶Úë7tY¶”Žœªªt4$颺>U:6©IUBÚìÙ/K±釮JÒa¶ÿ¢®Xºe4X†Ë°lHܾbYÝÜ’]ÚÏ•%›5ê±b¹ªÔ|¥ , Îl[±-’Ø°æl+}[VâÕ”ãKõåDU:ybüÅ"-?ܤ–bÓÞ fIVK|”ìßTMCFÙ©Þ<ÔHúPgý¦išYDòzòI²‘ªôIÿ»]UÛÇpê{ªNÚ RŸ­¾éË$ª1•Œ©ò>$£vªë¸[•ºêv4«‡þo[²ÞMÛJéƒ"ž;H(Þ’mKÍ1f«¥¡z¾ÝÒÌ´¢µlÙTT¬¶U“hL0²‚>ö,ýØT4ñ¸C$5g…ÔðÕMµ-7X)ÚrZžÚªEêšêÚ¤ ÇXØavÚ™ÝEJ_kÛª  wD/Ó6 ¤ÕLzSÕ­>³-1°š8£üe\½Ý'd³Ç {ÝÐ.Õ2\¤Þ1ƒ[íÈDêwU¶~Í,¢¡4ÉŽêyWïXf“¤?éïP¿-u-D¹Û¾If*k[SÔÎÕ™iLÖRÇJ³ê{¸|0;ÑÈ*GBšð;Ûé÷h•*ÔÈ€c¨iŽ-㾪æÊÈt¶ɱžTe®ÆÖU›éZ;´ì&>ÛíÊ'r·ã°÷©vUóLéj¶Ö ÍαZ·$# ÜíÛíã“Ô&’.[ROµzºúÊ)²É>ºì²§ÛÖUr¹\ê:–Û/еF*ùŽºÄ}I¶å†$°ï¨ü±®‘ÑrUÓqUxÝ]s;ýTt³«÷ߪäQúø¾¶j¤ìà¿¥ŽÚ†!¶s-‹‚[:î·-âè €Ÿ»É[vÖ!âø£.zÇ, ¢ßÔPÜ-êk ŠŽï~ž’ùt:²®çm?Sx¤½é«<Ò'sÂr'Ñ8N1äcËuU€¨¾ÕP!úk’T;–â©¥6UbœJqŪØ>7,½i hÎ"ji6¬ÂSpT¶K}bŒÚFr5qÈŠ¡(¸-|ž¢¤&œ#ÆXnÄ{þŠeÛ$c#W5 ã>:jUÎ=SF3MÂǦz$)²sšçI'ªœRÈá‡l¹ÝçS´¶Êhé@yËÔëÓ²[–Þ͆Z۵Ȥ• “&iVñ^Ò^±Õ7DèDÑRVjôù‘œèú–ÅÆ£Þ“»ZZω(°«Mò$Héï€">¥ßÓTx-2*2ª O{r¢vA©¹YÎÂJ'ÎÈhz*˜²×£øIëõh,qOs™¿%­‘ãcrÕ{„x¿ÍŒì‘»p-õ$RR}#³¯ªÎâ“„9¶Ú756,¶  xõLâsiç‰5¢¥ ‡ö4Ž¿) è*ªBûñx¬‰Ù11êÛx¬«¹n»›ê¥¹½øC½¯°÷ˆ‡ˆþ¶­Æ>Lh€ðæ ""rÍf*vÃ)ÊVÓÉÚ®#ǃj ÁeI®eÄgôèEƒÏ&DúMmfeÙN;B}ÁŠ©.¸K®F!¼u¿ï dIW-T‘vŠ}eâ)ŸÓˆˆoCêŽN¦ËÖRôSÙßWŽˆ•­|¿íXF* ÜŸJó ~>vÍc!P.%54Š°²Û~3WØE{·7_×g¿Zuz"‘Ì*ÄŽckäM|VM/©;d¥I½Š|ç D.nÇáËáŒkÇ Íår”©¥"JçˆÄ×HGš{ºÄb;ÇÂbÄ3燿weíH„*=Ûš‰“<ÒYÍ®+jûñ¯©y"Ï|#é–p‹„©»“¥cW#ÃþZ˜Ä„®ÅjêZ]•R•brãŸQ"ojM9¦†k5äÔ2€}jÍ¥<áξ艒A ô—b,VA28"ËQ·O¤GÌIV‡Àv¿+J øÏç¸Ïˆªšp–HœæŸQRÛæßïü~>:w¨”ÞX¶Dò£Ó´ 3sÝOYÕÝþICÍpf{ ›\'ðÿe‡ÉQUé‡p3$ŠæÇ›&ùËé•zBƺ6ÐTWâß(<Ïgù™ŸòQ`¢Åmõ‰( NÛ¢ZÔ‘Qª«µv’ÎNê'šÑ _af.s¢Œ•Q®¼±Y|À—ºŸù‚ïg¤ï’%³ÿ´/kfiVö.f.»˜_¿Ìïµê‚å×ñK©)p{Cüõ‹ÞµÌ—™>Ç˼tæ‚®/}e2˹W%¿›]Œ87&‹ÄûÏõ‚d–…"÷Å…Èüµ¸™=ú¾·s_zÌÛ;ÞuÌéŽws+Œ9ïqsñ¹¸¹x0cÕU|£—%ô3ßdÌ‘ÿnwóÕš/r{ñ»ÙíÅQ|‰AàvIàÜã:c.óÅMÆ÷Ò—ZW‘t<½ìëdåŸÿÅÆ—|±ñ Åw; yÏç׳aANpÛ1;þ€wsææ×»Þ˜ûbevG*ö+=?¼ú¯Æ‚P¹iÏ n3&ܸÛEÆÉEFÿ@²ÎΦ×ñÎ’èxݵÆ|Ѥä=ÆœŠßëÞâ7s—œ«Y$P·oYqsñ›øæâH"qõÅëìx’[Œ…QÊC\T|‘¹¨ø·ùkŠ/3×ÿîK_Oü6¾ž_ \¸p¼émÅœŒ|†ŠÙ¾™ëÒb|¶üòa¾ÖQî¶a~Õ¦÷ ŸÏîÎBÂœí[¸`ø"¹`Hyl|7.ãâó÷ ÷fW _ëâbZ¢—³ ‡9Sø¹n>+¸iÈ‹?Ç%ÃœïÍ^6¤gžNã ²w sûâþàÁ,ô¢ÄuBÉD$ùuß)Îþž/\&d =Ø}Ây¿ۋR;ÎåÏdAÒï0 )Júè½ 3ü«?+Uïx7^ÚÍ-©[ÄøíÝþgAØÈÎ.qüGQm¸9[ö¶”@zV±¸)_±xÞ¸‰KŸD#ŒÒ—å_ÌÊdø?ÍÉÀØ/üöÔ3Qïð¤@;ÎîøðÔøAžzi’S"Çò€å‘®wu=%ÿUº>rÞí-ªïçø+ÅU“™³b“VuÏ–KvN.ÅK6íi‚ÄÆ/R½ˆ_¤ú¡ë“ .þPêm*ÿ! -õNôÞ›Œá:W=Nõ¤œ^R÷æZ”yæ¯FüïÿäßÝþ³Å|—,ÿâ9´yûËüÑ*Ñ;ŸÆOV|:ñR5Ÿ¦W\Ž‰·û–tû/Âåz*3‹Õ™-#'í¢‚LKbQ\—I(Ûñ(ð%5šÀ(>QE. H£ H ÝÑ&7áõ+ÎAŸ~Œ)Ð ÅLˆUoÝþ¯(¼A4œ~·ê;gJH|ÿú¤zÞØ{ŸJ ³Õš¸Vá'¤™Õgn”¬Ò4âY0N><JLžtnR©E– 1ÝÄŒqjIá«V»"ÎÔv(&}÷Š2ÒWïÉF&dmúÓÉøì2]÷XùÄÕWêP(Œ$Ñ€ ?í’Å–œ1ùVN!èÉ«˜(³rÐí/Eå ,‰s堹韼Šßº’âÇ® Ok¹Ú7¼ â?zÉØSý†‚êáyæM´ˆ"&±µo^ÅÈUoÿ#kUA¨~LÚà½B¥¨&*El\²¥¢šI&‹ÍmæÕ«:yØ~t>E‰å Å?/+=MJFŸâÂÊÙóWìú‡’¨!Ý$h?‹kH­çöeœœÿÝãú¨%ý¨õééÈ+WK]ÒÛ$$(,Ñ2ßréè“îSšpJâ…G±äý]Ã{7+G´M‹GOš—Á{ÿ2lÏûé'HûýKH{Ƽ‚ĸ/¯!Å’%·¿ˆ"Ò'•˜LQ“ÈhÄf¥%oòa=›µ’¤þj£D´ÃÈKMÉÖ”DxGºDžö”çœeËJÏâ²…õäUG³|åCPÙg´vLQo˜ieL„g¦ˆ¦(¡~­xÃÛ_sáMåpB¦ñô¿£US.IUòéïº7³ªôùÊüŽ•‘7‘ú+JNÔ›6õ¥§¢ä4G{VcºýçÒy‘)˜Jm¯Ä¸¯{9kn©z~tû/ ±z¢â4s–É&Ù‡³*·ã€¥Dýi¿é}Æq*>ùy:8I‘ùg¿M QŸ42ç¾4¤@jemŠº”(ÀÒýÊÏjÅå¨×ójyû‡~U+Æë¥sû_fu«Û_æ…«Ûÿž®\½ •­È¾Häééô~ôa¨·ÅaÌåºûÊ ^ó\ϧW—4# Á‰ eËüK\û=Âö’ÄWTÈi_¬Ž}/ªcŸRÙ›èg𢻽ÑUUΰ‡HUo güDW]TÏn8ÿRíJÄ~’—V"òxÓÉÄ»$ˆ?Ùõ7%žìJ^óS£‚ïxïõK#ìšÿ†¹ÌŽ~/ê%÷}£ýþ5¯/ôLûã—Å«ôóìå{óðú‹Aá÷ÍW—\!*÷+ª";¾P*>õ~Ï°/ªL®•Ñ¿/ðÔúÒÞíµõ%›ÝÿÕuPöÏéÕõŒ%ýÕ_]Ïj@‰&% æI즄õüâúõ¹^]_(²ä¹ï¯‘ŠÖç5¿à¹õ¿È=·.ýÐ (L'ºàVq‘å*ÿ+¥bÃÇϮ֎Êÿ@©L¹h‰Xùk¥B°Ë½³žåk©gÖ×{µb6-e÷üBåž/õŽzATöùžQ/æǺ‡Ò «7¿O4Nú’{ ÍLù4ËWd6z?=«¥¿ò{éK¿´Ô~}¶Ÿ2-1Ÿó©ôB{ò o¢oÏk$ —×<‡^lγ¶æ¡~¬ôIföì'»§Æø~¨Ó(„åø ë³Ã˜QÉü_iZ²ü±œŸýÜb…LÚé©Ïtœ}>Y1ãñÜ,d~…V„ÝÂÊïá˜çF;/ùà@ðR{M*äÃÂÊ'â,Z ÊWHö3Øcr†¶O™_™Ù…`RuÖe’Á;f˜›çeá!å¨ôÍlÖë„V©©kè—uXŸ]¾w¡Ì.£kþÈÜÏ[ä¸hïâÁB‰/w9"KgæEg“oÑl"¥KDjÑ0”ѸbY($êÛ·ŵÐÒk‰Å\BŸB0‹áÙø5 eÉnˆ’¿ÖE›§b#²ì²Z1¾…BRÈëB6²%ÃË|½,&Ëët¡ŒÑ*-g°LðxŠ¬I±2-ˆB+¾Î¼Ü=D)ï©ËÚ—B ”>ed- _†o"R aÙcVýbÚ­¦R Ñ[bÖ–„,1°‹bòSwc_$‡ÙE~.FxÄ"Kì}±Ö.ž½I0¹±Á%"°!ù—ˆÝ"^«ù´Ú…­ û7ŠWŠGb µ‡Q¿H3 ìEyµ.$Û⎅¡˜( ÔÝ0„,\¾Ç]—8¥²F¾ˆFåî%ÚµztÃ@r‰|­]W>h¹O¾¾2+c.—¶p‹bQ.‰^&y^btKfµEš\œrƒ³¡wZbz7‰ò—`vïX«Ð¦•ŽŒ–ÓaEò_Î/”theƒ°õZ¶‰E)g“©ÕÅž|´_„ÁBæ·Ä,lhÀ×›Ÿò”/2e‹¡[©õév-ƒU®—Ù{v÷nÙÂÌÔúœ,øÂ-o+òòý4„ùÏV±já2äç­"ÉÂÜ•x¯:eÍ©«mí&­àvæl/³j%’5È[æ;Ò•„*O¶²˜­>/'3k€[Éñ;“w}Y++¥r_(²sW«ÿJ’aiîÁŽ²âWžªqnaÙDA7cçFê¼ ÃeŠrc¿|^yè–ž[Þ‘lŽÆòƒ6P„;¦¬¯€p•Šm¤×+pÝ-/wó9P–—›xÚ¬Þi£î$¥+ö^ÓMB…Ò`n ÇwU• ßý¼ÞfR]Rï¦Ñ›„Œy0W±àÊÂ]ÎÚläÑîévîb ï£òecÆÕÜXk W¹wVÔûä?eý×O Ç?Íïžë)œV˜o§!.œPÚˆž¹Œ8…“WQ¬xÁzڬůpp ¨½–°ë {ˆ¤²…Ös`ÅÉk±Üãb²¯R‹2¯™µXÜ5->­4órÈÖKø!P)#Q:Ì~ˆ$uʯ•ÊfiS¹ÉþÓÊb7ñÿ§²™ÊnnÖ[”Ij7ì³g¶Ct·ôvsÉßÈ[®€¢| sÇ 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting} \item{useRaster}{If \code{TRUE}, the rasterImage function is used for plotting. Otherwise the image function is used. This can be useful if rasterImage does not work well on your system (see note)} \item{main}{character. Main plot title} \item{...}{Any argument that can be passed to \code{\link[graphics]{image}} (graphics package)} \item{y}{If \code{x} is a RasterStack or RasterBrick: integer, character (layer name(s)), or missing to select which layer(s) to plot} } \seealso{\code{\link[raster]{plot}}, \code{\link[graphics]{image}}, \code{\link[raster]{contour}}} \note{ raster uses \code{\link[graphics]{rasterImage}} from the graphics package. For unknown reasons this does not work on Windows Server and on a few versions of Windows XP. On that system you may need to use argument \code{useRaster=FALSE} to get a plot. } \examples{ r <- raster(system.file("external/test.grd", package="raster")) image(r) } \keyword{methods} \keyword{spatial} raster/man/focal.Rd0000644000176200001440000001172114507510157013707 0ustar liggesusers\name{focal} \alias{focal} \alias{focal,RasterLayer-method} \title{Focal values} \description{ Calculate focal ("moving window") values for the neighborhood of focal cells using a matrix of weights, perhaps in combination with a function. } \usage{ \S4method{focal}{RasterLayer}(x, w, fun, filename='', na.rm=FALSE, pad=FALSE, padValue=NA, NAonly=FALSE, ...) } \arguments{ \item{x}{RasterLayer} \item{w}{matrix of weights (the moving window), e.g. a 3 by 3 matrix with values 1; see Details. The matrix does not need to be square, but the sides must be odd numbers. If you need even sides, you can add a column or row with weights of zero or \code{NA}} \item{fun}{function (optional). The function fun should take multiple numbers, and return a single number. For example mean, modal, min or max. It should also accept a \code{na.rm} argument (or ignore it, e.g. as one of the 'dots' arguments. For example, \code{length} will fail, but \code{function(x, ...){na.omit(length(x))}} works. } \item{filename}{character. Filename for a new raster (optional)} \item{na.rm}{logical. If \code{TRUE}, \code{NA} will be removed from focal computations. The result will only be \code{NA} if all focal cells are \code{NA}. Except for some special cases (weights of 1, functions like min, max, mean), using \code{na.rm=TRUE} may not be a good idea in this function because it can unbalance the effect of the weights} \item{pad}{logical. If \code{TRUE}, additional 'virtual' rows and columns are padded to \code{x} such that there are no edge effects. This can be useful when a function needs to have access to the central cell of the filter} \item{padValue}{numeric. The value of the cells of the padded rows and columns} \item{NAonly}{logical. If \code{TRUE}, only cell values that are \code{NA} are replaced with the computed focal values} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \details{ \code{focal} uses a matrix of weights for the neighborhood of the focal cells. The default function is \code{sum}. It is computationally much more efficient to adjust the weights-matrix than to use another function through the \code{fun} argument. Thus while the following two statements are equivalent (if there are no \code{NA} values), the first one is faster than the second one: \code{a <- focal(x, w=matrix(1/9, nc=3, nr=3))} \code{b <- focal(x, w=matrix(1,3,3), fun=mean)} There is, however, a difference if \code{NA} values are considered. One can use the \code{na.rm=TRUE} option which may make sense when using a function like \code{mean}. However, the results would be wrong when using a weights matrix. Laplacian filter: \code{filter=matrix(c(0,1,0,1,-4,1,0,1,0), nrow=3)} Sobel filters: \code{fx=matrix(c(-1,-2,-1,0,0,0,1,2,1) / 4, nrow=3)} and \code{fy=matrix(c(1,0,-1,2,0,-2,1,0,-1)/4, nrow=3)} see the \code{\link{focalWeight}} function to create distance based circular, rectangular, or Gaussian filters. Note that there is a difference between 0 and NA in the weights matrix. A zero weight cell is included in the computation, whereas a NA weight cell is excluded. This does not matter for "sum", nor for "mean" (zeros are removed), but it affects many other functions such as "var" as you could be adding a lot of zeros that should not be there. } \value{ RasterLayer } \seealso{ \code{\link{focalWeight}} } \examples{ r <- raster(ncols=36, nrows=18, xmn=0) values(r) <- runif(ncell(r)) # 3x3 mean filter r3 <- focal(r, w=matrix(1/9,nrow=3,ncol=3)) # 5x5 mean filter r5 <- focal(r, w=matrix(1/25,nrow=5,ncol=5)) # Gaussian filter gf <- focalWeight(r, 2, "Gauss") rg <- focal(r, w=gf) # The max value for the lower-rigth corner of a 3x3 matrix around a focal cell f = matrix(c(0,0,0,0,1,1,0,1,1), nrow=3) f rm <- focal(r, w=f, fun=max) # global lon/lat data: no 'edge effect' for the columns xmin(r) <- -180 r3g <- focal(r, w=matrix(1/9,nrow=3,ncol=3)) \dontrun{ ## focal can be used to create a cellular automaton # Conway's Game of Life w <- matrix(c(1,1,1,1,0,1,1,1,1), nr=3,nc=3) gameOfLife <- function(x) { f <- focal(x, w=w, pad=TRUE, padValue=0) # cells with less than two or more than three live neighbours die x[f<2 | f>3] <- 0 # cells with three live neighbours become alive x[f==3] <- 1 x } # simulation function sim <- function(x, fun, n=100, pause=0.25) { for (i in 1:n) { x <- fun(x) plot(x, legend=FALSE, asp=NA, main=i) dev.flush() Sys.sleep(pause) } invisible(x) } # Gosper glider gun m <- matrix(0, nc=48, nr=34) m[c(40, 41, 74, 75, 380, 381, 382, 413, 417, 446, 452, 480, 486, 517, 549, 553, 584, 585, 586, 619, 718, 719, 720, 752, 753, 754, 785, 789, 852, 853, 857, 858, 1194, 1195, 1228, 1229)] <- 1 init <- raster(m) # run the model sim(init, gameOfLife, n=150, pause=0.05) ## Implementation of Sobel edge-detection filter ## for RasterLayer r sobel <- function(r) { fy <- matrix(c(1,0,-1,2,0,-2,1,0,-1), nrow=3) fx <- matrix(c(-1,-2,-1,0,0,0,1,2,1) , nrow=3) rx <- focal(r, fx) ry <- focal(r, fy) sqrt(rx^2 + ry^2) } } } \keyword{spatial} raster/man/dataType.Rd0000644000176200001440000000512414507510157014376 0ustar liggesusers\name{dataType} \alias{dataType} \alias{dataType<-} \title{Data type } \description{ Get the datatype of a RasterLayer object. The datatype determines the interpretation of values written to disk. Changing the datatype of a Raster* object does not directly affect the way they are stored in memory. For native file formats (.grd/.gri files) it does affect how values are read from file. This is not the case for file formats that are read via GDAL (such as .tif and .img files) or netcdf. If you change the datatype of a RasterLayer and then read values from a native format file these may be completely wrong, so only do this for debugging or when the information in the header file was wrong. To set the datatype of a new file, you can give a 'datatype' argument to the functions that write values to disk (e.g. \code{\link{writeRaster}}). } \usage{ dataType(x) dataType(x) <- value } \arguments{ \item{x}{ A \code{RasterLayer} object } \item{value}{ A data type (see below) } } \details{ Setting the data type is useful if you want to write values to disk. In other cases use functions such as round() Datatypes are described by 5 characters. The first three indicate whether the values are integers, decimal number or logical values. The fourth character indicates the number of bytes used to save the values on disk, and the last character indicates whether the numbers are signed (i.e. can be negative and positive values) or not (only zero and positive values allowed) The following datatypes are available: \tabular{lll}{ \bold{Datatype definition} \tab \bold{minimum possible value} \tab \bold{maximum possible value} \cr \code{LOG1S} \tab FALSE (0)\tab TRUE (1) \cr \code{INT1S} \tab -127 \tab 127 \cr \code{INT1U} \tab 0 \tab 255 \cr \code{INT2S} \tab -32,767\tab 32,767 \cr \code{INT2U} \tab 0 \tab 65,534 \cr \code{INT4S} \tab -2,147,483,647 \tab 2,147,483,647 \cr \code{INT4U} \tab 0 \tab 4,294,967,296 \cr \code{FLT4S} \tab -3.4e+38 \tab 3.4e+38 \cr \code{FLT8S} \tab -1.7e+308 \tab 1.7e+308 \cr } For all integer types, except the single byte types, the lowest (signed) or highest (unsigned) value is used to store \code{NA}. Single byte files do not have \code{NA} values. Logical values are stored as signed single byte integers, they do have an \code{NA} value (-127) \code{INT4U} is available but they are best avoided as R does not support 32-bit unsigned integers. } \value{ Raster* object } \examples{ r <- raster(system.file("external/test.grd", package="raster")) dataType(r) \dontrun{ s <- writeRaster(r, 'new.grd', datatype='INT2U', overwrite=TRUE) dataType(s) } } \keyword{ spatial } raster/man/cluster.Rd0000644000176200001440000001137614507510157014312 0ustar liggesusers\name{cluster} \alias{beginCluster} \alias{endCluster} \alias{clusterR} \title{Use a multi-core cluster} \description{ \code{beginCluster} creates, and \code{endCluster} deletes a 'snow' cluster object. This object can be used for multi-core computing with those 'raster' functions that support it. \code{beginCluster} determines the number of nodes (cores) that are available and uses all of them (unless the argument \code{n} is used). NOTE: beginCluster may fail when the package 'nws' is installed. You can fix that by removing the 'nws' package, or by setting the cluster type manually, e.g. \code{beginCluster(type="SOCK")} endCluster closes the cluster and removes the object. The use of the cluster is automatic in these functions: \code{\link{projectRaster}}, \code{\link{resample}} and in \code{\link{extract}} when using polygons. \code{clusterR} is a flexible interface for using cluster with other functions. This function only works with functions that have a Raster* object as first argument and that operate on a cell by cell basis (i.e., there is no effect of neigboring cells) and return an object with the same number of cells as the input raster object. The first argument of the function called must be a Raster* object. There can only be one Raster* object argument. For example, it works with \code{\link{calc}} and it also works with \code{\link{overlay}} as long as you provide a single RasterStack or RasterBrick as the first argument. This function is particularly useful to speed up computations in functions like predict, interpolate, and perhaps calc. Among other functions, it does _not_ work with merge, crop, mosaic, (dis)aggregate, resample, projectRaster, focal, distance, buffer, direction. But note that projectRaster has a build-in capacity for clustering that is automatically used if beginCluster() has been called. } \usage{ beginCluster(n, type='SOCK', nice, exclude) endCluster() clusterR(x, fun, args=NULL, export=NULL, filename='', cl=NULL, m=2, ...) } \arguments{ \item{n}{Integer. The number of nodes to be used (optional)} \item{type}{Character. The cluster type to be used} \item{nice}{Integer. To set the prioirty for the workers, between -20 and 20 (UNIX like platforms only)} \item{exclude}{Character. Packages to exclude from loading on the nodes (because they may fail there) but are required/loaded on the master } \item{x}{Raster* object} \item{fun}{function that takes \code{x} as its first argument} \item{args}{list with the arguments for the function (excluding \code{x}, which should always be the first argument} \item{export}{character. Vector of variable names to export to the cluster nodes such that the are visible to fun (e.g. a parameter that is not passed as an argument)} \item{filename}{character. Output filename (optional)} \item{cl}{cluster object (do not use it if beginCluster() has been called} \item{m}{tuning parameter to determine how many blocks should be used. The number is rounded and multiplied with the number of nodes.} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \note{ If you want to write your own cluster-enabled functions see \code{\link{getCluster}, \link{returnCluster}}, and the vignette about writing functions. } \value{ beginCluster and endCluster: None. The side effect is to create or delete a cluster object. clusterR: as for the function called with argument \code{fun} } \examples{ \dontrun{ # set up the cluster object for parallel computing beginCluster() r <- raster() values(r) <- 1:ncell(r) x <- clusterR(r, sqrt, verbose=T) f1 <- function(x) calc(x, sqrt) y <- clusterR(r, f1) s <- stack(r, r*2, r*3) f2 <- function(d,e,f) (d + e) / (f * param) param <- 122 ov <- clusterR(s, overlay, args=list(fun=f2), export='param') pts <- matrix(c(0,0, 45,45), ncol=2, byrow=T) d <- clusterR(r, distanceFromPoints, args=list(xy=pts)) values(r) <- runif(ncell(r)) m <- c(0, 0.25, 1, 0.25, 0.5, 2, 0.5, 1, 3) m <- matrix(m, ncol=3, byrow=TRUE) rc1 <- clusterR(r, reclassify, args=list(rcl=m, right=FALSE), filename=rasterTmpFile(), datatype='INT2S', overwrite=TRUE) # equivalent to: rc2 <- reclassify(r, rcl=m, right=FALSE, filename=rasterTmpFile(), datatype='INT2S', overwrite=TRUE) # example with the calc function a <- 10 f3 <- function(x) sum(x)+a z1 <- clusterR(s, calc, args=list(fun=f3), export='a') # for some raster functions that use another function as an argument # you can write your own parallel function instead of using clusterR # get cluster object created with beginCluster cl <- getCluster() library(parallel) clusterExport(cl, "a") z2 <- calc(s, fun=function(x){ parApply(cl, x, 1, f3)} ) # set flag that cluster is available again returnCluster() # # done with cluster object endCluster() } } \author{Matteo Mattiuzzi and Robert J. Hijmans} \keyword{ spatial } raster/man/approxNA.Rd0000644000176200001440000000613714507510157014360 0ustar liggesusers\name{approxNA} \docType{methods} \alias{approxNA} \alias{approxNA,RasterStackBrick-method} \title{Estimate values for cell values that are \code{NA} by interpolating between layers} \description{ approxNA uses the \code{stats} function \code{\link{approx}} to estimate values for cells that are \code{NA} by interpolation across layers. Layers are considered equidistant, unless an argument 'z' is used, or \code{\link{getZ}} returns values, in which case these values are used to determine distance between layers. For estimation based on neighbouring cells see \code{\link{focal}} } \usage{ \S4method{approxNA}{RasterStackBrick}(x, filename="", method="linear", yleft, yright, rule=1, f=0, ties=mean, z=NULL, NArule=1, ...) } \arguments{ \item{x}{RasterStack or RasterBrick object} \item{filename}{character. Output filename (optional)} \item{method}{specifies the interpolation method to be used. Choices are "linear" or "constant" (step function; see the example in \code{\link{approx}}} \item{yleft}{the value to be returned before a non-\code{NA} value is encountered. The default is defined by the value of rule given below} \item{yright}{the value to be returned after the last non-\code{NA} value is encountered. The default is defined by the value of rule given below} \item{rule}{an integer (of length 1 or 2) describing how interpolation is to take place at for the first and last cells (before or after any non-\code{NA} values are encountered). If rule is 1 then NAs are returned for such points and if it is 2, the value at the closest data extreme is used. Use, e.g., \code{rule = 2:1}, if the left and right side extrapolation should differ} \item{f}{for method = "constant" a number between 0 and 1 inclusive, indicating a compromise between left- and right-continuous step functions. If y0 and y1 are the values to the left and right of the point then the value is \code{y0*(1-f)+y1*f} so that \code{f = 0)} is right-continuous and \code{f = 1} is left-continuous} \item{ties}{Handling of tied 'z' values. Either a function with a single vector argument returning a single number result or the string "ordered"} \item{z}{numeric vector to indicate the distance between layers (e.g., time, depth). The default is 1:nlayers(x) } \item{NArule}{single integer used to determine what to do when only a single layer with a non-\code{NA} value is encountered (and linear interpolation is not possible). The default value of 1 indicates that all layers will get this value for that cell; all other values do not change the cell values} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ RasterBrick } \seealso{ \code{ \link{focal}} } \examples{ r <- raster(ncols=5, nrows=5) r1 <- setValues(r, runif(ncell(r))) r2 <- setValues(r, runif(ncell(r))) r3 <- setValues(r, runif(ncell(r))) r4 <- setValues(r, runif(ncell(r))) r5 <- setValues(r, NA) r6 <- setValues(r, runif(ncell(r))) r1[6:10] <- NA r2[5:15] <- NA r3[8:25] <- NA s <- stack(r1,r2,r3,r4,r5,r6) s[1:5] <- NA x1 <- approxNA(s) x2 <- approxNA(s, rule=2) x3 <- approxNA(s, rule=2, z=c(1,2,3,5,14,15)) } \keyword{spatial} raster/man/Logic-methods.Rd0000644000176200001440000000246214507510157015323 0ustar liggesusers\name{Logic-methods} \docType{methods} \alias{Logic-methods} \alias{Logic,Raster,Raster-method} \alias{is.na,Raster-method} \alias{is.nan,Raster-method} \alias{is.finite,Raster-method} \alias{is.infinite,Raster-method} \alias{!,Raster-method} \title{Logical operators and functions} \description{ The following logical (boolean) operators are available for computations with RasterLayer objects: \code{&, |, and !} The following functions are available with a Raster* argument: \code{is.na}, \code{is.nan}, \code{is.finite}, \code{is.infinite} } \value{ A Raster object with logical (\code{TRUE/FALSE} values) } \section{Note}{ These are convenient operators/functions that are most usful for relatively small RasterLayers for which all the values can be held in memory. If the values of the output RasterLayer cannot be held in memory, they will be saved to a temporary file. In that case it could be more efficient to use \code{\link[raster]{calc}} instead. } \seealso{ \code{\link[raster]{Math-methods}}, \code{\link[raster]{overlay}}, \code{\link[raster]{calc}} } \examples{ r <- raster(ncols=10, nrows=10) values(r) <- runif(ncell(r)) * 10 r1 <- r < 3 | r > 6 r2 <- !r1 r3 <- r >= 3 & r <= 6 r4 <- r2 == r3 r[r>3] <- NA r5 <- is.na(r) r[1:5] r1[1:5] r2[1:5] r3[1:5] } \keyword{methods} \keyword{math} raster/man/trim.Rd0000644000176200001440000000246314507510157013601 0ustar liggesusers\name{trim} \alias{trim} \alias{trim,Raster-method} \alias{trim,character-method} \alias{trim,matrix-method} \alias{trim,data.frame-method} \title{Trim} \description{ Trim (shrink) a Raster* object by removing outer rows and columns that all have the same value (e.g. NA). Or remove the whitespace before or after a string of characters (or a matrix, or the character values in a data.frame). } \usage{ \S4method{trim}{Raster}(x, padding=0, values=NA, filename='', ...) \S4method{trim}{character}(x, internal=FALSE, ...) } \arguments{ \item{x}{Raster* object or a character string} \item{values}{numeric. Value(s) based on which a Raster* should be trimmed} \item{padding}{integer. Number of outer rows/columns to keep} \item{filename}{character. Optional output filename} \item{internal}{logical. If \code{TRUE}, sequential internal spaces are replaced by a single space} \item{...}{If \code{x} is a Raster* object: additional arguments as for \code{\link{writeRaster}}} } \value{ A RasterLayer or RasterBrick object (if \code{x} is a Raster* object) or a character string (if \code{x} is a character string). } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster(ncol=18,nrow=18) r[39:49] <- 1 r[113:155] <- 2 r[200] <- 6 s <- trim(r) trim(" hi folks ! ") } \keyword{spatial} raster/man/nlayers.Rd0000644000176200001440000000123014507510157014272 0ustar liggesusers\name{nlayers} \alias{nlayers} \alias{nlayers,BasicRaster-method} \alias{nlayers,Raster-method} \alias{nlayers,RasterStack-method} \alias{nlayers,RasterBrick-method} \alias{nlayers,Spatial-method} \title{Number of layers} \description{ Get the number of layers in a Raster* object, typically used with a (multilayer) RasterStack or RasterBrick object } \usage{ nlayers(x) } \arguments{ \item{x}{Raster* object} } \value{ integer } \seealso{ \code{\link[raster]{names}} } \examples{ r <- raster(ncols=10, nrows=10) values(r) <- 1:ncell(r) s <- stack(r, r, r) nlayers(s) s <- stack(s,s) nlayers(s) s <- dropLayer(s, 2:3) nlayers(s) } \keyword{spatial} raster/man/as.character.Rd0000644000176200001440000000160214507510157015156 0ustar liggesusers\name{as.character} \alias{as.character} \alias{as.character,Raster-method} \alias{as.character,Extent-method} \title{Character representation of a Raster or Extent object} \description{ \code{as.character} returns a text (R code) representation of a Raster* or Extent object. The main purpose of this is to allow quick generation of objects to use in examples on, for example, stackoverflow.com. } \usage{ \S4method{as.character}{Raster}(x, ...) \S4method{as.character}{Extent}(x, ...) } \arguments{ \item{x}{ Raster* or Extent object } \item{...}{ additional arguments, none implemented } } \value{ character } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.character(r) s <- stack(r, r) as.character(s) as.character(extent(s)) x <- as.character(s) eval(parse(text=x)) y <- as.character(extent(s)) eval(parse(text=y)) } \keyword{spatial} \keyword{methods} raster/man/subs.Rd0000644000176200001440000000433514507510157013602 0ustar liggesusers\name{substitute} \docType{methods} \alias{subs} \alias{subs,Raster,data.frame-method} \title{ Substitute values in a Raster* object} \description{ Substitute (replace) values in a Raster* object with values in a \code{data.frame}. The \code{data.frame} should have a column to identify the key (ID) to match with the cell values of the Raster* object, and one or more columns with replacement values. By default these are the first and second column but you can specify other columns with arguments \code{by} and \code{which}. It is possible to match one table to multiple layers, or to use multiple layers as a single key, but not both. } \usage{ \S4method{subs}{Raster,data.frame}(x, y, by=1, which=2, subsWithNA=TRUE, filename='', ...) } \arguments{ \item{x}{Raster* object} \item{y}{data.frame} \item{by}{column number(s) or name(s) identifying the key (ID) to match rows in data.frame \code{y} to values of the Raster object} \item{which}{column number or name that has the new (replacement) values} \item{subsWithNA}{logical. If \code{TRUE} values that are not matched become NA. If \code{FALSE}, they retain their original value (which could also be \code{NA}). This latter option is handy when you want to replace only one or a few values. It cannot be used when \code{x} has multiple layers} \item{filename}{character. Optional output filename} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \details{ You could obtain the same result with \code{\link[raster]{reclassify}}, but \code{subs} is more efficient for simple replacement. Use \code{reclassify} if you want to replace ranges of values with new values. You can also replace values using a fitted model. E.g. fit a model to \code{glm} or \code{loess} and then call \link[raster]{predict} } \value{ Raster object } \seealso{ \code{\link{reclassify}, \link{clamp}, \link{cut}}} \examples{ r <- raster(ncol=10, nrow=10) values(r) <- round(runif(ncell(r)) * 10) df <- data.frame(id=2:8, v=c(10,10,11,11,12:14)) x <- subs(r, df) x2 <- subs(r, df, subsWithNA=FALSE) df$v2 <- df$v * 10 x3 <- subs(r, df, which=2:3) s <- stack(r, r*3) names(s) <- c('first', 'second') x4 <- subs(s, df) x5 <- subs(s, df, which=2:3) } \keyword{methods} \keyword{spatial} raster/man/pointDistance.Rd0000644000176200001440000000436714507510157015437 0ustar liggesusers\name{pointDistance} \alias{pointDistance} \title{Distance between points} \description{ Calculate the geographic distance between two (sets of) points on the WGS ellipsoid (\code{lonlat=TRUE}) or on a plane (\code{lonlat=FALSE}). If both sets do not have the same number of points, the distance between each pair of points is given. If both sets have the same number of points, the distance between each point and the corresponding point in the other set is given, except if \code{allpairs=TRUE}. } \usage{ pointDistance(p1, p2, lonlat, allpairs=FALSE, ...) } \arguments{ \item{p1}{x and y coordinate of first (set of) point(s), either as c(x, y), matrix(ncol=2), or SpatialPoints*. } \item{p2}{x and y coordinate of second (set of) second point(s) (like for \code{p1}). If this argument is missing, a distance matrix is computed for \code{p1} } \item{lonlat}{logical. If \code{TRUE}, coordinates should be in degrees; else they should represent planar ('Euclidean') space (e.g. units of meters) } \item{allpairs}{logical. Only relevant if the number of points in \code{x} and \code{y} is the same. If \code{FALSE} the distance between each point in \code{x} with the corresponding point in \code{y} is returned. If \code{TRUE} a full distance matrix is returned } \item{...}{Additional arguments. None implemented } } \value{ A single value, or a vector, or matrix of values giving the distance in meters (lonlat=TRUE) or map-units (for instance, meters in the case of UTM) If \code{p2} is missing, a distance matrix is returned } \seealso{\code{\link{distanceFromPoints}, \link{distance}, \link{gridDistance}}, \code{\link[sp]{spDistsN1}}. The \code{geosphere} package has many additional distance functions and other functions that operate on spherical coordinates} \author{Robert J. Hijmans and Jacob van Etten. The distance for longitude/latitude data uses GeographicLib by C.F.F. Karney} \examples{ a <- cbind(c(1,5,55,31),c(3,7,20,22)) b <- cbind(c(4,2,8,65),c(50,-90,20,32)) pointDistance(c(0, 0), c(1, 1), lonlat=FALSE) pointDistance(c(0, 0), c(1, 1), lonlat=TRUE) pointDistance(c(0, 0), a, lonlat=TRUE) pointDistance(a, b, lonlat=TRUE) #Make a distance matrix dst <- pointDistance(a, lonlat=TRUE) # coerce to dist object dst <- as.dist(dst) } \keyword{ spatial } raster/man/union.Rd0000644000176200001440000000405414507510157013754 0ustar liggesusers\name{union} \docType{methods} \alias{union} \alias{union,Extent,Extent-method} \alias{union,SpatialPolygons,SpatialPolygons-method} \alias{union,SpatialPolygons,missing-method} \alias{union,SpatialPoints,SpatialPoints-method} \alias{union,SpatialLines,SpatialLines-method} \title{ Union Extent or SpatialPolygons* objects } \description{ Extent objects: Objects are combined into their union. See \code{\link{crop}} and \code{\link{extend}} to union a Raster object with an Extent object. Two SpatialPolygons* objects. Overlapping polygons (between layers, not within layers) are intersected, other spatial objects are appended. Tabular attributes are joined. See \code{\link{bind}} if you want to combine polygons without intersection. Single SpatialPolygons* object. Overlapping polygons are intersected. Original attributes are lost. New attributes allow for determining how many, and which, polygons overlapped. Union for SpatialLines and SpatialPoints simply combines the two data sets; without any geometric intersections. This is equivalent to \code{\link{bind}}. } \usage{ \S4method{union}{Extent,Extent}(x, y) \S4method{union}{SpatialPolygons,SpatialPolygons}(x, y) \S4method{union}{SpatialPolygons,missing}(x, y) \S4method{union}{SpatialLines,SpatialLines}(x, y) \S4method{union}{SpatialPoints,SpatialPoints}(x, y) } \arguments{ \item{x}{Extent or SpatialPolygons* object} \item{y}{Same as \code{x} or missing} } \value{ Extent or SpatialPolygons object } \seealso{ \code{\link[raster]{intersect}, \link[raster]{extent}, \link[raster]{setExtent}} \code{\link[sp]{merge}} for merging a data.frame with attributes of Spatial objects and \code{\link{+,SpatialPolygons,SpatialPolygons-method}} for an algebraic notation } \examples{ e1 <- extent(-10, 10, -20, 20) e2 <- extent(0, 20, -40, 5) union(e1, e2) #SpatialPolygons p <- shapefile(system.file("external/lux.shp", package="raster")) p0 <- aggregate(p) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) u <- union(p0, b) plot(u, col=2:4) } \keyword{methods} \keyword{spatial} raster/man/dimensions.Rd0000644000176200001440000000172414507510157014775 0ustar liggesusers\name{dim} \alias{dim} \alias{dim,RasterStackBrick-method} \alias{dim,BasicRaster-method} \alias{dim<-,BasicRaster-method} \alias{dim<-,RasterLayer-method} \alias{dim<-,RasterBrick-method} \docType{methods} \title{Dimensions of a Raster* object} \description{ Get or set the number of rows, columns, and layers of a Raster* object. You cannot use this function to set the dimensions of a RasterStack object. When setting the dimensions, you can provide a row number, or a vector with the row and the column number (for a RasterLayer and a RasterBrick), or a row and column number and the number of layers (only for a RasterBrick) } \usage{ \S4method{dim}{BasicRaster}(x) } \arguments{ \item{x}{Raster(* object} } \value{ Integer or Raster* object } \seealso{ \code{ \link{ncell}, \link{extent}, \link{res} } } \examples{ r <- raster() dim(r) dim(r) <- c(18) dim(r) dim(r) <- c(18, 36) dim(r) b <- brick(r) dim(b) dim(b) <- c(10, 10, 5) dim(b) } \keyword{spatial} raster/man/projectRaster.Rd0000644000176200001440000001170014507510157015447 0ustar liggesusers\name{projectRaster} \alias{projectRaster} \alias{projectExtent} \title{Project a Raster object} \description{ Project the values of a Raster* object to a new Raster* object with another projection (coordinate reference system, (CRS)). You can do this by providing the new projection as a single argument in which case the function sets the extent and resolution of the new object. To have more control over the transformation, and, for example, to assure that the new object lines up with other datasets, you can provide a Raster* object with the properties that the input data should be projected to. \code{projectExtent} returns a RasterLayer with a projected extent, but without any values. This RasterLayer can then be adjusted (e.g. by setting its resolution) and used as a template \code{'to'} in \code{projectRaster}. } \note{ If the resolution of the output is much larger than that of the input, you should first aggregate the input such that the resolution of the input becomes more similar (perhaps a little smaller) to the output. } \usage{ projectRaster(from, to, res, crs, method="bilinear", alignOnly=FALSE, over=FALSE, filename="", ...) projectExtent(object, crs) } \arguments{ \item{from}{Raster* object} \item{to}{Raster* object with the parameters to which 'from' should be projected} \item{res}{single or (vector of) two numerics. To, optionally, set the output resolution if 'to' is missing} \item{crs}{character or object of class 'CRS'. PROJ.4 description of the coordinate reference system. In projectRaster this is used to set the output CRS if 'to' is missing, or if 'to' has no valid CRS} \item{method}{method used to compute values for the new RasterLayer. Either 'ngb' (nearest neighbor), which is useful for categorical variables, or 'bilinear' (bilinear interpolation; the default value), which is appropriate for continuous variables.} \item{alignOnly}{logical. Use \code{to} or other parameters only to align the output (i.e. same origin and resolution), but use the projected extent from \code{from}} \item{over}{logical. If \code{TRUE} wrapping around the date-line is turned off. This can be desirable for global data (to avoid mapping the same areas twice) but it is not desirable 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 library. Also see \code{projInfo('proj')}, \code{projInfo('ellps')}, and \code{projInfo('datum')} for valid PROJ.4 values. } \note{ User beware. Sadly, the PROJ.4 notation has been partly deprecated in the GDAL/PROJ library that is used by this function. You can still use it, but *only* with the the WGS84 datum. Other datums are silently ignored. When printing a Spat* object the PROJ.4 notation is shown because it is the most concise and clear format available. However, internally a WKT representation is used (see \code{\link{crs}}). Vector (points, lines, polygons) can be transformed with \code{\link[sp]{spTransform}}. \code{projectExtent} does not work very well when transforming projected circumpolar data to (e.g.) longitude/latitude. With such data you may need to adjust the returned object. E.g. do \code{ymax(object) <- 90} } \value{ RasterLayer or RasterBrick object. } \author{Robert J. Hijmans and Joe Cheng} \seealso{ \code{\link{resample}} } \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, crs="+proj=longlat") r <- setValues(r, 1:ncell(r)) projection(r) # proj.4 projection description newproj <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +datum=WGS84" #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) } \keyword{spatial} raster/man/filename.Rd0000644000176200001440000000077414507510157014411 0ustar liggesusers\name{filename} \alias{filename} \title{Filename} \description{ Get the filename of a Raster* object. You cannot set the filename of an object (except for RasterStack objects); but you can provide a 'filename= ' argument to a function that creates a new RasterLayer or RasterBrick* object. } \usage{ filename(x) } \arguments{ \item{x}{A Raster* object } } \value{ a Raster* object } \examples{ r <- raster( system.file("external/test.grd", package="raster") ) filename(r) } \keyword{ spatial } raster/man/saveStack.Rd0000644000176200001440000000246114507510157014550 0ustar liggesusers\name{stackSave} \alias{stackSave} \alias{stackOpen} \title{Save or open a RasterStack file} \description{ A RasterStack is a collection of RasterLayers with the same spatial extent and resolution. They can be created from RasterLayer objects, or from file names. These two functions allow you to save the references to raster files and recreate a rasterStack object later. They only work if the RasterStack points to layers that have their values on disk. The values are not saved, only the references to the files. } \usage{ stackOpen(stackfile) stackSave(x, filename) } \arguments{ \item{stackfile}{ Filename for the RasterStack (to save it on disk) } \item{x}{ RasterStack object } \item{filename}{File name } } \details{ When a RasterStack is saved to a file, only pointers (filenames) to raster datasets are saved, not the data. If the name or location of a raster file changes, the RasterStack becomes invalid. } \value{ RasterStack object } \seealso{ \code{\link[raster]{writeRaster}}, \code{\link[raster]{stack}}, \code{\link[raster]{addLayer}}} \examples{ file <- system.file("external/test.grd", package="raster") s <- stack(c(file, file)) \dontrun{ s <- stackSave(s, "mystack") # note that filename adds an extension .stk to a stackfile s2 <- stackOpen("mystack.stk") s2 } } \keyword{ spatial } raster/man/headtail.Rd0000644000176200001440000000163314507510157014377 0ustar liggesusers\name{head} \docType{methods} \alias{head} \alias{head,RasterLayer-method} \alias{head,RasterStackBrick-method} \alias{head,Spatial-method} \alias{tail} \alias{tail,RasterLayer-method} \alias{tail,RasterStackBrick-method} \alias{tail,Spatial-method} \title{Show the head or tail of a Raster* object} \description{ Show the head (first rows/columns) or tail (last rows/columns) of the cell values of a Raster* object. } \usage{ head(x, ...) tail(x, ...) } \arguments{ \item{x}{Raster* object} \item{...}{Additional arguments: \code{rows=10} and \code{cols=20}, to set the maximum number of rows and columns that are shown. For RasterStack and RasterBrick objects there is an additional argument \code{lyrs} } } \value{ matrix } \seealso{ \code{\link{getValuesBlock}} } \examples{ r <- raster(nrow=25, ncol=25) values(r) = 1:ncell(r) head(r) tail(r, cols=10, rows=5) } \keyword{methods} \keyword{spatial} raster/man/setExtent.Rd0000644000176200001440000000241614507510157014607 0ustar liggesusers\name{setExtent} \alias{setExtent} \alias{extent<-} \title{Set the extent of a RasterLayer} \description{ setExtent sets the extent of a Raster* object. Either by providing a new Extent object or by setting the extreme coordinates one by one. } \usage{ setExtent(x, ext, keepres=FALSE, snap=FALSE) extent(x) <- value } \arguments{ \item{x}{A Raster* object} \item{ext}{ An object of class Extent (which you can create with \code{\link[raster]{extent}}, or an object that has an extent (e.g. a Raster* or Spatial* object) ) } \item{keepres}{logical. If \code{TRUE}, the resolution of the cells will stay the same after adjusting the bounding box (by adjusting the number of rows and columns). If \code{FALSE}, the number of rows and columns will stay the same, and the resolution will be adjusted. } \item{snap}{logical. If \code{TRUE}, the extent is adjusted so that the cells of the input and output RasterLayer are aligned} \item{value}{An object of class Extent (which you can create with \code{\link[raster]{extent}} )} } \value{ a Raster* object } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{Extent-class}} } \examples{ r <- raster() bb <- extent(-10, 10, -20, 20) extent(r) <- bb r <- setExtent(r, bb, keepres=TRUE) } \keyword{spatial} raster/man/contour.Rd0000644000176200001440000000125414507510157014314 0ustar liggesusers\name{contour} \docType{methods} \alias{contour} \alias{contour,RasterLayer-method} \title{Contour plot} \description{ Contour plot of a RasterLayer. } \usage{ \S4method{contour}{RasterLayer}(x, maxpixels=100000, ...) } \arguments{ \item{x}{Raster* object} \item{maxpixels}{maximum number of pixels used to create the contours} \item{...}{any argument that can be passed to \code{\link[graphics]{contour}} (graphics package)} } \seealso{ \code{\link{persp}}, \code{\link{filledContour}}, \code{\link{rasterToContour} } } \examples{ r <- raster(system.file("external/test.grd", package="raster")) plot(r) contour(r, add=TRUE) } \keyword{methods} \keyword{spatial} raster/man/round.Rd0000644000176200001440000000216214507510157013751 0ustar liggesusers\name{round} \docType{methods} \alias{round,RasterLayer-method} \alias{trunc,RasterLayer-method} \alias{ceiling,RasterLayer-method} \alias{floor,RasterLayer-method} \title{Integer values} \description{ These functions take a single RasterLayer argument \code{x} and change its values to integers. \code{ceiling} returns a RasterLayer with the smallest integers not less than the corresponding values of x. \code{floor} returns a RasterLayer with the largest integers not greater than the corresponding values of x. \code{trunc} returns a RasterLayer with the integers formed by truncating the values in x toward 0. \code{round} returns a RasterLayer with values rounded to the specified number of digits (decimal places; default 0). } \section{Methods}{ \describe{ ceiling(x) floor(x) trunc(x, ...) round(x, digits = 0) \item{x}{a RasterLayer object} \item{digits}{integer indicating the precision to be used} \item{...}{additional arguments} } } \details{ see ?base::round } \value{ a RasterLayer object } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- runif(ncell(r)) * 10 s <- round(r) } \keyword{spatial} raster/man/cover.Rd0000644000176200001440000000346414507510157013746 0ustar liggesusers\name{cover} \docType{methods} \alias{cover} \alias{cover,RasterLayer,RasterLayer-method} \alias{cover,RasterStackBrick,Raster-method} \alias{cover,SpatialPolygons,SpatialPolygons-method} \title{ Replace NA values with values of other layers } \description{ For Raster* objects: Replace \code{NA} values in the first Raster object (\code{x}) with the values of the second (\code{y}), and so forth for additional Rasters. If \code{x} has multiple layers, the subsequent Raster objects should have the same number of layers, or have a single layer only (which will be recycled). For SpatialPolygons* objects: Areas of \code{x} that overlap with \code{y} are replaced by (or intersected with) \code{y}. } \usage{ \S4method{cover}{RasterLayer,RasterLayer}(x, y, ..., filename='') \S4method{cover}{RasterStackBrick,Raster}(x, y, ..., filename='') \S4method{cover}{SpatialPolygons,SpatialPolygons}(x, y, ..., identity=FALSE) } \arguments{ \item{x}{Raster* or SpatialPolygons* object} \item{y}{Same as \code{x}} \item{filename}{character. Output filename (optional)} \item{...}{Same as \code{x}. If \code{x} is a Raster* object, also additional arguments as for \code{\link{writeRaster}}} \item{identity}{logical. If \code{TRUE} overlapping areas are intersected rather than replaced} } \value{ RasterLayer or RasterBrick object, or SpatialPolygons object } \examples{ # raster objects r1 <- raster(ncols=36, nrows=18) values(r1) <- 1:ncell(r1) r2 <- setValues(r1, runif(ncell(r1))) r2[r2 < 0.5] <- NA r3 <- cover(r2, r1) #SpatialPolygons p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) b <- SpatialPolygonsDataFrame(b, data.frame(ID_1=9)) cv1 <- cover(p, b) cv2 <- cover(p, b, identity=TRUE) } \keyword{methods} \keyword{spatial} raster/man/focalWeight.Rd0000644000176200001440000000216614507510157015062 0ustar liggesusers\name{focalWeight} \alias{focalWeight} \title{Focal weights matrix} \description{ Calculate focal ("moving window") weight matrix for use in the \code{\link{focal}} function. The sum of the values adds up to one. } \usage{ focalWeight(x, d, type=c('circle', 'Gauss', 'rectangle'), fillNA=FALSE) } \arguments{ \item{x}{Raster* object} \item{d}{numeric. If \code{type=circle}, the radius of the circle (in units of the CRS). If \code{type=rectangle} the dimension of the rectangle (one or two numbers). If \code{type=Gauss} the size of sigma, and optionally another number to determine the size of the matrix returned (default is 3 times sigma)} \item{type}{character indicating the type of filter to be returned} \item{fillNA}{logical. If \code{TRUE}, zeros are set to \code{NA} such that they are ignored in the computations. Only applies to \code{type="circle"}} } \value{ matrix that can be used in \code{\link{focal}} } \examples{ r <- raster(ncols=180, nrows=180, xmn=0, crs="+proj=utm +zone=1") # Gaussian filter for square cells gf <- focalWeight(r, .5, "Gauss") focalWeight(r, 2, "circle", fillNA=TRUE) } \keyword{spatial} raster/man/getValuesBlock.Rd0000644000176200001440000000377514507510157015547 0ustar liggesusers\name{getValuesBlock} \alias{getValuesBlock} \alias{getValuesBlock,RasterLayer-method} \alias{getValuesBlock,RasterLayerSparse-method} \alias{getValuesBlock,RasterStack-method} \alias{getValuesBlock,RasterBrick-method} \title{Get a block of raster cell values} \description{ getValuesBlock returns values for a block (rectangular area) of values of a Raster* object. } \usage{ \S4method{getValuesBlock}{RasterLayer}(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), format='', ...) \S4method{getValuesBlock}{RasterBrick}(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) \S4method{getValuesBlock}{RasterStack}(x, row=1, nrows=1, col=1, ncols=(ncol(x)-col+1), lyrs, ...) } \arguments{ \item{x}{Raster* object} \item{row}{positive integer. Row number to start from, should be between 1 and nrow(x)} \item{nrows}{positive integer. How many rows? Default is 1} \item{col}{positive integer. Column number to start from, should be between 1 and ncol(x)} \item{ncols}{positive integer. How many columns? Default is the number of columns left after the start column} \item{format}{character. When \code{x} is a \code{RasterLayer}, if \code{format='matrix'} or \code{format='m'}, a matrix is returned instead of a vector. If \code{format='matrix'}, it is a nrow x ncol matrix. If \code{format='m'} it is a 1 column matrix (the benefit is that the type of output is now the same for all Raster objects)} \item{lyrs}{integer (vector). Which layers? Default is all layers (\code{1:nlayers(x)})} \item{...}{additional arguments (none implemented)} } \value{ matrix or vector (if \code{(x=RasterLayer)}, unless \code{format='matrix'}) } \seealso{ \code{\link{getValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) b <- getValuesBlock(r, row=100, nrows=3, col=10, ncols=5) b b <- matrix(b, nrow=3, ncol=5, byrow=TRUE) b logo <- brick(system.file("external/rlogo.grd", package="raster")) getValuesBlock(logo, row=35, nrows=3, col=50, ncols=3, lyrs=2:3) } \keyword{spatial} \keyword{methods} raster/man/distanceFromPoints.Rd0000644000176200001440000000254214507510157016437 0ustar liggesusers\name{distanceFromPoints} \alias{distanceFromPoints} \title{Distance from points} \description{ The function calculates the distance from a set of points to all cells of a Raster* object. The distance unit is in meters if the coordinate reference system (crs) of the Raster* object is (\code{+proj=longlat}) or assumed to be if the crs is \code{NA}. In all other cases it is in the units defined by the crs (which typically is meters). } \usage{ distanceFromPoints(object, xy, filename='', ...) } \arguments{ \item{object}{Raster object} \item{xy}{matrix of x and y coordinates, or a SpatialPoints* object.} \item{filename}{character. Optional filename for the output RasterLayer} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \details{ Distances for \code{longlat} data are computed on the WGS84 spheroid using GeographicLib (Karney, 2013) } \references{ C.F.F. Karney, 2013. Algorithms for geodesics, J. Geodesy 87: 43-55. \doi{10.1007/s00190-012-0578-z}. } \value{RasterLayer} \seealso{ \code{\link{crs}}, \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} } \examples{ r <- raster(ncol=36,nrow=18) xy <- c(0,0) d1 <- distanceFromPoints(r, xy) crs(r) = '+proj=utm +zone=12 +datum=WGS84' d2 <- distanceFromPoints(r, xy) par(mfrow=c(1,2)) plot(d1) plot(d2) } \keyword{spatial} raster/man/names.Rd0000644000176200001440000000141414507510157013724 0ustar liggesusers\name{names} \alias{labels,Raster-method} \alias{names} \alias{names<-} \alias{names,Raster-method} \alias{names,RasterStack-method} \alias{names<-,Raster-method} \title{Names of raster layers} \description{ Get or set the names of the layers of a Raster* object } \usage{ \S4method{names}{Raster}(x) \S4method{names}{Raster}(x)<-value \S4method{labels}{Raster}(object) } \arguments{ \item{x}{Raster* object} \item{object}{Raster* object} \item{value}{character (vector)} } \value{ Character } \seealso{ \code{\link{nlayers}, \link[raster]{bands}} } \examples{ r <- raster(ncols=5, nrows=5) values(r) <- 1:ncell(r) s <- stack(r, r, r) nlayers(s) names(s) names(s) <- c('a', 'b', 'c') names(s)[2] <- 'hello world' names(s) s labels(s) } \keyword{spatial} raster/man/extract.Rd0000644000176200001440000002220314677254363014306 0ustar liggesusers\name{extract} \docType{methods} \alias{extract} \alias{extract,Raster,vector-method} \alias{extract,Raster,matrix-method} \alias{extract,Raster,data.frame-method} \alias{extract,Raster,SpatialPoints-method} \alias{extract,Raster,SpatialLines-method} \alias{extract,Raster,SpatialPolygons-method} \alias{extract,Raster,sf-method} \alias{extract,Raster,Extent-method} \alias{extract,SpatialPolygons,SpatialPoints-method} \alias{extract,SpatialPolygons,data.frame-method} \alias{extract,SpatialPolygons,matrix-method} \title{Extract values from Raster objects} \description{ Extract values from a Raster* object at the locations of spatial vector data. There are methods for points, lines, and polygons (classes from `sp` or `sf`), for a matrix or data.frame of points. You can also use cell numbers and Extent (rectangle) objects to extract values. If \code{y} represents points, \code{extract} returns the values of a Raster* object for the cells in which a set of points fall. If \code{y} represents lines, the \code{extract} method returns the values of the cells of a Raster* object that are touched by a line. If \code{y} represents polygons, the \code{extract} method returns the values of the cells of a Raster* object that are covered by a polygon. A cell is covered if its center is inside the polygon (but see the \code{weights} option for considering partly covered cells; and argument \code{small} for getting values for small polygons). It is also possible to extract values for point locations from SpatialPolygons. } \usage{ \S4method{extract}{Raster,matrix}(x, y, method='simple', buffer=NULL, small=FALSE, cellnumbers=FALSE, fun=NULL, na.rm=TRUE, layer, nl, df=FALSE, factors=FALSE, ...) \S4method{extract}{Raster,SpatialLines}(x, y, fun=NULL, na.rm=FALSE, cellnumbers=FALSE, df=FALSE, layer, nl, factors=FALSE, along=FALSE, sp=FALSE, ...) \S4method{extract}{Raster,SpatialPolygons}(x, y, fun=NULL, na.rm=FALSE, exact=FALSE, weights=FALSE, normalizeWeights=TRUE, cellnumbers=FALSE, small=TRUE, df=FALSE, layer, nl, factors=FALSE, sp=FALSE, ...) \S4method{extract}{SpatialPolygons,SpatialPoints}(x, y, ...) } \arguments{ \item{x}{Raster* object} \item{y}{points represented by a two-column matrix or data.frame, or \code{\link[sp]{SpatialPoints}*}; \code{\link[sp]{SpatialPolygons}*}; \code{\link[sp]{SpatialLines}}; \code{sf} spatial vector objects; \code{\link{Extent}}; or a numeric vector representing cell numbers} \item{method}{character. \code{'simple'} or \code{'bilinear'}. If \code{'simple'} values for the cell a point falls in are returned. If \code{'bilinear'} the returned values are interpolated from the values of the four nearest raster cells.} \item{buffer}{numeric. The radius of a buffer around each point from which to extract cell values. If the distance between the sampling point and the center of a cell is less than or equal to the buffer, the cell is included. The buffer can be specified as a single value, or as a vector of the length of the number of points. If the data are not projected (latitude/longitude), the unit should be meters. Otherwise it should be in map-units (typically also meters).} \item{small}{logical. If \code{TRUE} and \code{y} represents points and a \code{buffer} argument is used, the function always return a number, also when the buffer does not include the center of a single cell. The value of the cell in which the point falls is returned if no cell center is within the buffer. If \code{y} represents polygons, a value is also returned for relatively small polygons (e.g. those smaller than a single cell of the Raster* object), or polygons with an odd shape, for which otherwise no values are returned because they do not cover any raster cell centers. In some cases, you could alternatively use the centroids of such polygons, for example using \code{extract(x, coordinates(y))} or \code{extract(x, coordinates(y), method='bilinear')}.} \item{fun}{function to summarize the values (e.g. \code{mean}). The function should take a single numeric vector as argument and return a single value (e.g. mean, min or max), and accept a \code{na.rm} argument. Thus, standard R functions not including an na.rm argument must be wrapped as in this example: fun=function(x,...)length(x). If \code{y} represents points, \code{fun} is only used when a buffer is used (and hence multiple values per spatial feature would otherwise be returned).} \item{na.rm}{logical. Only useful when an argument \code{fun} is supplied. If \code{na.rm=TRUE} (the default value), NA values are removed before fun is applied. This argument may be ignored if the function used has a \code{...} argument and ignores an additional \code{na.rm} argument} \item{cellnumbers}{logical. If \code{cellnumbers=TRUE}, cell-numbers will also be returned (if no \code{fun} argument is supplied, and when extracting values with points, if \code{buffer} is \code{NULL})} \item{df}{logical. If \code{df=TRUE}, results will be returned as a data.frame. The first column is a sequential ID, the other column(s) are the extracted values} \item{exact}{logical. If \code{TRUE} the fraction of each cell that is (partly) covered by the polygon is extracted, not only the cells of which the centers are covered. This option is particularly useful if the polygons are small relative to the cells size of the Raster* object} \item{weights}{logical. If \code{TRUE} the fraction of a cell that is covered is returned or used by \code{fun}. These can be used as weights can be used for averaging; see examples. If \code{exact} is \code{FALSE}, this is the approximate fraction of each cell that is covered by the polygon, rounded to 1/100 } \item{normalizeWeights}{logical. If \code{TRUE}, weights are normalized such that they add up to one for each polygon} \item{factors}{logical. If \code{TRUE}, factor values are returned, else their integer representation is returned} \item{layer}{integer. First layer for which you want values (if \code{x} is a multilayer object)} \item{nl}{ integer. Number of layers for which you want values (if \code{x} is a multilayer object)} \item{along}{ boolean. Should returned values be ordered to go along the lines?} \item{sp}{ boolean. Should the extracted values be added to the data.frame of the Spatial* object \code{y}? This only applies if \code{y} is a Spatial* object and, for SpatialLines and SpatialPolygons, if \code{fun} is not NULL. In this case the returned value is the expanded Spatial object} \item{...}{additional arguments (none implemented)} } \value{ A vector for RasterLayer objects, and a matrix for RasterStack or RasterBrick objects. A list (or a data.frame if \code{df=TRUE}) if \code{y} is a SpatialPolygons* or SpatialLines* object or if a \code{buffer} argument is used (but not a \code{fun} argument). If \code{sp=TRUE} and \code{y} is a Spatial* object and \code{fun} is not NULL a Spatial* object is returned. The order of the returned values corresponds to the order of object \code{y}. If \code{df=TRUE}, this is also indicated in the first variable ('ID'). } \seealso{ \code{\link{getValues}, \link{getValuesFocal}} } \examples{ r <- raster(ncol=36, nrow=18, vals=1:(18*36)) ############################### # extract values by cell number ############################### extract(r, c(1:2, 10, 100)) s <- stack(r, sqrt(r), r/r) extract(s, c(1, 10, 100), layer=2, n=2) ############################### # extract values with points ############################### xy <- cbind(-50, seq(-80, 80, by=20)) extract(r, xy) sp <- SpatialPoints(xy) extract(r, sp, method='bilinear') # examples with a buffer extract(r, xy[1:3,], buffer=1000000) extract(r, xy[1:3,], buffer=1000000, fun=mean) ## illustrating the varying size of a buffer (expressed in meters) ## on a longitude/latitude raster z <- extract(r, xy, buffer=1000000) s <- raster(r) for (i in 1:length(z)) { s[z[[i]]] <- i } ## compare with raster that is not longitude/latitude crs(r) <- "+proj=utm +zone=17" xy[,1] <- 50 z <- extract(r, xy, buffer=8) for (i in 1:length(z)) { s[z[[i]]] <- i } plot(s) # library(maptools) # data(wrld_simpl) # plot(wrld_simpl, add=TRUE) ############################### # extract values with lines ############################### r <- raster(ncol=36, nrow=18, vals=1:(18*36)) cds1 <- rbind(c(-50,0), c(0,60), c(40,5), c(15,-45), c(-10,-25)) cds2 <- rbind(c(80,20), c(140,60), c(160,0), c(140,-55)) lines <- spLines(cds1, cds2) extract(r, lines) ############################### # extract values with polygons ############################### cds1 <- rbind(c(-180,-20), c(-160,5), c(-60, 0), c(-160,-60), c(-180,-20)) cds2 <- rbind(c(80,0), c(100,60), c(120,0), c(120,-55), c(80,0)) polys <- spPolygons(cds1, cds2) v <- extract(r, polys) # mean for each polygon unlist(lapply(v, function(x) if (!is.null(x)) mean(x, na.rm=TRUE) else NA )) # v <- extract(r, polys, cellnumbers=TRUE) # weighted mean # v <- extract(r, polys, weights=TRUE, fun=mean) # equivalent to: # v <- extract(r, polys, weights=TRUE) # sapply(v, function(x) if (!is.null(x)) {sum(apply(x, 1, prod)) / sum(x[,2])} else NA) ############################### # extract values with an extent ############################### e <- extent(150,170,-60,-40) extract(r, e) #plot(r) #plot(e, add=T) } \keyword{methods} \keyword{spatial} raster/man/factor.Rd0000644000176200001440000000735414507510157014110 0ustar liggesusers\name{factors} \docType{methods} \alias{is.factor} \alias{is.factor,Raster-method} \alias{is.factor,RasterStack-method} \alias{as.factor} \alias{as.factor,RasterLayer-method} \alias{levels} \alias{levels,Raster-method} \alias{levels,RasterStack-method} \alias{levels<-} \alias{levels<-,Raster-method} \alias{asFactor} \alias{asFactor,RasterLayer-method} \alias{factorValues} \alias{ratify} \alias{ratify,Raster-method} \alias{deratify} \title{Factors} \description{ These functions allow for defining a RasterLayer as a categorical variable. Such a RasterLayer is linked to other values via a "Raster Attribute Table" (RAT). Thus the cell values are an index, whereas the actual values of interest are in the RAT. The RAT is a data.frame. The first column in the RAT ("ID") has the unique cell values of the layer; this column should normally not be changed. The other columns can be of any basic type (factor, character, integer, numeric or logical). The functions documented here are mainly available such that files with a RAT can be read and processed; currently there is not too much further support. Whether a layer is defined as a factor or not is currently ignored by almost all functions. An exception is the 'extract' function (when used with option df=TRUE). Function 'levels' returns the RAT for inspection. It can be modified and set using \code{levels <- value} (but use caution as it is easy to mess things up). \code{as.factor} and \code{ratify} create a layer with a RAT table. Function 'deratify' creates a single layer for a (or each) variable in the RAT table. } \usage{ is.factor(x) as.factor(x) levels(x) \S4method{ratify}{Raster}(x, filename="", count=FALSE, ...) factorValues(x, v, layer=1, att=NULL, append.names=FALSE) deratify(x, att=NULL, layer=1, complete=FALSE, drop=TRUE, fun='mean', filename='', ...) asFactor(x, ...) } \arguments{ \item{x}{Raster* object} \item{v}{integer cell values} \item{layer}{integer > 0 indicating which layer to use (in a RasterStack or RasterBrick)} \item{att}{numeric or character. Which variable(s) in the RAT table should be used. If \code{NULL}, all variables are extracted. If using a numeric, skip the first two default columns} \item{append.names}{logical. Should names of data.frame returned by a combination of the name of the layer and the RAT variables? (can be useful for multilayer objects} \item{filename}{character. Optional} \item{count}{logical. If \code{TRUE}, a columns with frequencies is added} \item{...}{additional arguments as for \code{\link{writeRaster}}} \item{complete}{logical. If \code{TRUE}, the layer returned is no longer a factor} \item{drop}{logical. If \code{TRUE} a factor is converted to a numerical value if possible} \item{fun}{character. Used to get a single value for each class for a weighted RAT table. 'mean', 'min', 'max', 'smallest', or 'largest'} } \value{ Raster* object; list (levels); boolean (is.factor); matrix (factorValues) } \note{asFactor is deprecated and should not be used} \examples{ set.seed(0) r <- raster(nrow=10, ncol=10) values(r) <- runif(ncell(r)) * 10 is.factor(r) r <- round(r) f <- as.factor(r) is.factor(f) x <- levels(f)[[1]] x x$code <- letters[10:20] levels(f) <- x levels(f) f r <- raster(nrow=10, ncol=10) values(r) = 1 r[51:100] = 2 r[3:6, 1:5] = 3 r <- ratify(r) rat <- levels(r)[[1]] rat$landcover <- c("Pine", "Oak", "Meadow") rat$code <- c(12,25,30) levels(r) <- rat r # extract values for some cells i <- extract(r, c(1,2, 25,100)) i # get the attribute values for these cells factorValues(r, i) # write to file: # rr <- writeRaster(r, rasterTmpFile(), overwrite=TRUE) # rr # create a single-layer factor x <- deratify(r, "landcover") x is.factor(x) levels(x) } \keyword{methods} \keyword{spatial} raster/man/sampleStratified.Rd0000644000176200001440000000322114507510157016117 0ustar liggesusers\name{sampleStratified} \alias{sampleStratified} \alias{sampleStratified,RasterLayer-method} \title{Stratified random sample} \description{ Take a stratified random sample from the cell values of a Raster* object (without replacement). An attempt is made to sample \code{size} cells from each stratum. The values in the RasterLayer \code{x} are rounded to integers; with each value representing a stratum. } \usage{ \S4method{sampleStratified}{RasterLayer}(x, size, exp=10, na.rm=TRUE, xy=FALSE, ext=NULL, sp=FALSE, ...) } \arguments{ \item{x}{Raster* object, with values (rounded to integers) representing strata} \item{size}{positive integer giving the number of items to choose} \item{exp}{numeric >= 1. 'Expansion factor' that is multiplied with size to get an intial sample. Can be increased when you get an insufficient number of samples for small strata} \item{na.rm}{logical. If \code{TRUE} (the default), \code{NA} values are removed from random sample} \item{xy}{logical. Return coordinates of cells rather than cell numbers} \item{ext}{Extent object. To limit regular sampling to the area within the extent} \item{sp}{logical. If \code{TRUE}, a SpatialPointsDataFrame is returned} \item{...}{Additional arguments. None implemented} } \details{ The function may not work well when the size (number of cells) of some strata is relatively small. } \value{ matrix of cell numbers (and optionally coordinates) by stratum } \seealso{\code{\link{sampleRandom}, \link{sampleRegular}}} \examples{ r <- raster(ncol=10, nrow=10) names(r) <- 'stratum' values(r) <- round((runif(ncell(r))+0.5)*3) sampleStratified(r, size=3) } \keyword{spatial} raster/man/density.Rd0000644000176200001440000000157714507510157014312 0ustar liggesusers\name{density} \alias{density} \alias{density,Raster-method} \docType{methods} \title{Density plot} \description{ Create density plots of values in a Raster object } \usage{ \S4method{density}{Raster}(x, layer, maxpixels=100000, plot=TRUE, main, ...) } \arguments{ \item{x}{Raster object} \item{layer}{numeric. Can be used to subset the layers to plot in a multilayer object (RasterBrick or RasterStack)} \item{maxpixels}{the maximum number of (randomly sampled) cells to be used for creating the plot} \item{plot}{if \code{TRUE} produce a plot, else return a density object} \item{main}{main title for each plot (can be missing)} \item{...}{Additional arguments passed to base plot} } \value{ density plot (and a density object, returned invisibly if \code{plot=TRUE)} } \examples{ logo <- stack(system.file("external/rlogo.grd", package="raster")) density(logo) } \keyword{spatial} raster/man/scalebar.Rd0000644000176200001440000000244414507510157014401 0ustar liggesusers\name{scalebar} \alias{scalebar} \title{scalebar} \description{ Add a scalebar to a plot } \usage{ scalebar(d, xy = NULL, type = "line", divs = 2, below = "", lonlat = NULL, label, adj=c(0.5, -0.5), lwd = 2, ...) } \arguments{ \item{d}{distance covered by scalebar} \item{xy}{x and y coordinate to place the plot. Can be NULL. Use \code{xy=click()} to make this interactive } \item{type}{"line" or "bar"} \item{divs}{Number of divisions for a bar type. 2 or 4} \item{below}{Text to go below scalebar (e.g., "kilometers")} \item{lonlat}{Logical or NULL. If logical, \code{TRUE} indicates if the plot is using longitude/latitude coordinates. If \code{NULL} this is guessed from the plot's coordinates} \item{adj}{adjustment for text placement} \item{label}{Vector of three numbers to label the scale bar (beginning, midpoint, end)} \item{lwd}{line width for the "line" type scalebar} \item{...}{arguments to be passed to other methods } } \value{ None. Use for side effect of a scalebar added to a plot } \seealso{ \code{\link[raster]{plot}} } \author{Robert J. Hijmans; partly based on a function by Josh Gray } \examples{ f <- system.file("external/test.grd", package="raster") r <- raster(f) plot(r) scalebar(1000) scalebar(1000, xy=c(178000, 333500), type='bar', divs=4) } \keyword{spatial} raster/man/rowFromCell.Rd0000644000176200001440000000214014507510157015051 0ustar liggesusers\name{rowFromCell} \alias{rowFromCell} \alias{rowFromCell,BasicRaster,numeric-method} \alias{colFromCell} \alias{colFromCell,BasicRaster,numeric-method} \alias{rowColFromCell} \alias{rowColFromCell,BasicRaster,numeric-method} \title{Row or column number from a cell number} \description{ These functions get the row and/or column number from a cell number of a Raster* object) } \usage{ colFromCell(object, cell) rowFromCell(object, cell) rowColFromCell(object, cell) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{cell}{cell number(s)} } \details{ The colFromCell and similar functions accept a single value, or a vector or list of these values, Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \value{ row of column number(s) } \seealso{ \code{\link[raster]{cellFrom}} } \examples{ r <- raster(ncols=10, nrows=10) colFromCell(r, c(5,15)) rowFromCell(r, c(5,15)) rowColFromCell(r, c(5,15)) } \keyword{spatial} raster/man/erase.Rd0000644000176200001440000000256614507510157013731 0ustar liggesusers\name{erase} \docType{methods} \alias{erase} \alias{erase,SpatialPolygons,SpatialPolygons-method} \alias{erase,SpatialLines,SpatialPolygons-method} \title{ Erase parts of a SpatialPolygons* or SpatialLines* object. The inverse of this can be done with \code{\link{intersect}} } \description{ Erase parts of a SpatialPolygons* or SpatialLines* object with a SpatialPolygons* object } \usage{ \S4method{erase}{SpatialPolygons,SpatialPolygons}(x, y, ...) \S4method{erase}{SpatialLines,SpatialPolygons}(x, y, ...) } \arguments{ \item{x}{SpatialPolygons or SpatialLines object} \item{y}{SpatialPolygons object} \item{...}{Additional arguments (none)} } \value{ Spatial* } \seealso{The equivalent for raster data is \code{\link{mask}}} \examples{ # erase parts of polygons with other polygons p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) e <- erase(p, b) plot(e) # erase parts of lines with polygons r <- raster(extent(p) +c(-.1,.1,-.1,.1), crs=crs(p)) start <- xyFromCell(r, cellFromCol(r, 1)) end <- xyFromCell(r, cellFromCol(r, ncol(r))) lines <- do.call(spLines, lapply(1:10, function(i)rbind(start[i,], end[i,]))) crs(lines) <- crs(p) e2 <- erase(lines, p) plot(p) lines(lines, col='blue', lwd=4, lty=3) lines(e2, col='red', lwd=2) } \keyword{methods} \keyword{spatial} raster/man/drawExtent.Rd0000644000176200001440000000132014507510157014742 0ustar liggesusers\name{drawExtent} \alias{drawExtent} \title{ Create an Extent object by drawing on a map} \description{ Click on two points of a plot (map) to obtain an object of class \code{\link{Extent}} ('bounding box') } \usage{ drawExtent(show=TRUE, col="red") } \arguments{ \item{show}{logical. If \code{TRUE}, the extent will be drawn on the map} \item{col}{sets the color of the lines of the extent } } \value{ Extent } \examples{ \dontrun{ r1 <- raster(nrow=10, ncol=10) values(r1) <- runif(ncell(r1)) plot(r1) # after running the following line, click on the map twice e <- drawExtent() # after running the following line, click on the map twice mean(values(crop(r1, drawExtent()))) } } \keyword{ spatial } raster/man/atan2.Rd0000644000176200001440000000132314507510157013625 0ustar liggesusers\name{atan2} \alias{atan2,Raster,Raster-method} \alias{atan2} \title{Two argument arc-tangent} \description{ For Raster* objects x and y, atan2(y, x) returns the angle in radians for the tangent y/x, handling the case when x is zero. See \code{\link[base]{Trig}} See \code{\link[raster]{Math-methods}} for other trigonometric and mathematical functions that can be used with Raster* objects. } \usage{ atan2(y, x) } \arguments{ \item{y}{Raster* object} \item{x}{Raster* object} } \seealso{ \code{\link[raster]{Math-methods}} } \examples{ r1 <- r2 <- raster(nrow=10, ncol=10) values(r1) <- (runif(ncell(r1))-0.5) * 10 values(r2) <- (runif(ncell(r1))-0.5) * 10 atan2(r1, r2) } \keyword{methods} \keyword{math} raster/man/hdrFiles.Rd0000644000176200001440000000273514507510157014370 0ustar liggesusers\name{hdr} \alias{hdr} \title{Header files} \description{ Write header files to use together with raster binary files to read the data in other applications. } \usage{ hdr(x, format, extension='.wld', filename='') } \arguments{ \item{x}{RasterLayer or RasterBrick object associated with a binary values file on disk } \item{format}{Type of header file: 'VRT', 'BIL', 'ENVI', 'ErdasRaw', 'IDRISI', 'SAGA', 'RASTER', 'WORLDFILE', 'PRJ' } \item{extension}{File extension, only used with an ESRI worldfile (\code{format='WORLDFILE'})} \item{filename}{character. Need to be provided if \code{x} is not associated with a file} } \details{ The RasterLayer object must be associated with a file on disk. You can use \code{\link{writeRaster}} to save a existing file in another format. But if you have a file in a 'raster' format (or similar), you can also only export a header file, and use the data file (.gri) that already exists. The function can write a VRT (GDAL virtual raster) header (.vrt); an ENVI or BIL header (.hdr) file; an Erdas Raw (.raw) header file; an IDRISI (.rdc) or SAGA (.sgrd). This (hopefully) allows for reading the binary data (.gri), perhaps after changing the file extension, in other programs such as ENVI or ArcGIS. } \seealso{ \code{\link[raster]{writeRaster}}} \examples{ \dontrun{ r <- raster(system.file("external/test.grd", package="raster")) r <- writeRaster(r, filename='export.grd', overwrite=TRUE) hdr(r, format="ENVI") } } \keyword{ spatial } raster/man/writeValues.Rd0000644000176200001440000000637414507510157015145 0ustar liggesusers\name{writeValues} \alias{writeStart} \alias{writeStart,RasterLayer,character-method} \alias{writeStart,RasterBrick,character-method} \alias{writeStop} \alias{writeStop,RasterLayer-method} \alias{writeStop,RasterBrick-method} \alias{writeValues} \alias{writeValues,RasterLayer,vector-method} \alias{writeValues,RasterBrick,matrix-method} \title{Write values to a file} \description{ Functions for writing blocks (>= 1 row(s)) of values to files. Writing has to start at the first cell of a row (identified with argument \code{start}) and the values written must represent 1 or more entire rows. Begin by opening a file with \code{writeStart}, then write values to it in chunks. When writing is done close the file with \code{writeStop}. If you want to write all values of a Raster* object at once, you can also use \code{\link{writeRaster}} which is easier to use but more limited. The functions described here allow writing values to file using chunks of different sizes (e.g. 1 or 10 rows). Function \code{\link{blockSize}} can be used to suggest a chunk size to use. } \usage{ \S4method{writeStart}{RasterLayer,character}(x, filename, options=NULL, format, prj=FALSE, ...) \S4method{writeStart}{RasterBrick,character}(x, filename, options=NULL, format, prj=FALSE, ...) \S4method{writeValues}{RasterLayer,vector}(x, v, start, ...) \S4method{writeValues}{RasterBrick,matrix}(x, v, start, ...) \S4method{writeStop}{RasterLayer}(x) \S4method{writeStop}{RasterBrick}(x) } \arguments{ \item{x}{Raster* object} \item{filename}{character. Output file name} \item{options}{character, see \code{\link{writeRaster}}} \item{format}{character, see \code{\link{writeRaster}}} \item{prj}{logical. If \code{TRUE}, a "prj" file is written} \item{...}{additional arguments as for \code{\link{writeRaster}}} \item{v}{vector (RasterLayer) or matrix (RasterBrick) of values} \item{start}{Integer. Row number (counting starts at 1) from where to start writing \code{v}} } \value{ RasterLayer or RasterBrick } \seealso{ \code{\link{writeRaster}, \link{blockSize}, \link{update}} } \examples{ \dontrun{ r <- raster(system.file("external/test.grd", package="raster")) # write to a new binary file in chunks s <- raster(r) # tr <- blockSize(r) tr s <- writeStart(s, filename='test.grd', overwrite=TRUE) for (i in 1:tr$n) { v <- getValuesBlock(r, row=tr$row[i], nrows=tr$nrows[i]) s <- writeValues(s, v, tr$row[i]) } s <- writeStop(s) s2 <- writeStart(s, filename='test2.tif', format='GTiff', overwrite=TRUE) # writing last row first for (i in tr$n:1) { v <- getValuesBlock(r, row=tr$row[i], nrows=tr$nrows[i]) s2 <- writeValues(s2, v, tr$row[i]) } # row number 5 once more v <- getValuesBlock(r, row=5, nrows=1) writeValues(s2, v, 5) s2 <- writeStop(s2) ## write values of a RasterStack to a RasterBrick s <- stack(system.file("external/rlogo.grd", package="raster")) # create empty brick b <- brick(s, values=FALSE) b <- writeStart(b, filename="test.grd", format="raster",overwrite=TRUE) tr <- blockSize(b) for (i in 1:tr$n) { v <- getValuesBlock(s, row=tr$row[i], nrows=tr$nrows[i]) b <- writeValues(b, v, tr$row[i]) } b <- writeStop(b) # note that the above is equivalent to # b <- writeRaster(s, filename="test.grd", format="raster",overwrite=TRUE) } } \keyword{ spatial } \keyword{ methods } raster/man/Raster-classes.Rd0000644000176200001440000001374714507510157015530 0ustar liggesusers\name{Raster-class} \docType{class} \alias{BasicRaster-class} \alias{Raster-class} \alias{RasterLayer-class} \alias{RasterLayerSparse-class} \alias{RasterStack-class} \alias{RasterBrick-class} \alias{RasterStackBrick-class} \alias{VectorLayer-class} \alias{SpatialVector-class} \alias{print,Raster-method} \alias{show,BasicRaster-method} \alias{show,RasterLayer-method} \alias{show,RasterStack-method} \alias{show,RasterBrick-method} \alias{print,Spatial-method} \title{ Raster* classes} \description{ A raster is a database organized as a rectangular grid that is sub-divided into rectangular cells of equal area (in terms of the units of the coordinate reference system). The 'raster' package defines a number of "S4 classes" to manipulate such data. The main user level classes are \code{RasterLayer}, \code{RasterStack} and \code{RasterBrick}. They all inherit from \code{BasicRaster} and can contain values for the raster cells. An object of the \code{RasterLayer} class refers to a single layer (variable) of raster data. The object can point to a file on disk that holds the values of the raster cells, or hold these values in memory. Or it can not have any associated values at all. A \code{RasterStack} represents a collection of \code{RasterLayer} objects with the same extent and resolution. Organizing \code{RasterLayer} objects in a \code{RasterStack} can be practical when dealing with multiple layers; for example to summarize their values (see \code{\link[raster]{calc}}) or in spatial modeling (see \code{\link[raster]{predict}}). An object of class \code{RasterBrick} can also contain multiple layers of raster data, but they are more tightly related. An object of class \code{RasterBrick} can refer to only a single (multi-layer) data file, whereas each layer in a \code{RasterStack} can refer to another file (or another band in a multi-band file). This has implications for processing speed and flexibility. A \code{RasterBrick} should process quicker than a \code{RasterStack} (irrespective if values are on disk or in memory). However, a \code{RasterStack} is more flexible as a single object can refer to layers that have values stored on disk as well as in memory. If a layer that does not refer to values on disk (they only exists in memory) is added to a \code{RasterBrick}, it needs to load all its values into memory (and this may not be possible because of memory size limitations). Objects can be created from file or from each other with the following functions: \code{\link[raster]{raster}, \link[raster]{brick}} and \link[raster]{stack}. \code{Raster*} objects can also be created from SpatialPixels* and SpatialGrid* objects from the sp package using \code{as}, or simply with the function \code{\link[raster]{raster}}, \code{\link[raster]{brick}}, or \code{\link[raster]{stack}}. Vice versa, \code{Raster*} objects can be coerced into a sp type object with \code{as( , )}, e.g. \code{as(x, 'SpatialGridDataFrame')} . Common generic methods implemented for these classes include: \code{summary}, \code{show}, \code{dim}, and \code{plot, ...} \code{[} is implemented for RasterLayer. The classes described above inherit from the \code{BasicRaster} class which inherits from \code{BasicRaster}. The \code{BasicRaster} class describes the main properties of a raster such as the number of columns and rows, and it contains an object of the \code{link[raster]{Extent-class}} to describe its spatial extent (coordinates). It also holds the 'coordinate reference system' in a slot of class \code{\link[sp]{CRS-class}} defined in the \code{sp} package. A \code{BasicRaster} cannot contain any raster cell values and is therefore seldomly used. The \code{Raster*} class inherits from \code{BasicRaster}. It is a virtual class; which means that you cannot create an object of this class. It is used only to define methods for all the classes that inherit from it (\code{RasterLayer}, \code{RasterStack} and \code{RasterBrick}). Another virtual class is the \code{RasterStackBrick} class. It is formed by a class union of \code{RasterStack} and \code{RasterBrick}. You cannot make objects of it, but methods defined for objects of this class as arguments will accept objects of the \code{RasterLayer} and \code{RasterStack} as that argument. Classes \code{RasterLayer} and \code{RasterBrick} have a slot with an object of class \code{RasterFile} that describes the properties of the file they point to (if they do). \code{RasterLayer} has a slot with an object of class \code{SingleLayerData}, and the \code{RasterBrick} class has a slot with an object of class \code{MultipleLayerData}. These 'datalayer' classes can contain (some of) the values of the raster cells. These classes are not further described here because users should not need to directly access these slots. The 'setter' functions such as \code{setValues} should be used instead. Using such 'setter' functions is much safer because a change in one slot should often affect the values in other slots. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("RasterLayer", ...)}, or with the helper functions such as \code{raster}. } \section{Slots}{ Slots for RasterLayer and RasterBrick objects \describe{ \item{\code{title}:}{Character} \item{\code{file}:}{Object of class \code{".RasterFile"} } \item{\code{data}:}{Object of class \code{".SingleLayerData"} or \code{".MultipleLayerData"}} \item{\code{history}:}{To record processing history, not yet in use } \item{\code{legend}:}{Object of class \code{.RasterLegend}, Default legend. Should store preferences for plotting. Not yet implemented except that it stores the color table of images, if available} \item{\code{extent}:}{Object of \code{\link{Extent-class}} } \item{\code{ncols}:}{Integer} \item{\code{nrows}:}{Integer} \item{\code{crs}:}{Object of class \code{"CRS"}, i.e. the coordinate reference system. In Spatial* objects this slot is called 'proj4string' } } } \examples{ showClass("RasterLayer") } \keyword{classes} \keyword{spatial} raster/man/alignExtent.Rd0000644000176200001440000000207514507510157015107 0ustar liggesusers\name{alignExtent} \alias{alignExtent} \title{Align an extent (object of class Extent)} \description{ Align an Extent object with the (boundaries of the) cells of a Raster* object } \usage{ alignExtent(extent, object, snap='near') } \arguments{ \item{extent}{Extent object} \item{object}{Raster* object} \item{snap}{Character. One of 'near', 'in', or 'out', to determine in which direction the extent should be aligned. To the nearest border, inwards or outwards} } \value{ Extent object } \details{ Aligning an Extent object to another object assures that it gets the same origin and resolution. This should only be used to adjust objects because of imprecision in the data. alignExtent should not be used to force data to match that really does not match (use e.g. \code{\link{resample}} or (dis)aggregate for this). } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{drawExtent}}, \code{\link[raster]{Extent-class}} } \examples{ r <- raster() e <- extent(-10.1, 9.9, -20.1, 19.9) ea <- alignExtent(e, r) e extent(r) ea } \keyword{spatial} raster/man/subset.Rd0000644000176200001440000000231214507510157014124 0ustar liggesusers\name{subset} \alias{subset} \alias{subset,Raster-method} \alias{subset,RasterStack-method} \title{Subset layers in a Raster* object} \description{ Extract a set of layers from a RasterStack or RasterBrick object. } \usage{ \S4method{subset}{Raster}(x, subset, drop=TRUE, filename='', ...) \S4method{subset}{RasterStack}(x, subset, drop=TRUE, filename='', ...) } \arguments{ \item{x}{RasterBrick or RasterStack object} \item{subset}{integer or character. Should indicate the layers (represented as integer or by their name)} \item{drop}{If \code{TRUE}, a selection of a single layer will be returned as a RasterLayer} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ Raster* object } \seealso{ \code{\link[raster:addLayer]{dropLayer}}} \examples{ s <- stack(system.file("external/rlogo.grd", package="raster")) sel <- subset(s, 2:3) # Note that this is equivalent to sel2 <- s[[2:3]] # and in this particular case: sel3 <- dropLayer(s, 1) nlayers(s) nlayers(sel) # effect of 'drop=FALSE' when selecting a single layer sel <- subset(s, 2) class(sel) sel <- subset(s, 2, drop=FALSE) class(sel) } \keyword{ spatial } raster/man/pairs.Rd0000644000176200001440000000216014507510157013736 0ustar liggesusers\name{pairs} \docType{methods} \alias{pairs} \alias{pairs,RasterStackBrick-method} \title{ Pairs plot (matrix of scatterplots) } \description{ Pair plots of layers in a RasterStack or RasterBrick. This is a wrapper around graphics function \code{\link[graphics]{pairs}}. } \usage{ \S4method{pairs}{RasterStackBrick}(x, hist=TRUE, cor=TRUE, use="pairwise.complete.obs", maxpixels=100000, ...) } \arguments{ \item{x}{RasterBrick or RasterStack} \item{hist}{Logical. If TRUE a histogram of the values is shown on the diagonal} \item{cor}{Logical. If TRUE the correlation coefficient is shown in the upper panels} \item{use}{Argument passed to the \code{\link[stats]{cor}} function} \item{maxpixels}{Integer. Number of pixels to sample from each layer of large Raster objects} \item{...}{Additional arguments (only \code{cex} and \code{main})} } \seealso{ \code{\link{boxplot}, \link{hist}, \link{density}} } \examples{ r <- raster(system.file("external/test.grd", package="raster") ) s <- stack(r, 1/r, sqrt(r)) pairs(s) \dontrun{ # to make indvidual histograms: hist(r) # or scatter plots: plot(r, 1/r) } } \keyword{spatial} raster/man/persp.Rd0000644000176200001440000000233714507510157013757 0ustar liggesusers\name{persp} \docType{methods} \alias{persp} \alias{persp,RasterLayer-method} \alias{persp,RasterStackBrick-method} \title{Perspective plot} \description{ Perspective plot of a RasterLayer. This is an implementation of a generic function in the graphics package. } \usage{ \S4method{persp}{RasterLayer}(x, maxpixels=1e+05, ext=NULL, ...) \S4method{persp}{RasterStackBrick}(x, y=1, maxpixels=10000, ext=NULL, ...) } \arguments{ \item{x}{Raster* object} \item{y}{integer \code{> 0 & <= nlayers(x)} to select the layer of \code{x} if \code{x} is a RasterLayer or RasterBrick} \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting} \item{ext}{Extent. Can be used to zoom in to a region (see also \code{\link{zoom}} and \code{\link{crop}(x, \link{drawExtent}())}} \item{...}{Any argument that can be passed to \code{\link[graphics]{persp}} (graphics package)} } \seealso{ \code{\link[rasterVis:plot3d]{plot3D}}, \code{\link[graphics]{persp}}, \code{\link[raster]{contour}}, \code{\link[raster]{plot}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) persp(r) } \keyword{methods} \keyword{spatial} raster/man/which.minmax.Rd0000644000176200001440000000331414507510157015214 0ustar liggesusers\name{which.min} \docType{methods} \alias{which.min} \alias{which.max} \alias{whiches.min} \alias{whiches.max} \alias{which.min,RasterLayer-method} \alias{which.max,RasterLayer-method} \alias{which.min,RasterStackBrick-method} \alias{which.max,RasterStackBrick-method} \alias{whiches.min,RasterStackBrick-method} \alias{whiches.max,RasterStackBrick-method} \title{Where is the min or max value?} \description{Which cells have the minumum / maximum value (for a RasterLayer), or which layer has the minimum/maximum value (for a RasterStack or RasterBrick)? which.min and which.max return the index of the first layer that has the min or max value for a cell. This can be problematic if there are ties. In you want the index of all the layers that have the min or max value, use whiches.min or whiches.max (only for objects with less than 10 layers). } \usage{ which.min(x) which.max(x) whiches.min(x, ...) whiches.max(x, ...) } \arguments{ \item{x}{Raster* object} \item{...}{additional arguments (none implemented)} } \value{ (which.*): vector of cell numbers (if \code{x} is a RasterLayer). If \code{x} is a RasterStack or RasterBrick, a RasterLayer giving the number of the first layer with the minimum or maximum value for a cell. (whiches.*). An integer in which each digit represents a layer. For example, 35 means "layers 3 and 5" } \note{ There is a limit to accurate integer number representation. Therefore, do not use \code{whiches.*} with more than 15 layers. } \seealso{ \code{\link{Which}}} \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) r <- which.min(b) i <- which.min(b[[3]]) xy <- xyFromCell(b, i) plot(b[[3]]) points(xy) x <- whiches.min(b) freq(x) } \keyword{spatial} raster/man/Math-methods.Rd0000644000176200001440000000202314507510157015150 0ustar liggesusers\name{Math-methods} \docType{methods} \alias{Math-methods} \alias{Math2,Extent-method} \alias{Math2,Raster-method} \alias{Math,Raster-method} \alias{Math,RasterLayerSparse-method} \alias{log,Raster-method} \title{Mathematical functions} \description{ Generic mathematical functions that can be used with a Raster* object as argument: \code{"abs", "sign", "sqrt", "ceiling", "floor", "trunc", "cummax", "cummin", } \code{"cumprod", "cumsum", "log", "log10", "log2", "log1p", "acos", "acosh", "asin", } \code{"asinh", "atan", "atanh", "exp", "expm1", "cos", "cosh", "sin", "sinh", "tan", "tanh"}. } \section{Note}{ You can use the, somewhat more flexible, function \code{\link[raster]{calc}} instead of the Math-methods. } \seealso{ \code{\link[raster]{Arith-methods}}, \code{\link{calc}}, \code{\link{overlay}}, \code{\link{atan2}} } \examples{ r1 <- raster(nrow=10, ncol=10) r1 <- setValues(r1, runif(ncell(r1)) * 10) r2 <- sqrt(r1) s <- stack(r1, r2) - 5 b <- abs(s) } \keyword{spatial} \keyword{methods} \keyword{math} raster/man/setValues.Rd0000644000176200001440000000324214507510157014575 0ustar liggesusers\name{setValues} \alias{values<-} \alias{values<-,RasterLayer,ANY-method} \alias{values<-,RasterLayerSparse,ANY-method} \alias{values<-,RasterStack,ANY-method} \alias{values<-,RasterBrick,ANY-method} \alias{setValues} \alias{setValues,RasterLayer-method} \alias{setValues,RasterLayerSparse-method} \alias{setValues,RasterStack-method} \alias{setValues,RasterBrick-method} \title{Set values of a Raster object} \description{ Assign (new) values to a Raster* object. } \usage{ \S4method{setValues}{RasterLayer}(x, values, ...) \S4method{setValues}{RasterBrick}(x, values, layer=-1, ...) \S4method{setValues}{RasterStack}(x, values, layer=-1, ...) \S4method{setValues}{RasterLayerSparse}(x, values, index=NULL, ...) values(x) <- value } \arguments{ \item{x}{A \code{Raster*} } \item{values}{Cell values to associate with the Raster* object. There should be values for all cells} \item{value}{Cell values to associate with the Raster* object. There should be values for all cells} \item{layer}{Layer number (only relevant for RasterBrick and RasterStack objects). If missing, the values of all layers is set} \item{index}{Cell numbers corresponding to the values} \item{...}{Additional arguments (none implemented)} } \seealso{ \code{\link[raster]{replacement}} } \value{ a Raster* object } \note{ While you can access the 'values' slot of the objects directly, you would do that at your own peril because when setting values, multiple slots need to be changed; which is what setValues takes care of. } \examples{ r <- raster(ncol=10, nrow=10) vals <- 1:ncell(r) r <- setValues(r, vals) # equivalent to values(r) <- vals } \keyword{ spatial } \keyword{ methods } raster/man/flowpath.Rd0000644000176200001440000000145014507510157014445 0ustar liggesusers\name{flowPath} \alias{flowPath} \title{Flow path} \description{ Compute the flow path (drainage path) starting at a given point. See package \code{gdistance} for more path computations. } \usage{ flowPath(x, p, ...) } \arguments{ \item{x}{RasterLayer of flow direction (as can be created with \code{\link{terrain}}} \item{p}{starting point. Either two numbers: x (longitude) and y (latitude) coordinates; or a single cell number } \item{...}{additional arguments (none implemented)} } \value{ numeric (cell numbers) } \author{Ashton Shortridge} \examples{ data(volcano) v <- raster(volcano, xmn=2667400, xmx=2668010, ymn=6478700, ymx=6479570, crs="+init=epsg:27200") fd <- terrain(v, opt = "flowdir") path <- flowPath(fd, 2407) xy <- xyFromCell(fd, path) plot(v) lines(xy) } \keyword{spatial} raster/man/extractIndex.Rd0000644000176200001440000000452014507510157015264 0ustar liggesusers\name{Extract by index} \docType{methods} \alias{[[,Raster,ANY,ANY-method} \alias{[,Raster,Spatial,missing-method} \alias{[,Raster,RasterLayer,missing-method} \alias{[,Raster,Extent,missing-method} \alias{[,Raster,numeric,numeric-method} \alias{[,Raster,numeric,missing-method} \alias{[,Raster,missing,numeric-method} \alias{[,Raster,matrix,missing-method} \alias{[,Raster,missing,missing-method} \alias{[,Raster,logical,missing-method} \alias{[,Extent,numeric,missing-method} \alias{[,Extent,missing,missing-method} \title{Indexing to extract values of a Raster* object} \description{ These are shorthand methods that call other methods that should normally be used, such as \code{\link{getValues}}, \code{\link{extract}}, \code{\link{crop}}. \code{object[i]} can be used to access values of a Raster* object, using cell numbers. You can also use row and column numbers as index, using \code{object[i,j]} or \code{object[i,]} or \code{object[,j]}. In addition you can supply an Extent, SpatialPolygons, SpatialLines or SpatialPoints object. If \code{drop=TRUE} (the default) cell values are returned (a vector for a RasterLayer, a matrix for a RasterStack or RasterBrick). If \code{drop=FALSE} a Raster* object is returned that has the extent covering the requested cells, and with all other non-requested cells within this extent set to \code{NA}. If you supply a RasterLayer, its values will be used as logical (TRUE/FALSE) indices if both Raster objects have the same extent and resolution; otherwise the cell values within the extent of the RasterLayer are returned. Double brackes '[[ ]]' can be used to extract one or more layers from a multi-layer object. } \section{Methods}{ \describe{ \code{x[i]} \code{x[i,j]} Arguments \tabular{rll}{ \tab \code{x} \tab a Raster* object \cr \tab \code{i} \tab cell number(s), row number(s), a (logical) RasterLayer, Spatial* object \cr \tab \code{j} \tab column number(s) (only available if i is (are) a row number(s)) \cr \tab \code{drop} \tab If \code{TRUE}, cell values are returned. Otherwise, a Raster* object is returned \cr } }} \seealso{ \code{\link{getValues}, \link{setValues}, \link{extract}, \link{crop}, \link{rasterize}} } \examples{ r <- raster(ncol=10, nrow=5) values(r) <- 1:ncell(r) r[1] r[1:10] r[1,] r[,1] r[1:2, 1:2] s <- stack(r, sqrt(r)) s[1:3] s[[2]] } \keyword{methods} \keyword{spatial} raster/man/projection.Rd0000644000176200001440000000322014507510157014772 0ustar liggesusers\name{projection} \alias{wkt} \alias{wkt,ANY-method} \alias{wkt,Raster-method} \alias{crs} \alias{crs,ANY-method} \alias{crs<-} \alias{projection} \alias{projection<-} \alias{proj4string} \alias{proj4string,BasicRaster-method} \alias{proj4string,CRS-method} \alias{proj4string<-} \alias{as.character,CRS-method} \alias{is.na,CRS-method} \alias{crs<-,BasicRaster-method} \alias{crs<-,Spatial-method} \title{ Get or set a coordinate reference system (projection) } \description{ Get or set the coordinate reference system (CRS) of a Raster* object. } \usage{ \S4method{crs}{ANY}(x, asText=FALSE, ...) \S4method{wkt}{Raster}(obj) crs(x, ...) <- value projection(x, asText=TRUE) projection(x) <- value } \arguments{ \item{x}{Raster* or Spatial object } \item{obj}{Raster*, Spatial, or CRS object } \item{asText}{logical. If \code{TRUE}, the projection is returned as text. Otherwise a \code{\link[sp]{CRS-class}} object is returned} \item{...}{additional arguments. None implemented} \item{value}{\code{CRS} object or a character string describing a projection and datum in the PROJ.4 format } } \value{ Raster*, Spatial*, or character object } \note{ \code{crs} replaces earlier function \code{projection}. For compatibility with \code{sp} you can use \code{proj4string} instead of \code{crs}. \code{wkt} returns the "well-known-text" representation of the crs. } \seealso{ \code{\link[raster]{projectRaster}, \link[sp]{spTransform}}} \details{ projections are done by with the PROJ library } \examples{ r <- raster() crs(r) crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +datum=WGS84" crs(r) w <- wkt(r) w cat(w, "\n") } \keyword{ spatial } raster/man/draw.Rd0000644000176200001440000000152414507510157013560 0ustar liggesusers\name{draw} \alias{drawPoly} \alias{drawLine} \title{ Draw a line or polygon } \description{ Draw a line or polygon on a plot (map) and save it for later use. After calling the function, start clicking on the map. To finish, right-click and select 'stop'. } \usage{ drawPoly(sp=TRUE, col='red', lwd=2, ...) drawLine(sp=TRUE, col='red', lwd=2, ...) } \arguments{ \item{sp}{logical. If \code{TRUE}, the output will be a sp object (SpatialPolygons or SpatialLines). Otherwise a matrix of coordinates is returned} \item{col}{the color of the lines to be drawn} \item{lwd}{the width of the lines to be drawn} \item{...}{additional arguments padded to locator} } \value{ If \code{sp==TRUE} a SpatialPolygons or SpatialLines object; otherwise a matrix of coordinates } \seealso{ \code{\link[graphics]{locator}} } \keyword{ spatial } raster/man/calc.Rd0000644000176200001440000001224314507510157013525 0ustar liggesusers\name{calc} \docType{methods} \alias{calc} \alias{calc,Raster,function-method} \title{Calculate} \description{ Calculate values for a new Raster* object from another Raster* object, using a formula. If \code{x} is a RasterLayer, \code{fun} is typically a function that can take a single vector as input, and return a vector of values of the same length (e.g. \code{sqrt}). If \code{x} is a RasterStack or RasterBrick, fun should operate on a vector of values (one vector for each cell). \code{calc} returns a RasterLayer if \code{fun} returns a single value (e.g. \code{sum}) and it returns a RasterBrick if \code{fun} returns more than one number, e.g., \code{fun=quantile}. In many cases, what can be achieved with \code{calc}, can also be accomplished with a more intuitive 'raster-algebra' notation (see \code{\link[raster]{Arith-methods}}). For example, \code{r <- r * 2} instead of \code{r <- calc(r, fun=function(x){x * 2}}, or \code{r <- sum(s)} instead of \code{r <- calc(s, fun=sum)}. However, \code{calc} should be faster when using complex formulas on large datasets. With \code{calc} it is possible to set an output filename and file type preferences. See (\code{\link[raster]{overlay}}) to use functions that refer to specific layers, like (\code{function(a,b,c){a + sqrt(b) / c}}) } \usage{ \S4method{calc}{Raster,function}(x, fun, filename='', na.rm, forcefun=FALSE, forceapply=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{fun}{function} \item{filename}{character. Output filename (optional)} \item{na.rm}{Remove \code{NA} values, if supported by 'fun' (only relevant when summarizing a multilayer Raster object into a RasterLayer)} \item{forcefun}{logical. Force \code{calc} to not use fun with apply; for use with ambiguous functions and for debugging (see Details)} \item{forceapply}{logical. Force \code{calc} to use fun with apply; for use with ambiguous functions and for debugging (see Details)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ a Raster* object } \details{ The intent of some functions can be ambiguous. Consider: \code{library(raster)} \code{r <- raster(volcano)} \code{calc(r, function(x) x * 1:10)} In this case, the cell values are multiplied in a vectorized manner and a single layer is returned where the first cell has been multiplied with one, the second cell with two, the 11th cell with one again, and so on. But perhaps the intent was to create 10 new layers (\code{x*1, x*2, ...})? This can be achieved by using argument \code{forceapply=TRUE} \code{calc(r, function(x) x * 1:10, forceapply=TRUE)} } \note{ For large objects \code{calc} will compute values chunk by chunk. This means that for the result of \code{fun} to be correct it should not depend on having access to _all_ values at once. For example, to scale the values of a Raster* object by subtracting its mean value (for each layer), you would _not_ do, for Raster object \code{x}: \code{calc(x, function(x)scale(x, scale=FALSE))} Because the mean value of each chunk will likely be different. Rather do something like \code{m <- cellStats(x, 'mean')} \code{x - m} } \seealso{ \code{ \link[raster]{overlay}} , \code{ \link[raster]{reclassify}}, \link[raster]{Arith-methods}, \link[raster]{Math-methods}} \author{Robert J. Hijmans and Matteo Mattiuzzi} \examples{ r <- raster(ncols=36, nrows=18) values(r) <- 1:ncell(r) # multiply values with 10 fun <- function(x) { x * 10 } rc1 <- calc(r, fun) # set values below 100 to NA. fun <- function(x) { x[x<100] <- NA; return(x) } rc2 <- calc(r, fun) # set NA values to -9999 fun <- function(x) { x[is.na(x)] <- -9999; return(x)} rc3 <- calc(rc2, fun) # using a RasterStack as input s <- stack(r, r*2, sqrt(r)) # return a RasterLayer rs1 <- calc(s, sum) # return a RasterBrick rs2 <- calc(s, fun=function(x){x * 10}) # recycling by layer rs3 <- calc(s, fun=function(x){x * c(1, 5, 10)}) # use overlay when you want to refer to individual layer in the function # but it can be done with calc: rs4 <- calc(s, fun=function(x){x[1]+x[2]*x[3]}) ## # Some regression examples ## # create data r <- raster(nrow=10, ncol=10) s1 <- lapply(1:12, function(i) setValues(r, rnorm(ncell(r), i, 3))) s2 <- lapply(1:12, function(i) setValues(r, rnorm(ncell(r), i, 3))) s1 <- stack(s1) s2 <- stack(s2) # regression of values in one brick (or stack) with another s <- stack(s1, s2) # s1 and s2 have 12 layers; coefficients[2] is the slope fun <- function(x) { lm(x[1:12] ~ x[13:24])$coefficients[2] } x1 <- calc(s, fun) # regression of values in one brick (or stack) with 'time' time <- 1:nlayers(s) fun <- function(x) { lm(x ~ time)$coefficients[2] } x2 <- calc(s, fun) # get multiple layers, e.g. the slope _and_ intercept fun <- function(x) { lm(x ~ time)$coefficients } x3 <- calc(s, fun) ### A much (> 100 times) faster approach is to directly use ### linear algebra and pre-compute some constants ## add 1 for a model with an intercept X <- cbind(1, time) ## pre-computing constant part of least squares invXtX <- solve(t(X) \%*\% X) \%*\% t(X) ## much reduced regression model; [2] is to get the slope quickfun <- function(y) (invXtX \%*\% y)[2] x4 <- calc(s, quickfun) } \keyword{methods} \keyword{spatial} raster/man/movingFun.Rd0000644000176200001440000000336414511777071014604 0ustar liggesusers\name{movingFun} \alias{movingFun} \title{Moving functions} \description{ Helper function to compute 'moving' functions, such as the 'moving average' } \usage{ movingFun(x, n, fun=mean, type='around', circular=FALSE, na.rm=FALSE) } \arguments{ \item{x}{A vector of numbers} \item{n}{Size of the 'window', i.e. the number of sequential elements to use in the function} \item{fun}{A function like mean, min, max, sum} \item{type}{Character. One of 'around', 'to', or 'from'. The choice indicates which values should be used in the computation. The focal element is always used. If \code{type} is 'around', the other elements are before and after the focal element. Alternatively, you can select the elements preceding the focal element ('to') or those coming after it ('from'). For example, to compute the movingFun with \code{n=3} for element 5 of a vector; 'around' used elements 4,5,6; 'to' used elements 3,4,5, and 'from' uses elements 5,6,7} \item{circular}{Logical. If \code{TRUE}, the data are considered to have a circular nature (e.g. months of the year), and the last elements in vector \code{x} are used in the computation of the moving function of the first element(s) of the vector, and the first elements are used in the computation of the moving function for the last element(s)} \item{na.rm}{Logical. If \code{TRUE}, \code{NA} values should be ingored (by \code{fun})} } \value{ Numeric } \author{Robert J. Hijmans, inspired by Diethelm Wuertz' rollFun function in the fTrading package} \examples{ movingFun(1:12, 3, mean) movingFun(1:12, 3, mean, 'to') movingFun(1:12, 3, mean, 'from') movingFun(1:12, 3, mean, circular=TRUE) v <- c(0,1,2,3,3,3,3,4,4,4,5,5,6,7,7,8,9,NA) movingFun(v, n=5) movingFun(v, n=5, na.rm=TRUE) } \keyword{spatial} raster/man/clamp.Rd0000644000176200001440000000205514507510157013717 0ustar liggesusers\name{clamp} \alias{clamp} \alias{clamp,Raster-method} \alias{clamp,numeric-method} \title{Clamp values} \description{ Clamp values to a minimum and maximum value. That is, all values below the lower clamp value and above the upper clamp value become NA (or the lower/upper value if \code{useValue=TRUE}) } \usage{ \S4method{clamp}{Raster}(x, lower=-Inf, upper=Inf, useValues=TRUE, filename="", ...) \S4method{clamp}{numeric}(x, lower=-Inf, upper=Inf, ...) } \arguments{ \item{x}{RasterLayer, or numeric vector} \item{lower}{numeric. lowest value} \item{upper}{numeric. highest value} \item{useValues}{logical. If \code{FALSE} values outside the clamping range become \code{NA}, if \code{TRUE}, they get the extreme values} \item{filename}{character. Filename for the output RasterLayer (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ Raster object } \seealso{ \code{\link{reclassify}} } \examples{ r <- raster(ncols=12, nrows=12) values(r) <- 1:ncell(r) rc <- clamp(r, 25, 75) rc } \keyword{spatial} raster/man/compare.Rd0000644000176200001440000000400614507510157014247 0ustar liggesusers\name{compareRaster} \alias{compareRaster} \alias{all.equal,Raster,Raster-method} \title{Compare Raster objects} \description{ Evaluate whether a two or more Raster* objects have the same extent, number of rows and columns, projection, resolution, and origin (or a subset of these comparisons). all.equal is a wrapper around compareRaster with options \code{values=TRUE}, \code{stopiffalse=FALSE} and \code{showwarning=TRUE}. } \usage{ compareRaster(x, ..., extent=TRUE, rowcol=TRUE, crs=TRUE, res=FALSE, orig=FALSE, rotation=TRUE, values=FALSE, tolerance, stopiffalse=TRUE, showwarning=FALSE) } \arguments{ \item{x}{Raster* object } \item{...}{Raster* objects} \item{extent}{logical. If \code{TRUE}, bounding boxes are compared} \item{rowcol}{logical. If \code{TRUE}, number of rows and columns of the objects are compared} \item{crs}{logical. If \code{TRUE}, coordinate reference systems are compared.} \item{res}{logical. If \code{TRUE}, resolutions are compared (redundant when checking extent and rowcol)} \item{orig}{logical. If \code{TRUE}, origins are compared} \item{rotation}{logical. If \code{TRUE}, rotations are compared} \item{values}{logical. If \code{TRUE}, cell values are compared} \item{tolerance}{numeric between 0 and 0.5. If not supplied, the default value is used (see \code{\link{rasterOptions}}. It sets difference (relative to the cell resolution) that is permissible for objects to be considered 'equal', if they have a non-integer origin or resolution. See \link{all.equal}. } \item{stopiffalse}{logical. If \code{TRUE}, an error will occur if the objects are not the same} \item{showwarning}{logical. If \code{TRUE}, an warning will be given if objects are not the same. Only relevant when \code{stopiffalse} is \code{TRUE}} } \examples{ r1 <- raster() r2 <- r1 r3 <- r1 compareRaster(r1, r2, r3) nrow(r3) <- 10 # compareRaster(r1, r3) compareRaster(r1, r3, stopiffalse=FALSE) compareRaster(r1, r3, rowcol=FALSE) all.equal(r1, r2) all.equal(r1, r3) } \keyword{ spatial } raster/man/extension.Rd0000644000176200001440000000163414507510157014641 0ustar liggesusers\name{extension} \alias{extension} \alias{extension<-} \title{Filename extensions} \description{ Get or change a filename extension } \usage{ extension(filename, value=NULL, maxchar=10) extension(filename) <- value } \arguments{ \item{filename}{A filename, with or without the path} \item{value}{A file extension with or without a dot, e.g., ".txt" or "txt"} \item{maxchar}{Maximum number of characters after the last dot in the filename, for that string to be considered a filename extension } } \value{ A file extension, filename or path. If \code{ext(filename)} is used without a \code{value} argument, it returns the file extension; otherwise it returns the filename (with new extensions set to \code{value} } \examples{ fn <- "c:/temp folder/filename.exten sion" extension(fn) extension(fn) <- ".txt" extension(fn) fn <- extension(fn, '.document') extension(fn) extension(fn, maxchar=4) } \keyword{file} raster/man/zonal.Rd0000644000176200001440000000422414507510157013746 0ustar liggesusers\name{zonal} \alias{zonal} \alias{zonal,RasterLayer,RasterLayer-method} \alias{zonal,RasterStackBrick,RasterLayer-method} \title{Zonal statistics} \description{ Compute zonal statistics, that is summarized values of a Raster* object for each "zone" defined by a RasterLayer. If \code{stat} is a true \code{function}, \code{zonal} will fail (gracefully) for very large Raster objects, but it will in most cases work for functions that can be defined as by a character argument ('mean', 'sd', 'min', 'max', or 'sum'). In addition you can use 'count' to count the number of cells in each zone (only useful with \code{na.rm=TRUE}, otherwise \code{freq(z)} would be more direct. If a function is used, it should accept a \code{na.rm} argument (or at least a \code{...} argument) } \usage{ \S4method{zonal}{RasterLayer,RasterLayer}(x, z, fun='mean', digits=0, na.rm=TRUE, ...) \S4method{zonal}{RasterStackBrick,RasterLayer}(x, z, fun='mean', digits=0, na.rm=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{z}{RasterLayer with codes representing zones} \item{fun}{function to be applied to summarize the values by zone. Either as character: 'mean', 'sd', 'min', 'max', 'sum'; or, for relatively small Raster* objects, a proper function} \item{digits}{integer. Number of digits to maintain in 'zones'. By default averaged to an integer (zero digits)} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values in \code{x} are ignored} \item{...}{additional arguments. One implemented: \code{progress}, as in \code{\link{writeRaster}}} } \value{ A matrix with a value for each zone (unique value in \code{zones}) } \seealso{ See \code{\link{cellStats}} for 'global' statistics (i.e., all of \code{x} is considered a single zone), and \code{\link{extract}} for summarizing values for polygons} \examples{ r <- raster(ncols=10, nrows=10) values(r) <- runif(ncell(r)) * 1:ncell(r) z <- r values(z) <- rep(1:5, each=20) # for large files, use a character value rather than a function zonal(r, z, 'sum') # for smaller files you can also provide a function \dontrun{ zonal(r, z, mean) zonal(r, z, min) } # multiple layers zonal(stack(r, r*10), z, 'sum') } \keyword{spatial} raster/man/Summary-methods.Rd0000644000176200001440000000317714507510157015727 0ustar liggesusers\name{Summary-methods} \docType{methods} \alias{Summary-methods} \alias{mean,Raster-method} \alias{median,Raster-method} \alias{Summary,Raster-method} \title{ Summary methods } \description{ The following summary methods are available for Raster* objects: \code{mean, median, max, min, range, prod, sum, any, all} All methods take \code{na.rm} as an additional logical argument. Default is \code{na.rm=FALSE}. If \code{TRUE}, \code{NA} values are removed from calculations. These methods compute a summary statistic based on cell values of RasterLayers and the result of these methods is always a single RasterLayer (except for range, which returns a RasterBrick with two layers). See \code{\link{calc}} for functions not included here (e.g. median) or any other custom functions. You can mix RasterLayer, RasterStack and RasterBrick objects with single numeric or logical values. However, because generic functions are used, the method applied is chosen based on the first argument: '\code{x}'. This means that if \code{r} is a RasterLayer object, \code{mean(r, 5)} will work, but \code{mean(5, r)} will not work. To summarize all cells within a single RasterLayer, see \code{\link[raster]{cellStats}} and \code{\link[raster:extremeValues]{maxValue}} and \code{\link[raster:extremeValues]{minValue}} } \value{a RasterLayer} \seealso{ \code{\link{calc}} } \examples{ r1 <- raster(nrow=10, ncol=10) r1 <- setValues(r1, runif(ncell(r1))) r2 <- setValues(r1, runif(ncell(r1))) r3 <- setValues(r1, runif(ncell(r1))) r <- max(r1, r2, r3) r <- range(r1, r2, r3, 1.2) s <- stack(r1, r2, r3) r <- mean(s, 2) } \keyword{methods} \keyword{spatial} raster/man/setMinMax.Rd0000644000176200001440000000125014507510157014524 0ustar liggesusers\name{setMinMax} \alias{setMinMax,RasterLayer-method} \alias{setMinMax,RasterStack-method} \alias{setMinMax,RasterBrick-method} \alias{setMinMax} \title{Compute min and max values} \description{ The minimum and maximum value of a RasterLayer are computed (from a file on disk if necessary) and stored in the returned Raster* object. } \usage{ setMinMax(x, ...) } \arguments{ \item{x}{Raster object } \item{\dots}{additional arguments, none implemented} } \value{ Raster object } \seealso{ \code{\link[raster]{getValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) r r <- setMinMax(r) r } \keyword{ spatial } \keyword{ methods } raster/man/rasterToPolygons.Rd0000644000176200001440000000234414507510157016162 0ustar liggesusers\name{rasterToPolygons} \alias{rasterToPolygons} \title{ Raster to polygons conversion} \description{ Raster to polygons conversion. Cells with NA are not converted. A function can be used to select a subset of the raster cells (by their values). } \usage{ rasterToPolygons(x, fun=NULL, n=4, na.rm=TRUE, digits=12, dissolve=FALSE) } \arguments{ \item{x}{ Raster* object } \item{fun}{ function to select a subset of raster values (only allowed if \code{x} has a single layer)} \item{n}{ integer. The number of nodes for each polygon. Only 4, 8, and 16 are allowed } \item{na.rm}{ If \code{TRUE}, cells with \code{NA} values in all layers are ignored } \item{digits}{ number of digits to round the coordinates to } \item{dissolve}{logical. If \code{TRUE}, polygons with the same attribute value will be dissolved into multi-polygon regions} } \details{ \code{fun} should be a simple function returning a logical value. E.g.: \code{fun=function(x){x==1}} or \code{fun=function(x){x>3 & x<6}} } \value{ SpatialPolygonsDataFrame } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) * 10 r[r>8] <- NA pol <- rasterToPolygons(r, fun=function(x){x>6}) #plot(r > 6) #plot(pol, add=TRUE, col='red') } \keyword{ spatial } raster/man/Arith-methods.Rd0000644000176200001440000000601414507510157015332 0ustar liggesusers\name{Arith-methods} \docType{methods} \alias{Arith-methods} \alias{Arith,Extent,numeric-method} \alias{Arith,Raster,Raster-method} \alias{Arith,Raster,missing-method} \alias{Arith,RasterLayer,logical-method} \alias{Arith,RasterLayer,numeric-method} \alias{Arith,RasterLayerSparse,numeric-method} \alias{Arith,RasterStackBrick,logical-method} \alias{Arith,RasterStackBrick,numeric-method} \alias{Arith,logical,RasterLayer-method} \alias{Arith,logical,RasterStackBrick-method} \alias{Arith,numeric,Extent-method} \alias{Arith,numeric,RasterLayer-method} \alias{Arith,numeric,RasterLayerSparse-method} \alias{Arith,numeric,RasterStackBrick-method} \alias{+,SpatialPolygons,SpatialPolygons-method} \alias{+,SpatialLines,SpatialLines-method} \alias{+,SpatialPoints,SpatialPoints-method} \alias{-,SpatialPolygons,SpatialPolygons-method} \alias{*,SpatialPolygons,SpatialPolygons-method} \title{Arithmetic with Raster* objects} \description{ Standard arithmetic operators for computations with Raster* objects and numeric values. The following operators are available: \code{ +, -, *, /, ^, \%\%, \%/\% } The input Raster* objects should have the same extent, origin and resolution. If only the extent differs, the computation will continue for the intersection of the Raster objects. Operators are applied on a cell by cell basis. For a RasterLayer, numeric values are recycled by row. For a RasterStack or RasterBrick, recycling is done by layer. RasterLayer objects can be combined RasterStack/Brick objects, in which case the RasterLayer is 'recycled'. When using multiple RasterStack or RasterBrick objects, the number of layers of these objects needs to be the same. In addition to arithmetic with Raster* objects, the following operations are supported for SpatialPolygons* objects. Given SpatialPolygon objects \code{x} and \code{y}: \code{x+y} is the same as \code{\link{union}(x, y)}. For SpatialLines* and SpatialPoints* it is equivalent to \code{\link{bind}(x, y)} \code{x*y} is the same as \code{\link{intersect}(x, y)} \code{x-y} is the same as \code{\link{erase}(x, y)} } \details{ If the values of the output Raster* cannot be held in memory, they will be saved to a temporary file. You can use \code{\link{options}} to set the default file format, datatype and progress bar. } \value{ A Raster* object, and in some cases the side effect of a new file on disk. } \seealso{ \code{\link[raster]{Math-methods}}, \code{\link[raster]{overlay}}, \code{\link[raster]{calc}} } \examples{ r1 <- raster(ncols=10, nrows=10) values(r1) <- runif(ncell(r1)) r2 <- setValues(r1, 1:ncell(r1) / ncell(r1) ) r3 <- r1 + r2 r2 <- r1 / 10 r3 <- r1 * (r2 - 1 + r1^2 / r2) # recycling by row r4 <- r1 * 0 + 1:ncol(r1) # multi-layer object mutiplication, no recycling b1 <- brick(r1, r2, r3) b2 <- b1 * 10 # recycling by layer b3 <- b1 + c(1, 5, 10) # addition of the cell-values of two RasterBrick objects b3 <- b2 + b1 # summing two RasterBricks and one RasterLayer. The RasterLayer is 'recycled' b3 <- b1 + b2 + r1 } \keyword{methods} \keyword{math} \keyword{spatial} raster/man/geom.Rd0000644000176200001440000000327514507510157013557 0ustar liggesusers\name{geom} \docType{methods} \alias{geom} \alias{geom,SpatialPolygons-method} \alias{geom,SpatialLines-method} \alias{geom,SpatialPoints-method} \alias{geom,data.frame-method} \title{Get the coordinates of a vector type Spatial* object} \description{ Extract the coordinates of a Spatial object } \usage{ \S4method{geom}{SpatialPolygons}(x, sepNA=FALSE, ...) \S4method{geom}{SpatialLines}(x, sepNA=FALSE, ...) \S4method{geom}{SpatialPoints}(x, ...) \S4method{geom}{data.frame}(x, d, gt, crs, ...) } \arguments{ \item{x}{SpatialPolygons*, SpatialLines*, or SpatialPoints* object; or a data.frame} \item{sepNA}{logical. If \code{TRUE}, geometries are separated by a row with \code{NA} values} \item{...}{additional arguments, none implemented} \item{d}{data.frame that matches the number of objects in data.frame \code{x}} \item{gt}{character. geometry type. Must be one of "polygons", "lines", "points"} \item{crs}{character. PROJ.4 crs string} } \value{ Matrix with 6, (5 SpatialLines), or 3 (SpatialPoints) columns. object (sequential object number) part (sequential part number within the object; not for SpatialPoints), cump (cumulative part number; not for SpatialPoints), hole (is this a hole or not; only for SpatialPolygons), x (x coordinate or longitude), y (y coordinate or latitude) } \seealso{ \code{\link[sp]{coordinates}}, \code{\link[sp:geometry-methods]{geometry}} } \examples{ p <- readRDS(system.file("external/lux.rds", package="raster")) x <- geom(p) head(x) # and back to a SpatialPolygonsDataFrame x <- data.frame(x) sp <- as(x, "SpatialPolygons") crs(sp) <- crs(p) spdf <- SpatialPolygonsDataFrame(sp, data.frame(p), match.ID=FALSE) } \keyword{methods} \keyword{spatial} raster/man/localFun.Rd0000644000176200001440000000270314507510157014366 0ustar liggesusers\name{localFun} \docType{methods} \alias{localFun} \alias{localFun,RasterLayer,RasterLayer-method} \title{Local functions} \description{ Local functions for two RasterLayer objects (using a focal neighborhood) } \usage{ \S4method{localFun}{RasterLayer,RasterLayer}(x, y, ngb=5, fun, filename='', ...) } \arguments{ \item{x}{RasterLayer or RasterStack/RasterBrick} \item{y}{object of the same class as \code{x}, and with the same number of layers} \item{ngb}{integer. rectangular neighbourhood size. Either a single integer or a vector of two integers c(rows, cols), such as c(3,3) to have a 3 x 3 focal window} \item{fun}{function} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \note{The first two arguments that \code{fun} needs to accept are vectors representing the local cells of RasterLayer \code{x} and \code{y} (each of length \code{ngb * ngb}). It also must have an ellipsis (\code{...}) argument} \value{ RasterLayer } \seealso{ \code{\link{corLocal}}, \code{\link{localFun}} } \examples{ set.seed(0) b <- stack(system.file("external/rlogo.grd", package="raster")) x <- flip(b[[2]], 'y') + runif(ncell(b)) y <- b[[1]] + runif(ncell(b)) f <- localFun(x, y, fun=cor) \dontrun{ # local regression: rfun <- function(x, y, ...) { m <- lm(y~x) # return R^2 summary(m)$r.squared } ff <- localFun(x, y, fun=rfun) plot(f, ff) } } \keyword{methods} \keyword{spatial} raster/man/summary.Rd0000644000176200001440000000131114507510157014312 0ustar liggesusers\name{Summary} \docType{methods} \alias{summary,RasterLayer-method} \alias{summary,RasterStackBrick-method} \title{Summary} \description{ Summarize a Raster* object. A sample is used for very large files. } \usage{ \S4method{summary}{RasterLayer}(object, maxsamp=100000, ...) } \arguments{ \item{object}{Raster* object} \item{maxsamp}{positive integer. Sample size used for large datasets} \item{...}{additional arguments. None implemented} } \value{matrix with (an estimate of) the median, minimum and maximum values, the first and third quartiles, and the number of cells with \code{NA} values} \seealso{ \code{\link{cellStats}, link[raster]{quantile}} } \keyword{methods} \keyword{spatial} raster/man/sampleRegular.Rd0000644000176200001440000000251514507510157015427 0ustar liggesusers\name{sampleRegular} \alias{sampleRegular} \alias{sampleRegular,Raster-method} \title{Regular sample} \description{ Take a systematic sample from a Raster* object. } \usage{ \S4method{sampleRegular}{Raster}(x, size, ext=NULL, cells=FALSE, xy=FALSE, asRaster=FALSE, sp=FALSE, ...) } \arguments{ \item{x}{Raster object} \item{size}{positive integer giving the number of items to choose.} \item{ext}{Extent. To limit regular sampling to the area within that box} \item{cells}{logical. Also return sampled cell numbers (if asRaster=FALSE) } \item{xy}{logical. If \code{TRUE}, coordinates of sampled cells are also returned} \item{asRaster}{logical. If \code{TRUE}, a RasterLayer or RasterBrick is returned, rather than the sampled values} \item{sp}{logical. If \code{TRUE}, a SpatialPointsDataFrame is returned} \item{...}{additional arguments. None implemented} } \value{ A vector (single layer object), matrix (multi-layered object; or if \code{cells=TRUE}, or \code{xy=TRUE}), Raster* object (if \code{asRaster=TRUE}), or SpatialPointsDataFrame (if \code{sp=TRUE}) } \seealso{\code{\link{sampleRandom}}, \link{sampleStratified}} \examples{ r <- raster(system.file("external/test.grd", package="raster")) v <- sampleRegular(r, size=100) x <- sampleRegular(r, size=100, asRaster=TRUE) } \keyword{spatial} raster/man/layerStats.Rd0000644000176200001440000000377414507510157014767 0ustar liggesusers\name{layerStats} \alias{layerStats} \title{Correlation and (weighted) covariance} \description{ Compute correlation and (weighted) covariance for multi-layer Raster objects. Like \code{\link{cellStats}} this function returns a few values, not a Raster* object (see \code{\link{Summary-methods}} for that). } \usage{ layerStats(x, stat, w, asSample=TRUE, na.rm=FALSE, ...) } \arguments{ \item{x}{RasterStack or RasterBrick for which to compute a statistic} \item{stat}{Character. The statistic to compute: either 'cov' (covariance), 'weighted.cov' (weighted covariance), or 'pearson' (correlation coefficient)} \item{w}{RasterLayer with the weights (should have the same extent, resolution and number of layers as \code{x}) to compute the weighted covariance} \item{asSample}{Logical. If \code{TRUE}, the statistic for a sample (denominator is \code{n-1}) is computed, rather than for the population (denominator is \code{n})} \item{na.rm}{Logical. Should missing values be removed?} \item{...}{Additional arguments (none implemetned)} } \value{ List with two items: the correlation or (weighted) covariance matrix, and the (weighted) means. } \author{Jonathan A. Greenberg & Robert Hijmans. Weighted covariance based on code by Mort Canty} \references{ For the weighted covariance: \itemize{ \item {Canty, M.J. and A.A. Nielsen, 2008. Automatic radiometric normalization of multitemporal satellite imagery with the iteratively re-weighted MAD transformation. Remote Sensing of Environment 112:1025-1036.} \item {Nielsen, A.A., 2007. The regularized iteratively reweighted MAD method for change detection in multi- and hyperspectral data. IEEE Transactions on Image Processing 16(2):463-478.} } } \seealso{ \code{\link{cellStats}}, \code{\link{cov.wt}}, \code{\link[raster]{weighted.mean}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) layerStats(b, 'pearson') layerStats(b, 'cov') # weigh by column number w <- init(b, v='col') layerStats(b, 'weighted.cov', w=w) } raster/man/rasterFromCells.Rd0000644000176200001440000000205614507510157015733 0ustar liggesusers\name{rasterFromCells} \alias{rasterFromCells} \title{Subset a raster by cell numbers} \description{ This function returns a new raster based on an existing raster and cell numbers for that raster. The new raster is cropped to the cell numbers provided, and, if \code{values=TRUE} has values that are the cell numbers of the original raster. } \usage{ rasterFromCells(x, cells, values=TRUE) } \arguments{ \item{x}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{cells}{vector of cell numbers} \item{values}{Logical. If \code{TRUE}, the new RasterLayer has cell values that correspond to the cell numbers of \code{x}} } \details{ Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \value{ RasterLayer } \seealso{ \code{\link[raster]{rowFromCell}} } \examples{ r <- raster(ncols=100, nrows=100) cells <- c(3:5, 210) r <- rasterFromCells(r, cells) cbind(1:ncell(r), getValues(r)) } \keyword{spatial} raster/man/validCell.Rd0000644000176200001440000000135714507510157014526 0ustar liggesusers\name{validCell} \alias{validCell} \alias{validCol} \alias{validRow} \title{Validity of a cell, column or row number} \description{ Simple helper functions to determine if a row, column or cell number is valid for a certain Raster* object } \usage{ validCell(object, cell) validCol(object, colnr) validRow(object, rownr) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{cell}{cell number(s)} \item{colnr}{column number; or vector of column numbers} \item{rownr}{row number; or vector of row numbers} } \value{ logical value } \examples{ #using a new default raster (1 degree global) r <- raster() validCell(r, c(-1, 0, 1)) validRow(r, c(-1, 1, 100, 10000)) } \keyword{spatial} raster/man/writeFormats.Rd0000644000176200001440000000300514507510157015305 0ustar liggesusers\name{writeFormats} \alias{writeFormats} \title{File types for writing} \description{ List supported file types for writing RasterLayer values to disk. When a function writes a file to disk, the file format is determined by the 'format=' argument if supplied, or else by the file extension (if the extension is known). If other cases the default format is used. The 'factory-fresh' default format is 'raster', but this can be changed using \code{\link{rasterOptions}}. } \usage{ writeFormats() } \details{ writeFormats returns a matrix of the file formats (the "drivers") that are supported. Supported formats include: \tabular{llllr}{ \tab \bold{File type} \tab \bold{Long name} \tab \bold{default extension} \tab \bold{Multiband support} \cr \tab \code{raster} \tab 'Native' raster package format \tab .grd \tab Yes \cr \tab \code{ascii} \tab ESRI Ascii \tab .asc \tab No \cr \tab \code{SAGA} \tab SAGA GIS \tab .sdat \tab No \cr \tab \code{IDRISI} \tab IDRISI \tab .rst \tab No \cr \tab \code{CDF} \tab netCDF (requires ncdf4) \tab .nc \tab Yes \cr \tab \code{GTiff} \tab GeoTiff \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 } } \examples{ writeFormats() } \keyword{ spatial } raster/man/cellStats.Rd0000644000176200001440000000406714507510157014566 0ustar liggesusers\name{cellStats} \alias{cellStats} \alias{cellStats,RasterLayer-method} \alias{cellStats,RasterStackBrick-method} \title{Statistics across cells} \description{ Compute statistics for the cells of each layer of a Raster* object. In the \code{raster} package, functions such as max, min, and mean, when used with Raster* objects as argument, return a new Raster* object (with a value computed for each cell). In contrast, cellStats returns a single value, computed from the all the values of a layer. Also see \code{\link{layerStats}} } \usage{ \S4method{cellStats}{RasterLayer}(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) \S4method{cellStats}{RasterStackBrick}(x, stat='mean', na.rm=TRUE, asSample=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{stat}{The function to be applied. See Details} \item{na.rm}{Logical. Should \code{NA} values be removed?} \item{asSample}{Logical. Only relevant for \code{stat=sd} in which case, if \code{TRUE}, the standard deviation for a sample (denominator is \code{n-1}) is computed, rather than for the population (denominator is \code{n})} \item{...}{Additional arguments } } \value{ Numeric } \details{ \code{cellStats} will fail (gracefully) for very large Raster* objects except for a number of known functions: sum, mean, min, max, sd, 'skew' and 'rms'. 'skew' (skewness) and 'rms' (Root Mean Square) must be supplied as a character value (with quotes), the other known functions may be supplied with or without quotes. For other functions you could perhaps use a sample of the RasterLayer that can be held in memory (see \code{\link[raster]{sampleRegular}} ) } \seealso{ \code{\link[raster]{freq}}, \code{\link[raster]{quantile}}, \code{\link[raster:extremeValues]{minValue}}, \code{\link[raster:extremeValues]{maxValue}}, \code{\link[raster]{setMinMax}} } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) * 10 # works for large files cellStats(r, 'mean') # same, but does not work for very large files cellStats(r, mean) # multi-layer object cellStats(brick(r,r), mean) } \keyword{spatial} \keyword{univar} raster/man/autocor.Rd0000644000176200001440000000320214507510157014272 0ustar liggesusers\name{autocorrelation} \alias{Geary} \alias{Moran} \alias{MoranLocal} \alias{GearyLocal} \title{Spatial autocorrelation} \description{ Compute Moran's I or Geary's C measures of global spatial autocorrelation in a RasterLayer, or compute the the local Moran or Geary index (Anselin, 1995). } \usage{ Geary(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) Moran(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) MoranLocal(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) GearyLocal(x, w=matrix(c(1,1,1,1,0,1,1,1,1), 3,3)) } \arguments{ \item{x}{RasterLayer} \item{w}{Spatial weights defined by or a rectangular matrix with odd length (3, 5, ...) sides (as in \code{\link{focal}}) } } \value{ A single value (Moran's I or Geary's C) or a RasterLayer (Local Moran or Geary values) } \details{ The default setting uses a 3x3 neighborhood to compute "Queen's case" indices. You can use a filter (weights matrix) to do other things, such as "Rook's case", or different lags. } \seealso{ The spdep package for additional and more general approaches for computing indices of spatial autocorrelation } \author{Robert J. Hijmans and Babak Naimi} \references{ Moran, P.A.P., 1950. Notes on continuous stochastic phenomena. Biometrika 37:17-23 Geary, R.C., 1954. The contiguity ratio and statistical mapping. The Incorporated Statistician 5: 115-145 Anselin, L., 1995. Local indicators of spatial association-LISA. Geographical Analysis 27:93-115 } \examples{ r <- raster(nrows=10, ncols=10) values(r) <- 1:ncell(r) Moran(r) # Rook's case f <- matrix(c(0,1,0,1,0,1,0,1,0), nrow=3) Moran(r, f) Geary(r) x1 <- MoranLocal(r) # Rook's case x2 <- MoranLocal(r, w=f) } \keyword{spatial} raster/man/roundExtent.Rd0000644000176200001440000000162614507510157015145 0ustar liggesusers\name{Extent math} \alias{floor,Extent-method} \alias{ceiling,Extent-method} \title{round Extent coordinates} \description{ use \code{round(x, digits=0)} to round the coordinates of an Extent object to the number of digits specified. This can be useful when dealing with a small imprecision in the data (e.g. 179.9999 instead of 180). \code{floor} and \code{ceiling} move the coordiantes to the outer or inner whole integer numbers. It is also possible to use Arithmetic functions with Extent objects (but these work perhaps unexpectedly!) See \code{\link[raster]{Math-methods}} for these (and many more) methods with Raster* objects. } \usage{ \S4method{floor}{Extent}(x) \S4method{ceiling}{Extent}(x) } \arguments{ \item{x}{Extent object } } \seealso{\code{\link[raster]{Math-methods}}} \examples{ e <- extent(c(0.999999, 10.000011, -60.4, 60)) round(e) ceiling(e) floor(e) } \keyword{ spatial } raster/man/predict.Rd0000644000176200001440000001670614507510157014265 0ustar liggesusers\name{predict} \docType{methods} \alias{predict} \alias{predict,Raster-method} \title{Spatial model predictions} \description{ Make a Raster object with predictions from a fitted model object (for example, obtained with \code{lm}, \code{glm}). The first argument is a Raster object with the independent (predictor) variables. The \code{\link{names}} in the Raster object should exactly match those expected by the model. This will be the case if the same Raster object was used (via \code{extract}) to obtain the values to fit the model (see the example). Any type of model (e.g. glm, gam, randomForest) for which a predict method has been implemented (or can be implemented) can be used. This approach (predict a fitted model to raster data) is commonly used in remote sensing (for the classification of satellite images) and in ecology, for species distribution modeling. } \usage{ \S4method{predict}{Raster}(object, model, filename="", fun=predict, ext=NULL, const=NULL, index=1, na.rm=TRUE, inf.rm=FALSE, factors=NULL, format, datatype, overwrite=FALSE, progress='', ...) } \arguments{ \item{object}{Raster* object. Typically a multi-layer type (RasterStack or RasterBrick)} \item{model}{fitted model of any class that has a 'predict' method (or for which you can supply a similar method as \code{fun} argument. E.g. glm, gam, or randomForest } \item{filename}{character. Optional output filename } \item{fun}{function. Default value is 'predict', but can be replaced with e.g. predict.se (depending on the type of model), or your own custom function.} \item{ext}{Extent object to limit the prediction to a sub-region of \code{x} } \item{const}{data.frame. Can be used to add a constant for which there is no Raster object for model predictions. Particularly useful if the constant is a character-like factor value for which it is currently not possible to make a RasterLayer } \item{index}{integer. To select the column(s) to use if predict.'model' returns a matrix with multiple columns } \item{na.rm}{logical. Remove cells with \code{NA} values in the predictors before solving the model (and return a \code{NA} value for those cells). This option prevents errors with models that cannot handle \code{NA} values. In most other cases this will not affect the output. An exception is when predicting with a boosted regression trees model because these return predicted values even if some (or all!) variables are \code{NA} } \item{inf.rm}{logical. Remove cells with values that are not finite (some models will fail with -Inf/Inf values). This option is ignored when \code{na.rm=FALSE}} \item{factors}{list with levels for factor variables. The list elements should be named with names that correspond to names in \code{object} such that they can be matched. This argument may be omitted for standard models such as 'glm' as the predict function will extract the levels from the \code{model} object, but it is necessary in some other cases (e.g. cforest models from the party package)} \item{format}{character. Output file type. See \link[raster]{writeRaster} (optional) } \item{datatype}{character. Output data type. See \link[raster]{dataType} (optional) } \item{overwrite}{logical. If TRUE, "filename" will be overwritten if it exists } \item{progress}{character. "text", "window", or "" (the default, no progress bar) } \item{...}{additional arguments to pass to the predict.'model' function } } \seealso{ Use \code{\link[raster]{interpolate}} if your model has 'x' and 'y' as implicit independent variables (e.g., in kriging). } \value{ RasterLayer or RasterBrick } \examples{ # A simple model to predict the location of the R in the R-logo using 20 presence points # and 50 (random) pseudo-absence points. This type of model is often used to predict # species distributions. See the dismo package for more of that. # create a RasterStack or RasterBrick with with a set of predictor layers logo <- brick(system.file("external/rlogo.grd", package="raster")) names(logo) \dontrun{ # the predictor variables par(mfrow=c(2,2)) plotRGB(logo, main='logo') plot(logo, 1, col=rgb(cbind(0:255,0,0), maxColorValue=255)) plot(logo, 2, col=rgb(cbind(0,0:255,0), maxColorValue=255)) plot(logo, 3, col=rgb(cbind(0,0,0:255), maxColorValue=255)) par(mfrow=c(1,1)) } # known presence and absence points p <- matrix(c(48, 48, 48, 53, 50, 46, 54, 70, 84, 85, 74, 84, 95, 85, 66, 42, 26, 4, 19, 17, 7, 14, 26, 29, 39, 45, 51, 56, 46, 38, 31, 22, 34, 60, 70, 73, 63, 46, 43, 28), ncol=2) a <- matrix(c(22, 33, 64, 85, 92, 94, 59, 27, 30, 64, 60, 33, 31, 9, 99, 67, 15, 5, 4, 30, 8, 37, 42, 27, 19, 69, 60, 73, 3, 5, 21, 37, 52, 70, 74, 9, 13, 4, 17, 47), ncol=2) # extract values for points xy <- rbind(cbind(1, p), cbind(0, a)) v <- data.frame(cbind(pa=xy[,1], extract(logo, xy[,2:3]))) #build a model, here an example with glm model <- glm(formula=pa~., data=v) #predict to a raster r1 <- predict(logo, model, progress='text') plot(r1) points(p, bg='blue', pch=21) points(a, bg='red', pch=21) # use a modified function to get a RasterBrick with p and se # from the glm model. The values returned by 'predict' are in a list, # and this list needs to be transformed to a matrix predfun <- function(model, data) { v <- predict(model, data, se.fit=TRUE) cbind(p=as.vector(v$fit), se=as.vector(v$se.fit)) } # predfun returns two variables, so use index=1:2 r2 <- predict(logo, model, fun=predfun, index=1:2) \dontrun{ # You can use multiple cores to speed up the predict function # by calling it via the clusterR function (you may need to install the snow package) beginCluster() r1c <- clusterR(logo, predict, args=list(model)) r2c <- clusterR(logo, predict, args=list(model=model, fun=predfun, index=1:2)) } # principal components of a RasterBrick # here using sampling to simulate an object too large # to feed all its values to prcomp sr <- sampleRandom(logo, 100) pca <- prcomp(sr) # note the use of the 'index' argument x <- predict(logo, pca, index=1:3) plot(x) \dontrun{ # partial least square regression library(pls) model <- plsr(formula=pa~., data=v) # this returns an array: predict(model, v[1:5,]) # write a function to turn that into a matrix pfun <- function(x, data) { y <- predict(x, data) d <- dim(y) dim(y) <- c(prod(d[1:2]), d[3]) y } pp <- predict(logo, model, fun=pfun, index=1:3) # Random Forest library(randomForest) rfmod <- randomForest(pa ~., data=v) ## note the additional argument "type='response'" that is ## passed to predict.randomForest r3 <- predict(logo, rfmod, type='response', progress='window') ## get a RasterBrick with class membership probabilities vv <- v vv$pa <- as.factor(vv$pa) rfmod2 <- randomForest(pa ~., data=vv) r4 <- predict(logo, rfmod2, type='prob', index=1:2) spplot(r4) # cforest (other Random Forest implementation) example with factors argument v$red <- as.factor(round(v$red/100)) logo$red <- round(logo[[1]]/100) library(party) m <- cforest(pa~., control=cforest_unbiased(mtry=3), data=v) f <- list(levels(v$red)) names(f) <- 'red' # the second argument in party:::predict.RandomForest # is "OOB", and not "newdata" or similar. We need to write a wrapper # predict function to deal with this predfun <- function(m, d, ...) predict(m, newdata=d, ...) pc <- predict(logo, m, OOB=TRUE, factors=f, fun=predfun) # knn example, using calc instead of predict library(class) cl <- factor(c(rep(1, nrow(p)), rep(0, nrow(a)))) train <- extract(logo, rbind(p, a)) k <- calc(logo, function(x) as.integer(as.character(knn(train, x, cl)))) } } \keyword{methods} \keyword{spatial} raster/man/boxplot.Rd0000644000176200001440000000206414507510157014312 0ustar liggesusers\name{boxplot} \docType{methods} \alias{boxplot} \alias{boxplot,RasterLayer-method} \alias{boxplot,RasterStackBrick-method} \title{ Box plot of Raster objects } \description{ Box plot of layers in a Raster object } \usage{ \S4method{boxplot}{RasterStackBrick}(x, maxpixels=100000, ...) \S4method{boxplot}{RasterLayer}(x, y=NULL, maxpixels=100000, ...) } \arguments{ \item{x}{Raster* object} \item{y}{If \code{x} is a RasterLayer object, y can be an additional RasterLayer to group the values of \code{x} by 'zone'} \item{maxpixels}{Integer. Number of pixels to sample from each layer of large Raster objects} \item{...}{Arguments passed to \code{graphics::\link[graphics]{boxplot}}} } \seealso{ \code{\link{pairs}, \link{hist}} } \examples{ r1 <- r2 <- r3 <- raster(ncol=10, nrow=10) values(r1) <- rnorm(ncell(r1), 100, 40) values(r2) <- rnorm(ncell(r1), 80, 10) values(r3) <- rnorm(ncell(r1), 120, 30) s <- stack(r1, r2, r3) names(s) <- c('A', 'B', 'C') boxplot(s, notch=TRUE, col=c('red', 'blue', 'orange'), main='Box plot', ylab='random' ) } \keyword{spatial} raster/man/stackApply.Rd0000644000176200001440000000414614507510157014741 0ustar liggesusers\name{stackApply} \docType{methods} \alias{stackApply} \title{Apply a function on subsets of a RasterStack or RasterBrick} \description{ Apply a function on subsets of a RasterStack or RasterBrick. The layers to be combined are indicated with the vector \code{indices}. The function used should return a single value, and the number of layers in the output Raster* equals the number of unique values in \code{indices}. For example, if you have a RasterStack with 6 layers, you can use \code{indices=c(1,1,1,2,2,2)} and \code{fun=sum}. This will return a RasterBrick with two layers. The first layer is the sum of the first three layers in the input RasterStack, and the second layer is the sum of the last three layers in the input RasterStack. Indices are recycled such that \code{indices=c(1,2)} would also return a RasterBrick with two layers (one based on the odd layers (1,3,5), the other based on the even layers (2,4,6)). See \code{\link{calc}} if you want to use a more efficient function that returns multiple layers based on _all_ layers in the Raster* object. } \usage{ stackApply(x, indices, fun, filename='', na.rm=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{indices}{integer. Vector of length \code{nlayers(x)} (shorter vectors are recycled) containing all integer values between 1 and the number of layers of the output Raster*} \item{fun}{function that returns a single value, e.g. \code{mean} or \code{min}, and that takes a \code{na.rm} argument (or can pass through arguments via \code{...})} \item{na.rm}{logical. If \code{TRUE}, \code{NA} cells are removed from calculations} \item{filename}{character. Optional output filename} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ A new Raster* object, and in some cases the side effect of a new file on disk. } \seealso{\code{\link{calc}, \link{stackSelect}}} \examples{ r <- raster(ncol=10, nrow=10) values(r) <- 1:ncell(r) s <- brick(r,r,r,r,r,r) s <- s * 1:6 b1 <- stackApply(s, indices=c(1,1,1,2,2,2), fun=sum) b1 b2 <- stackApply(s, indices=c(1,2,3,1,2,3), fun=sum) b2 } \keyword{methods} \keyword{spatial} raster/man/corLocal.Rd0000644000176200001440000000372614507510157014367 0ustar liggesusers\name{corLocal} \docType{methods} \alias{corLocal} \alias{corLocal,RasterLayer,RasterLayer-method} \alias{corLocal,RasterStackBrick,RasterStackBrick-method} \title{Local correlation coefficient} \description{ Local correlation coefficient for two RasterLayer objects (using a focal neighborhood) or for two RasterStack or Brick objects (with the same number of layers (> 2)) } \usage{ \S4method{corLocal}{RasterLayer,RasterLayer}(x, y, ngb=5, method=c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) \S4method{corLocal}{RasterStackBrick,RasterStackBrick}(x, y, method=c("pearson", "kendall", "spearman"), test=FALSE, filename='', ...) } \arguments{ \item{x}{RasterLayer or RasterStack/RasterBrick} \item{y}{object of the same class as \code{x}, and with the same number of layers} \item{ngb}{neighborhood size. Either a single integer or a vector of two integers c(nrow, ncol)} \item{method}{character indicating which correlation coefficient is to be used. One of \code{"pearson"}, \code{"kendall"}, or \code{"spearman"}} \item{test}{logical. If \code{TRUE}, return a p-value} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \note{\code{NA} values are omitted} \value{ RasterLayer } \seealso{ \code{\link{cor}}, \code{\link{cor.test}} } \examples{ b <- stack(system.file("external/rlogo.grd", package="raster")) b <- aggregate(b, 2, mean) set.seed(0) b[[2]] <- flip(b[[2]], 'y') + runif(ncell(b)) b[[1]] <- b[[1]] + runif(ncell(b)) x <- corLocal(b[[1]], b[[2]], test=TRUE ) # plot(x) # only cells where the p-value < 0.1 xm <- mask(x[[1]], x[[2]] < 0.1, maskvalue=FALSE) plot(xm) # for global correlation, use the cor function x <- as.matrix(b) cor(x, method="spearman") # use sampleRegular for large datasets x <- sampleRegular(b, 1000) cor.test(x[,1], x[,2]) # RasterStack or Brick objects y <- corLocal(b, flip(b, 'y')) } \keyword{methods} \keyword{spatial} raster/man/symdif.Rd0000644000176200001440000000132614507510157014116 0ustar liggesusers\name{symdif} \docType{methods} \alias{symdif} \alias{symdif,SpatialPolygons,SpatialPolygons-method} \title{ Symetrical difference } \description{ Symetrical difference of SpatialPolygons* objects } \usage{ \S4method{symdif}{SpatialPolygons,SpatialPolygons}(x, y, ...) } \arguments{ \item{x}{SpatialPolygons* object} \item{y}{SpatialPolygons* object} \item{...}{Additional SpatialPolygons* object(s)} } \value{ SpatialPolygons* } \seealso{ \code{\link{erase}} } \examples{ #SpatialPolygons p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(p) sd <- symdif(p, b) plot(sd, col='red') } \keyword{methods} \keyword{spatial} raster/man/rasterFromXYZ.Rd0000644000176200001440000000344514507510157015366 0ustar liggesusers\name{rasterFromXYZ} \alias{rasterFromXYZ} \title{ Create a Raster* object from x, y, z values } \description{ Create a Raster* object from x, y and z values. x and y represent spatial coordinates and must be on a regular grid. If the resolution is not supplied, it is assumed to be the minimum distance between x and y coordinates, but a resolution of up to 10 times smaller is evaluated if a regular grid can otherwise not be created. z values can be single or multiple columns (variables) If the exact properties of the RasterLayer are known beforehand, it may be preferable to simply create a new RasterLayer with the raster function instead, compute cell numbers and assign the values with these (see example below). } \usage{ rasterFromXYZ(xyz, res=c(NA,NA), crs="", digits=5) } \arguments{ \item{xyz}{matrix or data.frame with at least three columns: x and y coordinates, and values (z). There may be several 'z' variables (columns)} \item{res}{numeric. The x and y cell resolution (optional)} \item{crs}{CRS object or a character string describing a projection and datum in PROJ.4 format} \item{digits}{numeric, indicating the requested precision for detecting whether points are on a regular grid (a low number of digits is a low precision)} } \value{ RasterLayer or RasterBrick } \seealso{See \code{\link{rasterize} for points that are not on a regular grid} } \examples{ r <- raster(nrow=5, ncol=5, xmn=0, xmx=10, ymn=0, ymx=10, crs="") set.seed(1) values(r) <- sample(1:25) r[r < 15] <- NA xyz <- rasterToPoints(r) rst <- rasterFromXYZ(xyz) # equivalent to: rr <- raster(nrow=5, ncol=5, xmn=0, xmx=10, ymn=0, ymx=10) cells <- cellFromXY(rr, xyz[,1:2]) rr[cells] <- xyz[,3] # multiple layers xyzz <- cbind(xyz, a=1:nrow(xyz), b=nrow(xyz):1) b <- rasterFromXYZ(xyzz) } \keyword{methods} \keyword{spatial} raster/man/terrain.Rd0000644000176200001440000001075114545422500014265 0ustar liggesusers\name{terrain} \alias{terrain} \alias{terrain,RasterLayer-method} \title{Terrain characteristics} \description{ Compute slope, aspect and other terrain characteristics from a raster with elevation data. The elevation data should be in map units (typically meter) for projected (planar) raster data. They should be in meters when the coordinate reference system (CRS) is longitude/latitude. } \usage{ \S4method{terrain}{RasterLayer}(x, opt="slope", unit="radians", neighbors=8, filename="", ...) } \arguments{ \item{x}{RasterLayer object with elevation values. Values should have the same unit as the map units, or in meters when the crs is longitude/latitude} \item{opt}{Character vector containing one or more of these options: slope, aspect, TPI, TRI, roughness, flowdir (see Details)} \item{unit}{Character. 'degrees', 'radians' or 'tangent'. Only relevant for slope and aspect. If 'tangent' is selected that is used for slope, but for aspect 'degrees' is used (as 'tangent' has no meaning for aspect) } \item{neighbors}{Integer. Indicating how many neighboring cells to use to compute slope for any cell. Either 8 (queen case) or 4 (rook case). Only used for slope and aspect, see Details} \item{filename}{Character. Output filename (optional)} \item{...}{Standard additional arguments for writing Raster* objects to file} } \details{ When \code{neighbors=4}, slope and aspect are computed according to Fleming and Hoffer (1979) and Ritter (1987). When \code{neigbors=8}, slope and aspect are computed according to Horn (1981). The Horn algorithm may be best for rough surfaces, and the Fleming and Hoffer algorithm may be better for smoother surfaces (Jones, 1997; Burrough and McDonnell, 1998). If slope = 0, aspect is set to 0.5*pi radians (or 90 degrees if unit='degrees'). When computing slope or aspect, the CRS (\code{\link{projection}}) of the RasterLayer \code{x} must be known (may not be \code{NA}), to be able to safely differentiate between planar and longitude/latitude data. flowdir returns the 'flow direction' (of water), i.e. the direction of the greatest drop in elevation (or the smallest rise if all neighbors are higher). They are encoded as powers of 2 (0 to 7). The cell to the right of the focal cell 'x' is 1, the one below that is 2, and so on: \tabular{rrr}{ 32 \tab64 \tab 128\cr 16 \tab x \tab 1 \cr 8 \tab 4 \tab 2 \cr } If two cells have the same drop in elevation, a random cell is picked. That is not ideal as it may prevent the creation of connected flow networks. ArcGIS implements the approach of Greenlee (1987) and I might adopt that in the future. The terrain indices are according to Wilson et al. (2007). TRI (Terrain Ruggedness Index) is the mean of the absolute differences between the value of a cell and the value of its 8 surrounding cells. TPI (Topographic Position Index) is the difference between the value of a cell and the mean value of its 8 surrounding cells. Roughness is the difference between the maximum and the minimum value of a cell and its 8 surrounding cells. Such measures can also be computed with the \code{\link{focal}} function: f <- matrix(1, nrow=3, ncol=3) TRI <- focal(x, w=f, fun=function(x, ...) sum(abs(x[-5]-x[5]))/8, pad=TRUE, padValue=NA) TPI <- focal(x, w=f, fun=function(x, ...) x[5] - mean(x[-5]), pad=TRUE, padValue=NA) rough <- focal(x, w=f, fun=function(x, ...) max(x) - min(x), pad=TRUE, padValue=NA, na.rm=TRUE) } \seealso{ \code{\link{hillShade}} } \references{ Burrough, P., and R.A. McDonnell, 1998. Principles of Geographical Information Systems. Oxford University Press. Fleming, M.D. and Hoffer, R.M., 1979. Machine processing of landsat MSS data and DMA topographic data for forest cover type mapping. LARS Technical Report 062879. Laboratory for Applications of Remote Sensing, Purdue University, West Lafayette, Indiana. Greenlee, D.D., 1987. Raster and vector processing for scanned linework. Photogrammetric Engineering and Remote Sensing 53:1383-1387 Horn, B.K.P., 1981. Hill shading and the reflectance map. Proceedings of the IEEE 69:14-47 Jones, K.H., 1998. A comparison of algorithms used to compute hill slope as a property of the DEM. Computers & Geosciences 24: 315-323 Ritter, P., 1987. A vector-based slope and aspect generation algorithm. Photogrammetric Engineering and Remote Sensing 53: 1109-1111 Wilson, M.F.J., O'Connell, B., Brown, C., Guinan, J.C., Grehan, A.J., 2007. Multiscale terrain analysis of multibeam bathymetry data for habitat mapping on the continental slope. Marine Geodesy 30: 3-35. } \keyword{spatial} raster/man/xyFromCell.Rd0000644000176200001440000000471314507510157014712 0ustar liggesusers\name{xyFromCell} \alias{xFromCol} \alias{xFromCol,Raster,numeric-method} \alias{xFromCol,Raster,missing-method} \alias{yFromRow} \alias{yFromRow,Raster,numeric-method} \alias{yFromRow,Raster,missing-method} \alias{xFromCell} \alias{xFromCell,Raster,numeric-method} \alias{yFromCell} \alias{yFromCell,Raster,numeric-method} \alias{xyFromCell} \alias{xyFromCell,BasicRaster-method} \alias{xyFromCell,BasicRaster,ANY-method} \alias{xyFromCell,Raster-method} \alias{xyFromCell,Raster-method} \alias{coordinates} \alias{coordinates,Raster-method} \alias{coordinates,Extent-method} \title{Coordinates from a row, column or cell number} \description{ These functions get coordinates of the center of raster cells for a row, column, or cell number of a Raster* object. } \usage{ \S4method{xFromCol}{Raster,numeric}(object, col) \S4method{yFromRow}{Raster,numeric}(object, row) \S4method{xFromCell}{Raster,numeric}(object, cell) \S4method{yFromCell}{Raster,numeric}(object, cell) \S4method{xyFromCell}{BasicRaster,ANY}(object, cell, spatial=FALSE, ...) \S4method{coordinates}{Raster}(obj, ...) \S4method{coordinates}{Extent}(obj, ...) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{col}{column number; or vector of column numbers. If missing, the x coordinates for all columns are returned} \item{row}{row number; or vector of row numbers. If missing, the y coordinates for all rows are returned} \item{cell}{cell number(s)} \item{spatial}{If \code{spatial=TRUE}, \code{xyFromCell} returns a SpatialPoints object instead of a matrix} \item{...}{additional arguments. None implemented} \item{obj}{Raster object} } \details{ Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \value{ xFromCol, yFromCol, xFromCell, yFromCell: vector of x or y coordinates xyFromCell: matrix(x,y) with coordinate pairs coordinates: xy coordinates for all cells } \seealso{ \code{\link{cellFromXY}} } \examples{ #using a new default raster (1 degree global) r <- raster() xFromCol(r, c(1, 120, 180)) yFromRow(r, 90) xyFromCell(r, 10000) xyFromCell(r, c(0, 1, 32581, ncell(r), ncell(r)+1)) #using a file from disk r <- raster(system.file("external/test.grd", package="raster")) r cellFromXY(r, c(180000, 330000)) #xy for corners of a raster: xyFromCell(r, c(1, ncol(r), ncell(r)-ncol(r)+1, ncell(r))) } \keyword{spatial} raster/man/as.raster.Rd0000644000176200001440000000147614507510157014533 0ustar liggesusers\name{as.raster} \alias{as.raster} \alias{as.raster,RasterLayer-method} \title{Coerce to a 'raster' object} \description{ Implementation of the generic \code{\link[grDevices]{as.raster}} function to create a 'raster' (small r) object. NOT TO BE CONFUSED with the Raster* (big R) objects defined by the raster package! Such objects can be used for plotting with the \code{\link[graphics]{rasterImage}} function. } \usage{ as.raster(x, ...) } \arguments{ \item{x}{ RasterLayer object } \item{...}{ Additional arguments. \code{maxpixels} Integer. To regularly subsample very large objects \code{col} Vector of colors. Default is col=rev(terrain.colors(255))) } } \value{ 'raster' object } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.raster(r) } \keyword{spatial} \keyword{methods} raster/man/boundaries.Rd0000644000176200001440000000270614507510157014761 0ustar liggesusers\name{boundaries} \alias{boundaries} \alias{boundaries,RasterLayer-method} \title{boundaries (edges) detection} \description{ Detect boundaries (edges). boundaries are cells that have more than one class in the 4 or 8 cells surrounding it, or, if \code{classes=FALSE}, cells with values and cells with \code{NA}. } \usage{ \S4method{boundaries}{RasterLayer}(x, type='inner', classes=FALSE, directions=8, asNA=FALSE, filename="", ...) } \arguments{ \item{x}{RasterLayer object} \item{type}{character. 'inner' or 'outer'} \item{classes}{character. Logical. If \code{TRUE} all different values are (after rounding) distinguished, as well as \code{NA}. If \code{FALSE} (the default) only edges between \code{NA} and non-\code{NA} cells are considered} \item{directions}{integer. Which cells are considered adjacent? Should be 8 (Queen's case) or 4 (Rook's case)} \item{asNA}{logical. If \code{TRUE}, non-edges are returned as \code{NA} instead of zero} \item{filename}{character. Filename for the output RasterLayer (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer. Cell values are either 1 (a border) or 0 (not a border), or \code{NA} } \seealso{ \code{\link{focal}}, \code{\link{clump}} } \examples{ r <- raster(nrow=18, ncol=36, xmn=0) r[150:250] <- 1 r[251:450] <- 2 plot( boundaries(r, type='inner') ) plot( boundaries(r, type='outer') ) plot( boundaries(r, classes=TRUE) ) } \keyword{methods} \keyword{spatial} raster/man/replacement.Rd0000644000176200001440000000340614507510157015123 0ustar liggesusers\name{replacement} \docType{methods} \alias{[<-,RasterLayer,RasterLayer,missing-method} \alias{[<-,RasterLayer,missing,missing-method} \alias{[<-,RasterStackBrick,Raster,missing-method} \alias{[<-,RasterStackBrick,missing,missing-method} \alias{[[<-,RasterStack,numeric,missing-method} \alias{[[<-,Raster,numeric,missing-method} \alias{[[<-,RasterStackBrick,character,missing-method} \alias{[[<-,RasterLayer,character,missing-method} \alias{[<-,Raster,numeric,numeric-method} \alias{[<-,Raster,numeric,missing-method} \alias{[<-,Raster,matrix,missing-method} \alias{[<-,Raster,logical,missing-method} \alias{[<-,Raster,missing,numeric-method} \alias{[<-,Raster,Spatial,missing-method} \alias{[<-,Raster,Extent,missing-method} \alias{[<-,Extent,numeric,missing-method} \alias{$<-,Raster-method} \alias{$,Raster-method} \title{Replace cell values or layers of a Raster* object} \description{ You can set values of a Raster* object, when \code{i} is a vector of cell numbers, a Raster*, Extent, or Spatial* object. These are shorthand methods that work best for relatively small Raster* objects. In other cases you can use functions such as \code{\link{calc} and \link{rasterize}}. } \section{Methods}{ \describe{ \code{x[i] <- value} \code{x[i,j] <- value} \tabular{rll}{ \tab \bold{Arguments:} \tab \cr \tab \code{x} \tab a Raster* object \cr \tab \code{i} \tab cell number(s), row number(s), Extent, Spatial* object \cr \tab \code{j} \tab columns number(s) (only available if i is (are) a row number(s)) \cr \tab \code{value} \tab new cell value(s) \cr } }} \seealso{ \link{calc}, \link{rasterize}} \examples{ r <- raster(ncol=10, nrow=5) values(r) <- 1:ncell(r) * 2 r[1,] <- 1 r[,1] <- 2 r[1,1] <- 3 s <- stack(r, sqrt(r)) s[s<5] <- NA } \keyword{methods} \keyword{spatial} raster/man/gainoffset.Rd0000644000176200001440000000223514507510157014750 0ustar liggesusers\name{Gain and offset} \alias{gain} \alias{offs} \alias{gain<-} \alias{offs<-} \title{Gain and offset of values on file} \description{ These functions can be used to get or set the gain and offset parameters used to transform values when reading them from a file. The gain and offset parameters are applied to the raw values using the formula below: \code{value <- value * gain + offset} The default value for gain is 1 and for offset is 0. 'gain' is sometimes referred to as 'scale'. Note that setting gain and/or offset are intended to be used with values that are stored in a file. For a Raster* object with values in memory, assigning gain or offset values will lead to the inmediate computation of new values; in such cases it would be clearer to use \code{\link[raster]{Arith-methods}}. } \usage{ gain(x) gain(x) <- value offs(x) offs(x) <- value } \arguments{ \item{x}{Raster* object} \item{value}{Single numeric value } } \value{ Raster* object or numeric value(s) } \examples{ r <- raster(system.file("external/test.grd", package="raster")) gain(r) offs(r) r[1505:1510] gain(r) <- 10 offs(r) <- 5 r[1505:1510] } \keyword{ spatial } \keyword{ methods } raster/man/validNames.Rd0000644000176200001440000000065214507510157014707 0ustar liggesusers\name{validNames} \alias{validNames} \title{Create valid names} \description{ Create a set of valid names (trimmed, no duplicates, not starting with a number). } \usage{ validNames(x, prefix='layer') } \arguments{ \item{x}{character} \item{prefix}{character string used if x is empty} } \value{ character } \seealso{ \code{\link{make.names} } } \examples{ validNames(c('a', 'a', '', '1', NA, 'b', 'a')) } raster/man/resample.Rd0000644000176200001440000000307414507510157014435 0ustar liggesusers\name{resample} \alias{resample} \alias{resample,Raster,Raster-method} \title{Resample a Raster object} \description{ Resample transfers values between non matching Raster* objects (in terms of origin and resolution). Use \code{\link[raster]{projectRaster}} if the target has a different coordinate reference system (projection). Before using resample, you may want to consider using these other functions instead: \code{\link[raster]{aggregate}}, \code{\link[raster]{disaggregate}}, \code{\link[raster]{crop}}, \code{\link[raster]{extend}}, \code{\link[raster]{merge}}. } \usage{ \S4method{resample}{Raster,Raster}(x, y, method="bilinear", filename="", ...) } \arguments{ \item{x}{Raster* object to be resampled} \item{y}{Raster* object with parameters that \code{x} should be resampled to} \item{method}{method used to compute values for the new RasterLayer, should be \code{"bilinear"} for bilinear interpolation, or \code{"ngb"} for using the nearest neighbor} \item{filename}{character. Output filename (optional) } \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick object } \author{Robert J. Hijmans and Joe Cheng} \seealso{ \code{\link[raster]{aggregate}}, \code{\link[raster]{disaggregate}}, \code{\link[raster]{crop}}, \code{\link[raster]{extend}}, \code{\link[raster]{merge}}, \code{\link[raster]{projectRaster}} } \examples{ r <- raster(nrow=3, ncol=3) values(r) <- 1:ncell(r) s <- raster(nrow=10, ncol=10) s <- resample(r, s, method='bilinear') #par(mfrow=c(1,2)) #plot(r) #plot(s) } \keyword{spatial} raster/man/rasterTmpFile.Rd0000644000176200001440000000354614507510157015412 0ustar liggesusers\name{rasterTmpFile} \alias{rasterTmpFile} \alias{removeTmpFiles} \alias{showTmpFiles} \title{Temporary files} \description{ Functions in the raster package create temporary files if the values of an output Raster* object cannot be stored in memory (RAM). This can happen when no filename is provided to a function and in functions where you cannot provide a filename (e.g. when using 'raster algebra'). Temporary files are automatically removed at the start of each session. During a session you can use \code{showTmpFiles} to see what is there and \code{removeTmpFiles} to delete all the temporary files. \code{rasterTmpFile} returns a temporary filename. These can be useful when developing your own functions. These filenames consist of \code{prefix_date_time_pid_rn} where \code{pid} is the process id returned by \code{\link{Sys.getpid}} and \code{rn} is a 5 digit random number. This should make tempfiles unique if created at different times and also when created in parallel processes (different pid) that use \code{\link{set.seed}} and call rasterTmpFile at the same time. It is possible, however, to create overlapping names (see the examples), which is undesirable and can be avoided by setting the prefix argument. } \usage{ rasterTmpFile(prefix='r_tmp_') showTmpFiles() removeTmpFiles(h=24) } \arguments{ \item{prefix}{Character. Prefix to the filename (which will be followed by 10 random numbers)} \item{h}{Numeric. The minimum age of the files in number of hours (younger files are not deleted)} } \value{ \code{rasterTmpFile} returns a valid file name \code{showTmpFiles} returns the names (.grd only) of the files in the temp directory \code{removeTmpFiles} returns nothing } \seealso{ \code{\link{rasterOptions}}, \code{\link[base]{tempfile}} } \examples{ \dontrun{ rasterTmpFile('mytemp_') showTmpFiles() removeTmpFiles(h=24) }} \keyword{ spatial } raster/man/datasource.Rd0000644000176200001440000000243314507510157014755 0ustar liggesusers\name{datasource} \alias{fromDisk} \alias{inMemory} \alias{inMemory,BasicRaster-method} \alias{hasValues} \alias{hasValues,BasicRaster-method} \title{Are values in memory and/or on disk?} \description{ These are helper functions for programmers and for debugging that provide information about whether a Raster object has associated values, and if these are in memory or on disk. \code{fromDisk} is \code{TRUE} if the data source is a file on disk; and \code{FALSE} if the object only exists in memory. \code{inMemory}i is \code{TRUE} if all values are currently in memory (RAM); and \code{FALSE} if not (in which case they either are on disk, or there are no values). \code{hasValues} is \code{TRUE} if the object has cell values. } \usage{ fromDisk(x) \S4method{inMemory}{BasicRaster}(x) \S4method{hasValues}{BasicRaster}(x) } \arguments{ \item{x}{ Raster* object } } \value{ Logical } \examples{ rs <- raster(system.file("external/test.grd", package="raster")) inMemory(rs) fromDisk(rs) rs <- readAll(rs) inMemory(rs) fromDisk(rs) rs <- rs + 1 inMemory(rs) fromDisk(rs) rs <- raster(rs) inMemory(rs) fromDisk(rs) rs <- setValues(rs, 1:ncell(rs)) inMemory(rs) fromDisk(rs) #rs <- writeRaster(rs, filename=rasterTmpFile(), overwrite=TRUE) #inMemory(rs) #fromDisk(rs) } \keyword{ spatial } raster/man/readAll.Rd0000644000176200001440000000153314507510157014167 0ustar liggesusers\name{readAll} \alias{readAll,RasterLayer-method} \alias{readAll,RasterStack-method} \alias{readAll,RasterBrick-method} \alias{readAll} \title{Read values from disk} \description{ Read all values from a raster file associated with a Raster* object into memory. This function should normally not be used. In most cases \code{\link[raster]{getValues}} or \code{\link[raster]{getValuesBlock}} is more appropriate as \code{readAll} will fail when there is no file associated with the RasterLayer (values may only exist in memory). } \usage{ readAll(object) } \arguments{ \item{object}{a Raster* object} } \seealso{ \code{\link[raster]{getValues}}, \code{\link[raster]{getValuesBlock}}, \code{\link[raster]{extract}}} \examples{ r <- raster(system.file("external/test.grd", package="raster")) r <- readAll(r) } \keyword{classes} \keyword{spatial} raster/man/raster.Rd0000644000176200001440000001521714507510157014127 0ustar liggesusers\name{raster} \docType{methods} \alias{raster} \alias{raster,missing-method} \alias{raster,character-method} \alias{raster,Extent-method} \alias{raster,BasicRaster-method} \alias{raster,RasterLayer-method} \alias{raster,RasterLayerSparse-method} \alias{raster,RasterStack-method} \alias{raster,RasterBrick-method} \alias{raster,Spatial-method} \alias{raster,SpatialGrid-method} \alias{raster,SpatialPixels-method} \alias{raster,matrix-method} \alias{raster,list-method} \alias{raster,im-method} \alias{raster,asc-method} \alias{raster,kasc-method} \alias{raster,kde-method} \alias{raster,grf-method} \alias{raster,sf-method} \alias{raster,GridTopology-method} \alias{raster,SpatRaster-method} \title{Create a RasterLayer object} \description{ Methods to create a RasterLayer object. RasterLayer objects can be created from scratch, a file, an Extent object, a matrix, an 'image' object, or from a Raster*, Spatial*, im (spatstat) asc, kasc (adehabitat*), grf (geoR) or kde object. In many cases, e.g. when a RasterLayer is created from a file, it does (initially) not contain any cell (pixel) values in (RAM) memory, it only has the parameters that describe the RasterLayer. You can access cell-values with \code{\link[raster]{getValues}, \link[raster]{extract}} and related functions. You can assign new values with \code{\link[raster]{setValues}} and with \code{\link[raster]{replacement}}. For an overview of the functions in the raster package have a look here: \code{\link{raster-package}}. } \usage{ \S4method{raster}{character}(x, band=1, ...) \S4method{raster}{RasterLayer}(x) \S4method{raster}{RasterStack}(x, layer=0) \S4method{raster}{RasterBrick}(x, layer=0) \S4method{raster}{missing}(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, crs, ext, resolution, vals=NULL) \S4method{raster}{Extent}(x, nrows=10, ncols=10, crs="", ...) \S4method{raster}{matrix}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", template=NULL) \S4method{raster}{Spatial}(x, origin, ...) \S4method{raster}{SpatialGrid}(x, layer=1, values=TRUE) \S4method{raster}{SpatialPixels}(x, layer=1, values=TRUE) \S4method{raster}{sf}(x, origin, ...) } \arguments{ \item{x}{filename (character), Extent, Raster*, sf, SpatialPixels*, SpatialGrid*, object, 'image', matrix, im, or missing. Supported file types are the 'native' raster package format and those that can be read by GDAL} \item{band}{integer. The layer to use in a multi-layer file} \item{...}{Additional arguments, see Details } \item{layer}{integer. The layer (variable) to use in a multi-layer file, or the layer to extract from a RasterStack/Brick or SpatialPixelsDataFrame or SpatialGridDataFrame. An empty RasterLayer (no associated values) is returned if \code{layer=0}} \item{values}{logical. If \code{TRUE}, the cell values of '\code{x}' are copied to the RasterLayer object that is returned} \item{nrows}{integer > 0. Number of rows} \item{ncols}{integer > 0. Number of columns} \item{xmn}{minimum x coordinate (left border)} \item{xmx}{maximum x coordinate (right border)} \item{ymn}{minimum y coordinate (bottom border)} \item{ymx}{maximum y coordinate (top border)} \item{ext}{object of class Extent. If present, the arguments xmn, xmx, ymn and ynx are ignored} \item{crs}{character or object of class CRS. PROJ.4 type description of a Coordinate Reference System (map projection). If this argument is missing, and the x coordinates are within -360 .. 360 and the y coordinates are within -90 .. 90, "+proj=longlat +datum=WGS84" is used. Also see under Details if \code{x} is a character (filename)} \item{resolution}{numeric vector of length 1 or 2 to set the resolution (see \code{\link{res}}). If this argument is used, arguments \code{ncols} and \code{nrows} are ignored } \item{vals}{optional. Values for the new RasterLayer. Accepted formats are as for \code{\link{setValues}}} \item{origin}{minimum y coordinate (bottom border)} \item{template}{Raster* or Extent object used to set the extent (and CRS in case of a Raster* object). If not \code{NULL}, arguments \code{xmn}, \code{xmx}, \code{ymn}, \code{ymx} and \code{crs} (unless \code{template} is an Extent object) are ignored} } \details{ If \code{x} is a filename, the following additional variables are recognized: \code{sub}: positive integer. Subdataset number for a file with subdatasets \code{native}: logical. Default is \code{FALSE}. 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 GDAL. 'raster' and netcdf format files are always read with native drivers. \code{RAT}: logical. The default is \code{TRUE}, in which case a raster attribute table is created for files that have one \code{offset}: integer. To indicate the number of header rows on non-standard ascii files (rarely useful; use with caution) \code{crs}: character. PROJ.4 string to set the CRS. Ignored when the file provides a CRS description that can be interpreted. If \code{x} represents a \bold{NetCDF} file, the following additional variable is recognized: \code{varname}: character. The variable name, such as 'tasmax' or 'pr'. If not supplied and the file has multiple variables are a guess will be made (and reported) \code{lvar}: integer > 0 (default=3). To select the 'level variable' (3rd dimension variable) to use, if the file has 4 dimensions (e.g. depth instead of time)\cr \code{level}: integer > 0 (default=1). To select the 'level' (4th dimension variable) to use, if the file has 4 dimensions, e.g. to create a RasterBrick of weather over time at a certain height. \cr To use NetCDF files the \code{ncdf4} package needs to be available. It is assumed that these files follow, or are compatible with, the CF-1 convention (The GMT format may also work). If the ncdf file does not have a standard extension (which is used to recognize the file format), you can use argument \code{ncdf=TRUE} to indicate the format. If \code{x} is a \code{Spatial} or an \code{Extent} object, additional arguments are for the method with signature \code{'missing'} } \value{ RasterLayer } \seealso{ \code{\link[raster]{stack}, \link[raster]{brick}} } \examples{ # Create a RasterLayer object from a file # N.B.: For your own files, omit the 'system.file' and 'package="raster"' bits # these are just to get the path to files installed with the package f <- system.file("external/test.grd", package="raster") f r <- raster(f) logo <- raster(system.file("external/rlogo.grd", package="raster")) #from scratch r1 <- raster(nrows=108, ncols=21, xmn=0, xmx=10) #from an Extent object e <- extent(r) r2 <- raster(e) #from another Raster* object r3 <- raster(r) s <- stack(r, r, r) r4 <- raster(s) r5 <- raster(s, 3) } \keyword{methods} \keyword{spatial} raster/man/RGB.Rd0000644000176200001440000000341014507510157013231 0ustar liggesusers\name{RGB} \docType{methods} \alias{RGB} \alias{RGB,RasterLayer-method} \title{Create a Red-Green-Blue Raster object} \description{ Make a Red-Green-Blue object that can be used to create images. } \usage{ \S4method{RGB}{RasterLayer}(x, filename='', col=rainbow(25), breaks=NULL, alpha=FALSE, colNA='white', zlim=NULL, zlimcol=NULL, ext=NULL, ...) } \value{RasterBrick} \arguments{ \item{x}{RasterLayer} \item{filename}{character. Output filename (optional)} \item{col}{A color palette, that is a vector of n contiguous colors generated by functions like \link{rainbow}, \link{heat.colors}, \link{topo.colors}, \link[sp]{bpy.colors} or one or your own making, perhaps using \code{\link{colorRampPalette}}. If none is provided, \code{rev(terrain.colors(255))} is used unless \code{x} has a 'color table'} \item{breaks}{numeric. A set of finite numeric breakpoints for the colours: must have one more breakpoint than colour and be in increasing order} \item{alpha}{If \code{TRUE} a fourth layer to set the background transparency is added} \item{colNA}{color for the background (\code{NA} values)} \item{zlim}{vector of lenght 2. Range of values to plot} \item{zlimcol}{If \code{NULL} the values outside the range of zlim get the color of the extremes of the range. If zlimcol has any other value, the values outside the zlim range get the color of \code{NA} values (see colNA)} \item{ext}{An \code{\link{Extent}} object to zoom in to a region of interest (see \code{\link{drawExtent}})} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \seealso{ \code{\link[raster]{plotRGB}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) x <- RGB(r) plot(x, col=gray(0:9/10)) plotRGB(x) } \keyword{methods} \keyword{spatial} raster/man/zoom.Rd0000644000176200001440000000227114507510157013607 0ustar liggesusers\name{zoom} \docType{methods} \alias{zoom} \alias{zoom,Raster-method} \alias{zoom,Spatial-method} \alias{zoom,missing-method} \title{Zoom in on a map} \description{ Zoom in on a map (plot) by providing a new extent, by default this is done by clicking twice on the map. } \usage{ zoom(x, ...) \S4method{zoom}{Raster}(x, ext=drawExtent(), maxpixels=100000, layer=1, new=TRUE, useRaster=TRUE, ...) \S4method{zoom}{Spatial}(x, ext=drawExtent(), new=TRUE, ...) \S4method{zoom}{missing}(x, ext=drawExtent(), new=TRUE, ...) } \arguments{ \item{x}{Raster* or Spatial* (vector type) object} \item{ext}{Extent object, or other object from which an extent can be extracted} \item{maxpixels}{Maximum number of pixels used for the map} \item{layer}{Positive integer to select the layer to be used if x is a mutilayer Raster object} \item{new}{Logical. If \code{TRUE}, the zoomed in map will appear on a new device (window)} \item{useRaster}{Logical. If \code{TRUE}, a bitmap raster is used to plot the image instead of polygons} \item{...}{additional paramters for base plot} } \value{ Extent object (invisibly) } \seealso{ \code{\link[raster]{drawExtent}}, \code{\link[raster]{plot}}} \keyword{spatial} raster/man/properties.Rd0000644000176200001440000000120514507510157015013 0ustar liggesusers\name{properties} \alias{dataSize} \alias{dataSigned} \title{Raster file properties} \description{ Properties of the values of the file that a RasterLayer object points to \code{dataSize} returns the number of bytes used for each value (pixel, grid cell) \code{dataSigned} is TRUE for data types that include negative numbers. } \usage{ dataSize(object) dataSigned(object) } \arguments{ \item{object}{Raster* object} } \seealso{ \code{\link[raster]{filename}} } \value{ varies } \examples{ r <- raster(system.file("external/test.grd", package="raster")) dataSize(r) dataSigned(r) dataType(r) } \keyword{spatial} raster/man/select.Rd0000644000176200001440000000331114507510157014076 0ustar liggesusers\name{select} \docType{methods} \alias{select} \alias{select,Raster-method} \alias{select,Spatial-method} \title{ Geometric subsetting } \description{ Geometrically subset Raster* or Spatial* objects by drawing on a plot (map). } \usage{ \S4method{select}{Raster}(x, use='rec', ...) \S4method{select}{Spatial}(x, use='rec', draw=TRUE, col='cyan', size=2, ...) } \arguments{ \item{x}{Raster*, SpatialPoints*, SpatialLines*, or SpatialPolygons*} \item{use}{character: 'rec' or 'pol'. To use a rectangle or a polygon for selecting} \item{draw}{logical. Add the selected features to the plot?} \item{col}{color to use to draw the selected features (when \code{draw=TRUE)}} \item{size}{integer > 0. Size to draw the selected features with (when \code{draw=TRUE)})} \item{...}{additional arguments. None implemented} } \seealso{ \code{\link{click}, \link{crop}} } \value{ Raster* or Spatial* object } \examples{ \dontrun{ # select a subset of a RasterLayer r <- raster(nrow=10, ncol=10) values(r) <- 1:ncell(r) plot(r) s <- select(r) # now click on the map twice # plot the selection on a new canvas: x11() plot(s) # select a subset of a SpatialPolygons object p1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60), c(-180,-20)) hole <- rbind(c(-150,-20), c(-100,-10), c(-110,20), c(-150,-20)) p2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55), c(-10,0)) p3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45), c(-125,0)) pols <- SpatialPolygons( list( Polygons(list(Polygon(p1), Polygon(hole)), 1), Polygons(list(Polygon(p2)), 2), Polygons(list(Polygon(p3)), 3))) pols@polygons[[1]]@Polygons[[2]]@hole <- TRUE plot(pols, col=rainbow(3)) ps <- select(pols) # now click on the map twice ps } } \keyword{spatial} raster/man/freq.Rd0000644000176200001440000000272014507510157013557 0ustar liggesusers\name{freq} \docType{methods} \alias{freq} \alias{freq,RasterLayer-method} \alias{freq,RasterStackBrick-method} \title{Frequency table} \description{ Frequency table of the values of a RasterLayer. } \usage{ \S4method{freq}{RasterLayer}(x, digits=0, value=NULL, useNA='ifany', progress='', ...) \S4method{freq}{RasterStackBrick}(x, digits=0, value=NULL, useNA='ifany', merge=FALSE, progress='', ...) } \arguments{ \item{x}{RasterLayer} \item{digits}{non-negative integer for rounding the cell values. Argument is passed to \code{round} } \item{value}{numeric, logical or NA. An optional single value to only count the number of cells with that value} \item{useNA}{character. What to do with NA values? Options are "no", "ifany", "always". See to \code{\link[base]{table}} } \item{progress}{character to specify a progress bar. Choose from 'text', 'window', or '' (the default, no progress bar)} \item{merge}{logical. If \code{TRUE} the list will be merged into a single data.frame} \item{...}{additional arguments (none implemented)} } \value{ matrix (RasterLayer). List of matrices (one for each layer) or data.frame (if \code{merge=TRUE}) (RasterStack or RasterBrick) } \seealso{ \code{\link[raster]{crosstab} } and \code{\link[raster]{zonal} } } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) r[1:5] <- NA r <- r * r * r * 5 freq(r) freq(r, value=2) s <- stack(r, r*2, r*3) freq(s, merge=TRUE) } \keyword{spatial} \keyword{univar} raster/man/as.list.Rd0000644000176200001440000000072214507510157014177 0ustar liggesusers\name{as.list} \alias{as.list,Raster-method} \title{Create a list of RasterLayer objects} \description{ Create a list of RasterLayer objects from Raster* objects } \usage{ \S4method{as.list}{Raster}(x, ...) } \arguments{ \item{x}{ Raster* object } \item{...}{additional Raster* objects} } \value{ list } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.list(r) s <- stack(r,r*2,r*3) as.list(s, r) } \keyword{spatial} \keyword{methods} raster/man/isLonLat.Rd0000644000176200001440000000250314507510157014346 0ustar liggesusers\name{isLonLat} \alias{isLonLat} \alias{isLonLat,BasicRaster-method} \alias{isLonLat,Spatial-method} \alias{isLonLat,CRS-method} \alias{isLonLat,character-method} \alias{isLonLat,ANY-method} \alias{couldBeLonLat} \alias{couldBeLonLat,BasicRaster-method} \alias{couldBeLonLat,Spatial-method} \alias{couldBeLonLat,ANY-method} \title{Is this longitude/latitude data?} \description{ Test whether a Raster* or other object has a longitude/latitude coordinate reference system (CRS) by inspecting the PROJ.4 coordinate reference system description. \code{couldBeLonLat} also returns \code{TRUE} if the CRS is \code{NA} but the x coordinates are within -365 and 365 and the y coordinates are within -90.1 and 90.1. } \usage{ \S4method{isLonLat}{BasicRaster}(x, ...) \S4method{isLonLat}{Spatial}(x, ...) \S4method{couldBeLonLat}{BasicRaster}(x, warnings=TRUE, ...) \S4method{couldBeLonLat}{Spatial}(x, warnings=TRUE, ...) } \arguments{ \item{x}{Raster* or Spatial* object} \item{warnings}{logical. If \code{TRUE}, a warning is given if the CRS is \code{NA} or when the CRS is longitude/latitude but the coordinates do not match that} \item{...}{additional arguments. None implemented} } \value{ Logical } \examples{ r <- raster() isLonLat(r) crs(r) <- "+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84" isLonLat(r) } \keyword{spatial} raster/man/bands.Rd0000644000176200001440000000250514507510157013712 0ustar liggesusers\name{bands} \alias{bandnr} \alias{bandnr,RasterLayer-method} \alias{nbands} \title{Number of bands} \description{ A 'band' refers to a single layer for a possibly multi-layer file. Most RasterLayer objects will refer to files with a single layer. The term 'band' is frequently used in remote sensing to refer to a variable (layer) in a multi-variable dataset as these variables typically reperesent reflection in different bandwidths in the electromagnetic spectrum. But in that context, bands could be stored in a single or in separate files. In the context of the raster package, the term band is equivalent to a layer in a raster file. \code{nbands} returns the number of bands of the file that a RasterLayer points to (and 1 if it does not point at any file). This functions also works for a RasterStack for which it is equivalent to \code{\link{nlayers}}. \code{band} returns the specific band the RasterLayer refers to (1 if the RasterLayer points at single layer file or does not point at any file). } \usage{ nbands(x) bandnr(x, ...) } \arguments{ \item{x}{RasterLayer} \item{...}{Additional arguments (none at this time)} } \seealso{\code{\link[raster]{nlayers}}} \value{ numeric >= 1 } \examples{ f <- system.file("external/rlogo.grd", package="raster") r <- raster(f, layer=2) nbands(r) bandnr(r) } \keyword{spatial} raster/man/rectify.Rd0000644000176200001440000000157414507510157014275 0ustar liggesusers\name{rectify} \alias{rectify} \alias{rectify,Raster-method} \title{rectify a Raster object} \description{ rectify changes a rotated Raster* object into a non-rotated (rectangular) object. This is wrapper function around \code{\link{resample}}. } \usage{ \S4method{rectify}{Raster}(x, ext, res, method='ngb', filename='', ...) } \arguments{ \item{x}{Raster* object to be rectified} \item{ext}{Optional. Extent object or object from which an Extent object can be extracted} \item{res}{Optional. Single or two numbers to set the resolution} \item{method}{Method used to compute values for the new RasterLayer, should be "bilinear" for bilinear interpolation, or "ngb" for nearest neighbor } \item{filename}{Character. Output filename } \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick object } \keyword{spatial} raster/man/hist.Rd0000644000176200001440000000244514507510157013575 0ustar liggesusers\name{hist} \docType{methods} \alias{hist} \alias{hist,Raster-method} \title{Histogram} \description{ Create a histogram of the values of a RasterLayer. For large datasets a sample is used. } \usage{ \S4method{hist}{Raster}(x, layer, maxpixels=100000, plot=TRUE, main, ...) } \arguments{ \item{x}{Raster* object} \item{layer}{integer (or character) to indicate layer number (or name). Can be used to subset the layers to plot in a multilayer Raster* object} \item{maxpixels}{integer. To regularly subsample very large objects} \item{plot}{logical. Plot the histogram or only return the histogram values} \item{main}{character. Main title(s) for the plot. Default is the value of \code{\link{names}}} \item{...}{Additional arguments. See under Methods and at \code{\link[graphics]{hist}}} } \value{ This function is principally used for the side-effect of plotting a histogram, but it also returns an S3 object of class 'histogram' (invisibly if \code{plot=TRUE}). } \seealso{ \code{\link{pairs}, \link{boxplot}} } \examples{ r1 <- raster(nrows=50, ncols=50) r1 <- setValues(r1, runif(ncell(r1))) r2 <- setValues(r1, runif(ncell(r1))) rs <- r1 + r2 rp <- r1 * r2 par(mfrow=c(2,2)) plot(rs, main='sum') plot(rp, main='product') hist(rs) a = hist(rp) a } \keyword{methods} \keyword{spatial} raster/man/plotRGB.Rd0000644000176200001440000000636014507510157014137 0ustar liggesusers\name{plotRGB} \docType{methods} \alias{plotRGB} \alias{plotRGB,RasterStackBrick-method} \title{Red-Green-Blue plot of a multi-layered Raster object} \description{ Make a Red-Green-Blue plot based on three layers (in a RasterBrick or RasterStack). Three layers (sometimes referred to as "bands" because they may represent different bandwidths in the electromagnetic spectrum) are combined such that they represent the red, green and blue channel. This function can be used to make 'true (or false) color images' from Landsat and other multi-band satellite images. } \usage{ \S4method{plotRGB}{RasterStackBrick}(x, r=1, g=2, b=3, scale, maxpixels=500000, stretch=NULL, ext=NULL, interpolate=FALSE, colNA='white', alpha, bgalpha, addfun=NULL, zlim=NULL, zlimcol=NULL, axes=FALSE, xlab='', ylab='', asp=NULL, add=FALSE, margins=FALSE, ...) } \arguments{ \item{x}{RasterBrick or RasterStack} \item{r}{integer. Index of the Red channel, between 1 and nlayers(x)} \item{g}{integer. Index of the Green channel, between 1 and nlayers(x)} \item{b}{integer. Index of the Blue channel, between 1 and nlayers(x)} \item{scale}{integer. Maximum (possible) value in the three channels. Defaults to 255 or to the maximum value of \code{x} if that is known and larger than 255} \item{maxpixels}{integer > 0. Maximum number of pixels to use} \item{stretch}{character. Option to stretch the values to increase the contrast of the image: "lin" or "hist"} \item{ext}{An \code{\link{Extent}} object to zoom in to a region of interest (see \code{\link{drawExtent}})} \item{interpolate}{logical. If \code{TRUE}, interpolate the image when drawing} \item{colNA}{color for the background (\code{NA} values)} \item{alpha}{transparency. Integer between 0 (transparent) and 255 (opaque)} \item{bgalpha}{Background transparency. Integer between 0 (transparent) and 255 (opaque)} \item{addfun}{Function to add additional items such as points or polygons to the plot (map). See \code{\link[raster]{plot}}} \item{zlim}{numeric vector of length 2. Range of values to plot (optional)} \item{zlimcol}{If \code{NULL} the values outside the range of zlim get the color of the extremes of the range. If zlimcol has any other value, the values outside the zlim range get the color of \code{NA} values (see colNA)} \item{axes}{logical. If \code{TRUE} axes are drawn (and arguments such as \code{main="title"} will be honored)} \item{xlab}{character. Label of x-axis} \item{ylab}{character. Label of y-axis} \item{asp}{numeric. Aspect (ratio of x and y. If NULL, and appropriate value is computed to match data for the longitude/latitude coordinate reference system, and 1 for planar coordinate reference systems} \item{add}{logical. If \code{TRUE} add values to current plot} \item{margins}{logical. If \code{TRUE} standard whitespace margins are used. If \code{FALSE}, graphics::par(plt=c(0,1,0,1)) is used} \item{...}{graphical parameters as in \code{\link{plot}} or \code{\link{rasterImage}}} } \author{Robert J. Hijmans; stretch option based on functions by Josh Gray } \seealso{ \code{\link[raster]{plot}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) plotRGB(b) plotRGB(b, 3, 2, 1) plotRGB(b, 3, 2, 1, stretch='hist') } \keyword{methods} \keyword{spatial} raster/man/unique.Rd0000644000176200001440000000230714507510157014131 0ustar liggesusers\name{unique} \docType{methods} \alias{unique} \alias{unique,RasterLayer,missing-method} \alias{unique,RasterStackBrick,missing-method} \title{Unique values} \description{ This function returns the unique values in a RasterLayer object or the unique combinations of the layers in a multilayer object. } \usage{ \S4method{unique}{RasterLayer,missing}(x, incomparables=FALSE, na.last=NA, progress="", ...) \S4method{unique}{RasterStackBrick,missing}(x, incomparables=FALSE, na.last=NA, progress="", ...) } \arguments{ \item{x}{Raster object} \item{incomparables}{must be missing. The default value \code{FALSE} is used. See \code{\link[base]{unique}}} \item{na.last}{logical. for controlling the treatment of \code{NA}s. If \code{TRUE}, missing values in the data are put last; if \code{FALSE}, they are put first; if \code{NA}, they are removed.} \item{progress}{character. Use "text" or "window" for a progress indicator} \item{...}{additional arguments. as in \code{\link[base]{unique}}} } \seealso{ \code{\link[base]{unique}} } \value{ vector or matrix } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- round(runif(ncell(r))*10) unique(r) unique(stack(r, round(r/2))) } \keyword{spatial} raster/man/programming.Rd0000644000176200001440000000535414507510157015152 0ustar liggesusers\name{Programming} \alias{readStart} \alias{readStop} \alias{readStart,Raster-method} \alias{readStart,RasterStack-method} \alias{readStop,Raster-method} \alias{readStop,RasterStack-method} \alias{canProcessInMemory} \alias{pbCreate} \alias{pbStep} \alias{pbClose} \alias{getCluster} \alias{returnCluster} \title{Helper functions for programming} \description{ These are low level functions that can be used by programmers to develop new functions. If in doubt, it is almost certain that you do not need these functions as these are already embedded in all other functions in the raster package. \code{canProcessInMemory} is typically used within functions. In the raster package this function is used to determine if the amount of memory needed for the function is available. If there is not enough memory available, the function returns \code{FALSE}, and the function that called it will write the results to a temporary file. readStart opens file connection(s) for reading, readStop removes it. pbCreate creates a progress bar, pbStep sets the progress, and pbClose closes it. } \usage{ canProcessInMemory(x, n=4, verbose=FALSE) pbCreate(nsteps, progress, style=3, label='Progress', ...) pbStep(pb, step=NULL, label='') pbClose(pb, timer) readStart(x, ...) readStop(x) getCluster() returnCluster() } \arguments{ \item{x}{RasterLayer or RasterBrick object (for connections) or RasterStack object (canProcessInMemory)} \item{n}{integer. The number of copies of the Raster* object cell values that a function needs to be able to have in memory} \item{verbose}{logical. If \code{TRUE} the amount of memory needed and available is printed} \item{nsteps}{integer. Number of steps the progress bar will make from start to end (e.g. nrow(raster)) } \item{progress}{character. 'text', 'window', or ''} \item{style}{style for text progress bar. See \code{\link[utils]{txtProgressBar}} } \item{label}{character. Label for the window type progress bar} \item{...}{additional arguments (None implemented, except for 'silent=TRUE' for readStart for files read with gdal, and other arguments passed to gdal.open)} \item{pb}{ progress bar object created with pbCreate } \item{step}{which step is this ( 1 <= step <= nsteps ). If step is \code{NULL}, a single step is taken } \item{timer}{logical. If \code{TRUE}, time to completion will be printed. If missing, the value will be taken from the rasterOptions} } \value{ canProcessInMemory: logical closeConnection: RasterLayer or RasterBrick object getCluster: snow cluster object } \examples{ r <- raster(nrow=100, ncol=100) canProcessInMemory(r, 4) r <- raster(nrow=50000, ncol=50000) canProcessInMemory(r, 2, verbose=TRUE) rasterOptions(maxmem=Inf, memfrac=.8) rasterOptions(default=TRUE) } \keyword{ spatial } raster/man/compareCRS.Rd0000644000176200001440000000225614507510157014624 0ustar liggesusers\name{compareCRS} \alias{compareCRS} \title{ Partially compare two CRS objects } \description{ Compare CRS objects } \usage{ compareCRS(x, y, unknown=FALSE, verbatim=FALSE, verbose=FALSE) } \arguments{ \item{x}{CRS object, or object from which it can be extracted with \code{\link{projection}}, or PROJ.4 format character string} \item{y}{same as \code{x}} \item{unknown}{logical. Return \code{TRUE} if \code{x} or \code{y} is \code{TRUE}} \item{verbatim}{logical. If \code{TRUE} compare \code{x} and \code{y}, verbatim (not partially)} \item{verbose}{logical. If \code{TRUE}, messages about the comparison may be printed} } \value{ logical } \seealso{\code{sp::identicalCRS}, \code{\link{crs} }} \examples{ compareCRS("+proj=lcc +lat_1=48 +lat_2=33 +lon_0=-100 +ellps=WGS84", "+proj=longlat +datum=WGS84") compareCRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0", "+proj=longlat +datum=WGS84") compareCRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0", "+proj=longlat +datum=WGS84", verbatim=TRUE) compareCRS("+proj=longlat +datum=WGS84", NA) compareCRS("+proj=longlat +datum=WGS84", NA, unknown=TRUE) } \keyword{ spatial } raster/man/as.logical-methods.Rd0000644000176200001440000000160114507510157016274 0ustar liggesusers\name{as.logical} \docType{methods} \alias{as.logical,Raster-method} \alias{as.integer,Raster-method} \title{ Change cell values to logical or integer values} \description{ Change values of a Raster* object to logical or integer values. With \code{as.logical}, zero becomes \code{FALSE}, all other values become \code{TRUE}. With \code{as.integer} values are truncated. } \usage{ \S4method{as.logical}{Raster}(x, filename='', ...) \S4method{as.integer}{Raster}(x, filename='', ...) } \arguments{ \item{x}{Raster* object} \item{filename}{character. Output filename (optional)} \item{...}{additional optional arguments as for \code{\link{writeRaster}}} } \seealso{ \code{\link[base]{logical}}, \code{\link[base]{integer}} } \examples{ r <- raster(nrow=10, ncol=10) set.seed(0) values(r) <- runif(ncell(r)) * 10 r r <- as.integer(r) r as.logical(r) } \keyword{methods} \keyword{spatial} raster/man/spplot.Rd0000644000176200001440000000420714507510157014145 0ustar liggesusers\name{spplot} \docType{methods} \alias{spplot} \alias{spplot,Raster-method} \alias{spplot,SpatRaster-method} \alias{spplot,SpatialPoints-method} \alias{spplot,SpatialLines-method} \alias{spplot,SpatialPolygons-method} \alias{lines,SpatialPolygons-method} \alias{spplot,SpatVector-method} \title{Use spplot to plot a Raster* or other object} \description{ A wrapper function around \link[sp]{spplot} (sp package). With spplot it is easy to map several layers with a single legend for all maps. ssplot is itself a wrapper around the \link[lattice]{levelplot} function in the lattice package, and see the help for these functions for additional options. One of the advantages of the wrapper function for Raster* objects is the additional \code{maxpixels} argument to sample large objects for faster drawing. There are also added spplot methods for Spatial objects that have no data.frame and for SpatVector (terra package) } \usage{ \S4method{spplot}{Raster}(obj, ..., maxpixels=50000, as.table=TRUE, zlim) } \arguments{ \item{obj}{Raster* object} \item{...}{Any argument that can be passed to \code{\link[sp]{spplot}} and \link[lattice]{levelplot}} \item{maxpixels}{integer. Number of pixels to sample from each layer of large Raster objects} \item{as.table}{If \code{TRUE}, the plots are ordered from top to bottom} \item{zlim}{Vector of two elements indicating the minimum and maximum values to be mapped (values outside that ranage are set to these limits)} } \seealso{ \code{ \link[raster]{plot}, \link[raster]{plotRGB} } The rasterVis package has more advanced plotting methods for Raster objects } \examples{ r <- raster(system.file("external/test.grd", package="raster")) s <- stack(r, r*2) names(s) <- c('meuse', 'meuse x 2') spplot(s) pts <- data.frame(sampleRandom(r, 10, xy=TRUE)) coordinates(pts) <- ~ x + y spplot(s, scales = list(draw = TRUE), xlab = "easting", ylab = "northing", col.regions = rainbow(99, start=.1), names.attr=c('original', 'times two'), sp.layout = list("sp.points", pts, pch=20, cex=2, col='black'), par.settings = list(fontsize = list(text = 12)), at = seq(0, 4000, 500)) } \keyword{methods} \keyword{spatial} raster/man/slopeAspect.Rd0000644000176200001440000000102514507510157015101 0ustar liggesusers\name{Slope and aspect} \alias{slopeAspect} \title{Slope and aspect} \description{ DEPRACATED. Use \code{\link{terrain}} instead. } \usage{ slopeAspect(dem, filename='', out=c('slope', 'aspect'), unit='radians', neighbors=8, flatAspect, ...) } \arguments{ \item{dem}{DEPRACATED} \item{filename}{DEPRACATED} \item{out}{DEPRACATED} \item{unit}{DEPRACATED} \item{neighbors}{DEPRACATED} \item{flatAspect}{DEPRACATED} \item{...}{DEPRACATED} } \seealso{ \code{\link{terrain}} } \keyword{spatial} raster/man/stackSelect.Rd0000644000176200001440000000305414507510157015070 0ustar liggesusers\name{stackSelect} \alias{stackSelect} \alias{stackSelect,RasterStackBrick,Raster-method} \title{Select cell values from a multi-layer Raster* object} \description{ Use a Raster* object to select cell values from different layers in a multi-layer Raster* object. The object to select values \code{y} should have values between \code{1} and \code{nlayers(x)}. The values of \code{y} are rounded. See \code{\link{extract}} for extraction of values by cell, point, or otherwise. } \usage{ \S4method{stackSelect}{RasterStackBrick,Raster}(x, y, recycle=FALSE, type='index', filename='', ...) } \arguments{ \item{x}{RasterStack or RasterBrick object} \item{y}{Raster* object} \item{recycle}{Logical. Recursively select values (default = \code{FALSE}. Only relevant if \code{y} has multiple layers. E.g. if \code{x} has 12 layers, and \code{y} has 4 layers, the indices of the \code{y} layers are used three times.} \item{type}{Character. Only relevant when \code{recycle=TRUE}. Can be 'index' or 'truefalse'. If it is 'index', the cell values of \code{y} should represent layer numbers. If it is 'truefalse' layer numbers are indicated by 0 (not used, NA returned) and 1 (used)} \item{filename}{Character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ Raster* object } \seealso{\code{\link{stackApply}}, \code{\link{extract}}} \examples{ r <- raster(ncol=10, nrow=10, vals=1) s <- stack(r, r+2, r+5) values(r) <- round((runif(ncell(r)))*3) x <- stackSelect(s, r) } \keyword{methods} \keyword{spatial} raster/man/NAvalue.Rd0000644000176200001440000000176714507510157014167 0ustar liggesusers\name{NAvalue} \alias{NAvalue<-} \alias{NAvalue} \title{Set the NA value of a RasterLayer } \description{ NAvalue returns the value that is used to write NA values to disk (in 'raster' type files). If you set the NA value of a Raster* object, this value will be interpreted as NA when reading the values from a file. Values already in memory will not be affected. If the NA value is smaller than zero, all values smaller or equal to that number will be set to NA. } \usage{ NAvalue(x) <- value NAvalue(x) } \arguments{ \item{x}{A \code{Raster} object} \item{value}{the value to be interpreted as NA; set this before reading the values from the file. Integer values are matched exactly; for decimal values files any value <= the value will be interpreted as NA} } \value{ Returns or set the NA value used for storage on disk. } \examples{ r1 <- raster(system.file("external/rlogo.grd", package="raster")) r2 <- r1 NAvalue(r2) NAvalue(r2) <- 255 #plot(r1) #x11() #plot(r2) } \keyword{ spatial } raster/man/weighted.mean.Rd0000644000176200001440000000261714507510157015346 0ustar liggesusers\name{weighted.mean} \alias{weighted.mean} \alias{weighted.mean,RasterStackBrick,vector-method} \alias{weighted.mean,RasterStackBrick,RasterStackBrick-method} \title{Weighted mean of rasters} \description{ Computes the weighted mean for each cell of a number or raster layers. The weights can be spatially variable or not. } \usage{ \S4method{weighted.mean}{RasterStackBrick,vector}(x, w, na.rm=FALSE, filename='', ...) \S4method{weighted.mean}{RasterStackBrick,RasterStackBrick}(x, w, na.rm=FALSE,filename='', ...) } \arguments{ \item{x}{RasterStack or RasterBrick} \item{w}{A vector of weights (one number for each layer), or for spatially variable weights, a RasterStack or RasterBrick with weights (should have the same extent, resolution and number of layers as x)} \item{na.rm}{Logical. Should missing values be removed?} \item{filename}{Character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer } \seealso{ \code{\link{Summary-methods}}, \code{\link[stats]{weighted.mean}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) # give least weight to first layer, most to last layer wm1 <- weighted.mean(b, w=1:3) # spatially varying weights # weigh by column number w1 <- init(b, v='col') # weigh by row number w2 <- init(b, v='row') w <- stack(w1, w2, w2) wm2 <- weighted.mean(b, w=w) } raster/man/mask.Rd0000644000176200001440000000535114507510157013560 0ustar liggesusers\name{mask} \docType{methods} \alias{mask} \alias{mask,RasterLayer,RasterLayer-method} \alias{mask,RasterStackBrick,RasterLayer-method} \alias{mask,RasterLayer,RasterStackBrick-method} \alias{mask,RasterStackBrick,RasterStackBrick-method} \alias{mask,Raster,Spatial-method} \alias{mask,Raster,sf-method} \title{Mask values in a Raster object} \description{ Create a new Raster* object that has the same values as \code{x}, except for the cells that are \code{NA} (or other \code{maskvalue}) in a 'mask'. These cells become \code{NA} (or other \code{updatevalue}). The mask can be either another Raster* object of the same extent and resolution, or a Spatial* object (e.g. SpatialPolygons) in which case all cells that are not covered by the Spatial object are set to \code{updatevalue}. You can use \code{inverse=TRUE} to set the cells that are not \code{NA} (or other \code{maskvalue}) in the mask, or not covered by the Spatial* object, to \code{NA} (or other \code{updatvalue}). } \usage{ \S4method{mask}{RasterLayer,RasterLayer}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{RasterStackBrick,RasterLayer}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{RasterLayer,RasterStackBrick}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{RasterStackBrick,RasterStackBrick}(x, mask, filename="", inverse=FALSE, maskvalue=NA, updatevalue=NA, updateNA=FALSE, ...) \S4method{mask}{Raster,Spatial}(x, mask, filename="", inverse=FALSE, updatevalue=NA, updateNA=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{mask}{Raster* object or a Spatial* object} \item{filename}{character. Optional output filename} \item{inverse}{logical. If \code{TRUE}, areas on mask that are _not_ the \code{maskvalue} are masked} \item{maskvalue}{numeric. The value in \code{mask} that indicates the cells of \code{x} that should become \code{updatevalue} (default = \code{NA})} \item{updatevalue}{numeric. The value that cells of \code{x} should become if they are not covered by \code{mask} (and not \code{NA})} \item{updateNA}{logical. If \code{TRUE}, \code{NA} values outside the masked area are also updated to the the \code{updatevalue} (only relevant if the \code{updatevalue} is not \code{NA}} \item{...}{additional arguments as in \code{\link{writeRaster}}} } \value{Raster* object} \seealso{\code{\link{rasterize}, \link{crop}}} \examples{ r <- raster(ncol=10, nrow=10) m <- raster(ncol=10, nrow=10) values(r) <- runif(ncell(r)) * 10 values(m) <- runif(ncell(r)) m[m < 0.5] <- NA mr <- mask(r, m) m2 <- m > .7 mr2 <- mask(r, m2, maskvalue=TRUE) } \keyword{methods} \keyword{spatial} raster/man/overlay.Rd0000644000176200001440000001132014507510157014277 0ustar liggesusers\name{overlay} \docType{methods} \alias{overlay} \alias{overlay,Raster,Raster-method} \alias{overlay,Raster,missing-method} \title{Overlay Raster objects} \description{ Create a new Raster* object, based on two or more Raster* objects. (You can also use a single object, but perhaps \code{\link{calc}} is what you are looking for in that case). You should supply a function \code{fun} to set the way that the RasterLayers are combined. The number of arguments in the function must match the number of Raster objects (or take any number). For example, if you combine two RasterLayers you could use multiply: \code{fun=function(x,y){return(x*y)}} percentage: \code{fun=function(x,y){return(100 * x / y)}}. If you combine three layers you could use \code{fun=function(x,y,z){return((x + y) * z)}} Note that the function must work for vectors (not only for single numbers). That is, it must return the same number of elements as its input vectors. Alternatively, you can also supply a function such as \code{sum}, that takes \code{n} arguments (as \code{'...'}), and perhaps also has a \code{na.rm} argument, like in \code{sum(..., na.rm)}. If a single mutli-layer object is provided, its layers are treated as individual RasterLayer objects if the argument \code{unstack=TRUE} is used. If multiple objects are provided, they should have the same number of layers, or it should be possible to recycle them (e.g., 1, 3, and 9 layers, which would return a RasterBrick with 9 layers). } \usage{ \S4method{overlay}{Raster,Raster}(x, y, ..., fun, filename="", recycle=TRUE, forcefun=FALSE) \S4method{overlay}{Raster,missing}(x, y, ..., fun, filename="", unstack=TRUE, forcefun=FALSE) } \arguments{ \item{x}{Raster* object} \item{y}{Raster* object, or missing (only useful if \code{x} has multiple layers)} \item{...}{Additional Raster objects (and/or arguments for writing files as in \code{\link{writeRaster})}} \item{fun}{Function to be applied. When using RasterLayer objects, the number of arguments of the function should match the number of Raster objects, or it should take any number of arguments. When using multi-layer objects the function should match the number of layers of the RasterStack/Brick object (unless unstack=FALSE) } \item{filename}{Character. Output filename (optional) } \item{recycle}{Logical. Should layers from Raster objects with fewer layers be recycled?} \item{unstack}{Logical. Should layers be unstacked before computation (i.e. does the \code{fun} refer to individual layers in a multilayer object)?} \item{forcefun}{Boolean. If \code{TRUE}, overlay will not attempt to internally use apply (it is rarely necessary to use this argument)} } \details{ Instead of the overlay function you can also use arithmetic functions such as \code{*, /, +, -} with Raster objects (see examples). In that case you cannot specify an output filename. Moreover, the overlay function should be more efficient when using large data files that cannot be loaded into memory, as the use of the complex arithmetic functions might lead to the creation of many temporary files. While you can supply functions such as \code{sum} or \code{mean}, it would be more direct to use the Raster* objects as arguments to those functions (e.g. \code{sum(r1,r2,r3)}) See \code{\link{rasterize}} and \code{\link{extract}} for "overlays" involving Raster* objects and polygons, lines, or points. } \value{ Raster* object } \seealso{\code{ \link[raster]{calc}, \link[raster]{Arith-methods}} } \examples{ r <- raster(ncol=10, nrow=10) r1 <- init(r, fun=runif) r2 <- init(r, fun=runif) r3 <- overlay(r1, r2, fun=function(x,y){return(x+y)}) # long version for multiplication r4 <- overlay(r1, r2, fun=function(x,y){(x*y)} ) #use the individual layers of a RasterStack to get a RasterLayer s <- stack(r1, r2) r5 <- overlay(s, fun=function(x,y) x*y ) # equivalent to r5c <- calc(s, fun=function(x) x[1]*x[2] ) #Combine RasterStack and RasterLayer objects (s2 has four layers. # r1 (one layer) and s (two layers) are recycled) s2 <- stack(r1, r2, r3, r4) b <- overlay(r1, s, s2, fun=function(x,y,z){return(x*y*z)} ) # use a single RasterLayer (same as calc function) r6 <- overlay(r1, fun=sqrt) # multiplication with more than two layers # (make sure the number of RasterLayers matches the arguments of 'fun') r7 <- overlay(r1, r2, r3, r4, fun=function(a,b,c,d){return(a*b+c*d)} ) # equivalent function, efficient if values can be loaded in memory r8 <- r1 * r2 + r3 * r4 # Also works with multi-layer objects. s1 <- stack(r1, r2, r3) x <- overlay(s1, s1, fun=function(x,y)x+y+5) # in this case the first layer of the shorter object is recycled. # i.e., s2 is treated as stack(r1, r3, r1) s2 <- stack(r1, r3) y <- overlay(s1, s2, fun=sum) } \keyword{methods} \keyword{spatial} raster/man/iniFile.Rd0000644000176200001440000000216514507510157014204 0ustar liggesusers\name{inifile} \alias{readIniFile} \title{Read a .ini file} \description{ This function reads \code{'.ini'} files. These are text file databases that are organized in [sections] containing pairs of "name = value". } \usage{ readIniFile(filename, token='=', commenttoken=';', aslist=FALSE, case) } \arguments{ \item{filename}{Character. Filename of the .ini file} \item{token}{Character. The character that separates the "name" (variable name) from the "value"} \item{commenttoken}{Character. This token and everything that follows on the same line is considered a 'comment' that is not for machine consumption and is ignored in processing} \item{aslist}{Logical. Should the values be returned as a list} \item{case}{Optional. Function that operates on the text, such as \code{\link{toupper}} or \code{\link{tolower}} } } \details{ This function allows for using inistrings that have "=" as part of a value (but the token cannot be part of the 'name' of a variable!). Sections can be missing. } \value{ A n*3 matrix of characters with columns: section, name, value; or a list if \code{aslist=TRUE}. } \keyword{file} raster/man/hillShade.Rd0000644000176200001440000000224014545422524014516 0ustar liggesusers\name{hillShade} \alias{hillShade} \title{Hill shading} \description{ Compute hill shade from slope and aspect layers (both in radians). Slope and aspect can be computed with function \code{\link{terrain}}. A hill shade layer is often used as a backdrop on top of which another, semi-transparent, layer is drawn. } \usage{ hillShade(slope, aspect, angle=45, direction=0, filename='', normalize=FALSE, ...) } \arguments{ \item{slope}{RasterLayer object with slope values (in radians) } \item{aspect}{RasterLayer object with aspect values (in radians) } \item{angle}{ The the elevation angle of the light source (sun), in degrees} \item{direction}{ The direction (azimuth) angle of the light source (sun), in degrees} \item{filename}{Character. Optional filename} \item{normalize}{Logical. If \code{TRUE}, values below zero are set to zero and the results are multiplied with 255} \item{...}{Standard additional arguments for writing RasterLayer files} } \seealso{ \code{\link{terrain}} } \author{Andrew Bevan, Robert J. Hijmans} \references{ Horn, B.K.P., 1981. Hill shading and the reflectance map. Proceedings of the IEEE 69(1):14-47 } \keyword{spatial} raster/man/Compare-methods.Rd0000644000176200001440000000304714507510157015654 0ustar liggesusers\name{Compare-methods} \docType{methods} \alias{Compare-methods} \alias{Compare,Extent,Extent-method} \alias{Compare,Raster,Raster-method} \alias{Compare,Raster,logical-method} \alias{Compare,Raster,numeric-method} \alias{Compare,logical,Raster-method} \alias{Compare,numeric,Raster-method} \alias{==,BasicRaster,BasicRaster-method} \alias{!=,BasicRaster,BasicRaster-method} \title{Compare Raster* objects} \description{ These methods compare the location and resolution of Raster* objects. That is, they compare their spatial extent, projection, and number of rows and columns. For \code{BasicRaster} objects you can use \code{==} and \code{!=}, the values returned is a single logical value \code{TRUE} or \code{FALSE} For RasterLayer objects, these operators also compare the values associated with the objects, and the result is a RasterLayer object with logical (Boolean) values. The following methods have been implemented for RasterLayer objects: \code{==, !=, >, <, <=, >=} } \value{ A logical value or a RasterLayer object, and in some cases the side effect of a new file on disk. } \examples{ r1 <- raster() r1 <- setValues(r1, round(10 * runif(ncell(r1)))) r2 <- setValues(r1, round(10 * runif(ncell(r1)))) as(r1, 'BasicRaster') == as(r2, 'BasicRaster') r3 <- r1 == r2 b <- extent(0, 360, 0, 180) r4 <- setExtent(r2, b) as(r2, 'BasicRaster') != as(r4, 'BasicRaster') # The following would give an error. You cannot compare RasterLayer # that do not have the same BasicRaster properties. #r3 <- r1 > r4 } \keyword{methods} \keyword{math} raster/man/Extent-class.Rd0000644000176200001440000000157714507510157015205 0ustar liggesusers\name{Extent-class} \docType{class} \alias{Extent} \alias{Extent-class} \alias{show,Extent-method} \title{Class "Extent" } \description{ Objects of class Extent are used to define the spatial extent (extremes) of objects of the BasicRaster and Raster* classes. } \section{Objects from the Class}{ You can use the \code{\link{extent}} function to create Extent objects, or to extract them from Raster* and Spatial* objects. } \section{Slots}{ \describe{ \item{\code{xmin}:}{minimum x coordinate} \item{\code{xmax}:}{maximum x coordinate} \item{\code{ymin}:}{minumum y coordinate} \item{\code{ymax}:}{maximum y coordinate} } } \section{Methods}{ \describe{ \item{show}{display values of a Extent object } } } \seealso{ \code{\link{extent}}, \code{\link[raster]{setExtent}} } \examples{ ext <- extent(-180,180,-90,90) ext } \keyword{classes} \keyword{spatial} raster/man/filledContour.Rd0000644000176200001440000000142614507510157015435 0ustar liggesusers\name{filledContour} \alias{filledContour} \title{Filled contour plot} \description{ Filled contour plot of a RasterLayer. This is a wrapper around \code{\link[graphics]{filled.contour}} for RasterLayer objects. } \usage{ filledContour(x, y=1, maxpixels=100000, ...) } \arguments{ \item{x}{A Raster* object} \item{y}{Integer. The layer number of x (if x has multiple layers)} \item{maxpixels}{The maximum number of pixels} \item{...}{Any argument that can be passed to \code{\link[graphics]{filled.contour}} (graphics package)} } \seealso{ \code{\link[graphics]{filled.contour}}, \code{\link[raster]{persp}}, \code{\link[raster]{plot}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) filledContour(r) } \keyword{methods} \keyword{spatial} raster/man/rasterToContour.Rd0000644000176200001440000000145314507510157016001 0ustar liggesusers\name{rasterToContour} \alias{rasterToContour} \title{ Raster to contour lines conversion} \description{ RasterLayer to contour lines. This is a wrapper around \code{\link[grDevices]{contourLines}} } \usage{ rasterToContour(x, maxpixels=100000, ...) } \arguments{ \item{x}{ a RasterLayer object } \item{maxpixels}{ Maximum number of raster cells to use; this function fails when too many cells are used} \item{...}{Any argument that can be passed to \code{\link[grDevices]{contourLines}} } } \details{ Most of the code was taken from maptools::ContourLines2SLDF, by Roger Bivand & Edzer Pebesma } \value{ SpatialLinesDataFrame } \examples{ f <- system.file("external/test.grd", package="raster") r <- raster(f) x <- rasterToContour(r) class(x) plot(r) plot(x, add=TRUE) } \keyword{ spatial } raster/man/buffer.Rd0000644000176200001440000000313514507510157014074 0ustar liggesusers\name{buffer} \alias{buffer} \alias{buffer,RasterLayer-method} \alias{buffer,Spatial-method} \title{buffer} \description{ Calculate a buffer around all cells that are not \code{NA} or around SpatialPoints, Lines, or Polygons. Note that the distance unit of the buffer \code{width} parameter is meters if the RasterLayer is not projected (\code{+proj=longlat}), and in map units (typically also meters) when it is projected. } \usage{ \S4method{buffer}{RasterLayer}(x, width=0, filename='', doEdge=FALSE, ...) \S4method{buffer}{Spatial}(x, width=1, dissolve=TRUE, ...) } \arguments{ \item{x}{RasterLayer or Spatial* object} \item{width}{numeric > 0. Unit is meter if \code{x} has a longitude/latitude CRS, or mapunits in other cases} \item{filename}{character. Filename for the output RasterLayer (optional)} \item{doEdge}{logical. If \code{TRUE}, the \code{\link{boundaries}} function is called first. This may be efficient in cases where you compute a buffer around very large areas because \code{boundaries} determines the edge cells that matter for distance computation} \item{dissolve}{logical. If \code{TRUE}, buffer geometries of overlapping polygons are dissolved and all geometries are aggregated and attributes (the data.frame) are dropped} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{RasterLayer or SpatialPolygons* object} \seealso{ \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} } \examples{ r <- raster(ncol=36,nrow=18) values(r) <- NA r[500] <- 1 b <- buffer(r, width=5000000) #plot(b) } \keyword{spatial} raster/man/brick.Rd0000644000176200001440000001056014507510157013715 0ustar liggesusers\name{brick} \docType{methods} \alias{brick} \alias{brick,character-method} \alias{brick,missing-method} \alias{brick,RasterLayer-method} \alias{brick,RasterStack-method} \alias{brick,RasterBrick-method} \alias{brick,Extent-method} \alias{brick,array-method} \alias{brick,list-method} \alias{brick,SpatialPixels-method} \alias{brick,SpatialGrid-method} \alias{brick,kasc-method} \alias{brick,grf-method} \alias{brick,SpatRaster-method} \title{ Create a RasterBrick object} \description{ A RasterBrick is a multi-layer raster object. They are typically created from a multi-layer (band) file; but they can also exist entirely in memory. They are similar to a RasterStack (that can be created with \code{\link[raster]{stack}}), but processing time should be shorter when using a RasterBrick. Yet they are less flexible as they can only point to a single file. A RasterBrick can be created from RasterLayer objects, from a RasterStack, or from a (multi-layer) file. The can also be created from SpatialPixels*, SpatialGrid*, and Extent objects, and from a three-dimensional array. } \usage{ \S4method{brick}{character}(x, ...) \S4method{brick}{RasterStack}(x, values=TRUE, nl, filename='', ...) \S4method{brick}{RasterBrick}(x, nl, ...) \S4method{brick}{RasterLayer}(x, ..., values=TRUE, nl=1, filename='') \S4method{brick}{missing}(nrows=180, ncols=360, xmn=-180, xmx=180, ymn=-90, ymx=90, nl=1, crs) \S4method{brick}{Extent}(x, nrows=10, ncols=10, crs="", nl=1) \S4method{brick}{array}(x, xmn=0, xmx=1, ymn=0, ymx=1, crs="", transpose=FALSE) \S4method{brick}{SpatialGrid}(x) \S4method{brick}{SpatialPixels}(x) } \arguments{ \item{x}{character (filename, see Details); Raster* object; missing; array; SpatialGrid*; SpatialPixels*; Extent; or list of Raster* objects. Supported file types are the 'native' raster package format and those that can be read via GDAL, and NetCDF files (see details)} \item{...}{see Details} \item{values}{logical. If \code{TRUE}, the cell values of '\code{x}' are copied to the RasterBrick object that is returned} \item{nl}{integer > 0. How many layers should the RasterBrick have?} \item{filename}{character. Filename if you want the RasterBrick to be saved on disk} \item{nrows}{integer > 0. Number of rows} \item{ncols}{integer > 0. Number of columns} \item{xmn}{minimum x coordinate (left border)} \item{xmx}{maximum x coordinate (right border)} \item{ymn}{minimum y coordinate (bottom border)} \item{ymx}{maximum y coordinate (top border)} \item{crs}{character or object of class CRS. PROJ4 type description of a Coordinate Reference System (map projection). If this argument is missing, and the x coordinates are within -360 .. 360 and the y coordinates are within -90 .. 90, "+proj=longlat +datum=WGS84" is used} \item{transpose}{if \code{TRUE}, the values in the array are transposed} } \details{ If \code{x} is a RasterLayer, the additional arguments can be used to pass additional Raster* objects. If there is a \code{filename} argument, the additional arguments are as for \code{\link{writeRaster}}. If \code{x} represents a filename there is the following additional argument: \code{native}: logical. If \code{TRUE} (not the default), reading and writing of IDRISI, BIL, BSQ, BIP, and Arc ASCII files is done with native (raster package) drivers, rather then via GDAL. In addition, if \code{x} is a \bold{NetCDF} filename there are the following additional arguments: \code{varname}: character. The variable name (e.g. 'altitude' or 'precipitation'. If not supplied and the file has multiple variables are a guess will be made (and reported)) \code{lvar}: integer > 0 (default=3). To select the 'level variable' (3rd dimension variable) to use, if the file has 4 dimensions (e.g. depth instead of time) \code{level}: integer > 0 (default=1). To select the 'level' (4th dimension variable) to use, if the file has 4 dimensions, e.g. to create a RasterBrick of weather over time at a certain height. \code{dims}: integer vector to indicated the order of the dimensions. Default is \code{dims=c(1,2,3)} (rows, cols, time). To use NetCDF files the \code{ncdf4} package needs to be available. It is assumed that these files follow, or are compatible with the CF-1 convention. } \value{ RasterBrick } \seealso{ \code{\link[raster]{raster}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) b nlayers(b) names(b) extract(b, 870) } \keyword{methods} \keyword{spatial} raster/man/stack.Rd0000644000176200001440000000477514507510157013743 0ustar liggesusers\name{stack} \docType{methods} \alias{stack} \alias{stack,character-method} \alias{stack,Raster-method} \alias{stack,list-method} \alias{stack,missing-method} \alias{stack,SpatialPixelsDataFrame-method} \alias{stack,SpatialGridDataFrame-method} \alias{stack,kasc-method} \alias{stack,SpatRaster-method} \title{Create a RasterStack object} \description{ A RasterStack is a collection of RasterLayer objects with the same spatial extent and resolution. A RasterStack can be created from RasterLayer objects, or from raster files, or both. It can also be created from a SpatialPixelsDataFrame or a SpatialGridDataFrame object. } \usage{ \S4method{stack}{character}(x, ..., bands=NULL, varname="", native=FALSE, RAT=TRUE, quick=FALSE) \S4method{stack}{Raster}(x, ..., layers=NULL) \S4method{stack}{missing}(x) \S4method{stack}{list}(x, bands=NULL, native=FALSE, RAT=TRUE, ...) } \arguments{ \item{x}{filename (character), Raster* object, missing (to create an empty RasterStack), SpatialGrid*, SpatialPixels*, or list (of filenames and/or Raster* objects). If \code{x} is a list, additional arguments \code{...} are ignored} \item{bands}{integer. which bands (layers) of the file should be used (default is all layers)} \item{layers}{integer (or character with layer names) indicating which layers of a RasterBrick should be used (default is all layers)} \item{native}{logical. If \code{TRUE} native drivers are used instead of gdal drivers (where available, such as for BIL and Arc-ASCII files)} \item{RAT}{logical. If \code{TRUE} a raster attribute table is created for files that have one} \item{quick}{logical. If \code{TRUE} the extent and resolution of the objects are not compared. This speeds up the creation of the RasteStack but should be use with great caution. Only use this option when you are absolutely sure that all the data in all the files are aligned, and you need to create RasterStack for many (>100) files} \item{varname}{character. To select the variable of interest in a NetCDF file (see \code{\link{raster}})} \item{...}{additional filenames or Raster* objects} } \value{ RasterStack } \seealso{ \code{\link[raster]{addLayer}, \link[raster:addLayer]{dropLayer}, \link[raster]{raster}, \link[raster]{brick}} } \examples{ # file with one layer fn <- system.file("external/test.grd", package="raster") s <- stack(fn, fn) r <- raster(fn) s <- stack(r, fn) nlayers(s) # file with three layers slogo <- stack(system.file("external/rlogo.grd", package="raster")) nlayers(slogo) slogo } \keyword{methods} \keyword{spatial} raster/man/strech.Rd0000644000176200001440000000352214507510157014113 0ustar liggesusers\name{stretch} \alias{stretch} \alias{stretch,Raster-method} \title{Stretch} \description{ Linear stretch of values in a Raster object. Provide the desired output range (minv and maxv) and the lower and upper bounds in the original data, either as quantiles (if \code{minq=0} and \code{maxq=1} you use the minimum and maximum cell values), or as actual values (\code{smin} and \code{smax}; e.g. precomputed quantile values). If \code{smin} and \code{smax} are both not \code{NA}, \code{minq} and \code{maxq} are ignored. } \usage{ \S4method{stretch}{Raster}(x, minv=0, maxv=255, minq=0, maxq=1, smin=NA, smax=NA, samplesize=1000000, filename='', ...) } \arguments{ \item{x}{Raster object} \item{minv}{numeric >= 0 and smaller than maxv. lower bound of stretched value} \item{maxv}{numeric <= 255 and larger than maxv. upper bound of stretched value} \item{minq}{numeric >= 0 and smaller than maxq. lower quantile bound of original value. Ignored if smin is supplied} \item{maxq}{numeric <= 1 and larger than minq. upper quantile bound of original value. Ignored if smax is supplied} \item{smin}{numeric < smax. user supplied lower value for the layers, to be used instead of a quantile computed by the function itself} \item{smax}{numeric > smin. user supplied upper value for the layers, to be used instead of a quantile computed by the function itself} \item{samplesize}{numeric > 1. If samplesize < ncell(x), a regular sample of samplesize is taken from x to compute the quantiles (to speed things up)} \item{filename}{character. Filename for the output Raster object (optional)} \item{...}{ additional arguments as for \code{\link{writeRaster}}} } \value{ Raster } \seealso{stretch argument in \code{\link{plotRGB}}} \examples{ r <- raster(nc=10, nr=10) values(r) <- rep(1:2, 50) stretch(r) s <- stack(r, r*2) stretch(s) } \keyword{spatial} raster/man/reclassify.Rd0000644000176200001440000000455014507510157014771 0ustar liggesusers\name{reclassify} \docType{methods} \alias{reclassify} \alias{reclassify,Raster-method} \title{Reclassify} \description{ Reclassify values of a Raster* object. The function (re)classifies groups of values to other values. For example, all values between 1 and 10 become 1, and all values between 11 and 15 become 2 (see functions \code{\link{subs}} and \code{\link{cut}} for alternative approaches). Reclassification is done with matrix \code{rcl}, in the row order of the reclassify table. Thus, if there are overlapping ranges, the first time a number is within a range determines the reclassification value. } \usage{ \S4method{reclassify}{Raster}(x, rcl, filename='', include.lowest=FALSE, right=TRUE, ...) } \arguments{ \item{x}{Raster* object} \item{rcl}{matrix for reclassification. This matrix can have 3 or 2 columns. In a \code{3-column matrix} the first two columns are "from" - "to" for the input values, and the third column "becomes" has the new value for that range. (You can also supply a vector that can be coerced into a n*3 matrix (with \code{byrow=TRUE})). A \code{2-column matrix} represents ("is", "becomes") which can be useful for integer values. In that case, the \code{right} argument is automatically set to \code{NA}} \item{filename}{character. Output filename (optional) } \item{include.lowest}{logical, indicating if a value equal to the lowest value in rcl (or highest value in the second column, for right = FALSE) should be included. The default is \code{FALSE}} \item{right}{logical, indicating if the intervals should be closed on the right (and open on the left) or vice versa. The default is \code{TRUE}. A special case is to use right=NA. In this case both the left and right intervals are open} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ Raster* object } \seealso{ \code{ \link{subs}, \link{clamp}, \link{cut}, \link{calc}} } \examples{ r <- raster(ncols=36, nrows=18) values(r) <- runif(ncell(r)) # reclassify the values into three groups # all values > 0 and <= 0.25 become 1, etc. m <- c(0, 0.25, 1, 0.25, 0.5, 2, 0.5, 1, 3) rclmat <- matrix(m, ncol=3, byrow=TRUE) rc <- reclassify(r, rclmat) # for values >= 0 (instead of > 0), do rc <- reclassify(r, rclmat, include.lowest=TRUE) # equivalent to rc <- reclassify(r, c(-Inf,0.25,1, 0.25,0.5,2, 0.5,Inf,3)) } \keyword{spatial} raster/man/raster-package.Rd0000644000176200001440000005306014545422445015522 0ustar liggesusers\name{raster-package} \alias{raster-package} \docType{package} \title{ Overview of the functions in the raster package } \description{ The raster package provides classes and functions to manipulate geographic (spatial) data in 'raster' format. Raster data divides space into cells (rectangles; pixels) of equal size (in units of the coordinate reference system). Such continuous spatial data are also referred to as 'grid' data, and be contrasted with discrete (object based) spatial data (points, lines, polygons). The package should be particularly useful when using very large datasets that can not be loaded into the computer's memory. Functions will work correctly, because they process large files in chunks, i.e., they read, compute, and write blocks of data, without loading all values into memory at once. Below is a list of some of the most important functions grouped by theme. See the vignette for more information and some examples (you can open it by running this command: \code{vignette('Raster')}) } \details{ The package implements classes for Raster data (see \link{Raster-class}) and supports \itemize{ \item Creation of Raster* objects from scratch or from file \item Handling extremely large raster files \item Raster algebra and overlay functions \item Distance, neighborhood (focal) and patch functions \item Polygon, line and point to raster conversion \item Model predictions \item Summarizing raster values \item Easy access to raster cell-values \item Plotting (making maps) \item Manipulation of raster extent, resolution and origin \item Computation of row, column and cell numbers to coordinates and vice versa \item Reading and writing various raster file types } . } \section{I. Creating Raster* objects}{ RasterLayer, RasterStack, and RasterBrick objects are, as a group, referred to as Raster* objects. Raster* objects can be created, from scratch, files, or from objects of other classes, with the following functions: \tabular{ll}{ \code{\link{raster}}\tab To create a RasterLayer \cr \code{\link{stack}} \tab To create a RasterStack (multiple layers)\cr \code{\link{brick}} \tab To create a RasterBrick (multiple layers)\cr \code{\link{subset}} \tab Select layers of a RasterStack/Brick\cr \code{\link{addLayer}} \tab Add a layer to a Raster* object\cr \code{\link{dropLayer}} \tab Remove a layer from a RasterStack or RasterBrick \cr \code{\link{unstack}} \tab Create a list of RasterLayer objects from a RasterStack \cr --------------------------- \tab --------------------------------------------------------------------------------------------------- \cr } } \section{II. Changing the spatial extent and/or resolution of Raster* objects}{ \tabular{ll}{ \code{\link{merge}} \tab Combine Raster* objects with different extents (but same origin and resolution) \cr \code{\link{mosaic}} \tab Combine RasterLayers with different extents and a function for overlap areas \cr \code{\link{crop}} \tab Select a geographic subset of a Raster* object \cr \code{\link{extend}} \tab Enlarge a Raster* object \cr \code{\link{trim}} \tab Trim a Raster* object by removing exterior rows and/or columns that only have NAs\cr \code{\link{aggregate}} \tab Combine cells of a Raster* object to create larger cells \cr \code{\link{disaggregate}} \tab Subdivide cells \cr \code{\link{resample}} \tab Warp values to a Raster* object with a different origin or resolution \cr \code{\link{projectRaster}} \tab project values to a raster with a different coordinate reference system \cr \code{\link{shift}} \tab Move the location of Raster \cr \code{\link{flip}} \tab Flip values horizontally or vertically \cr \code{\link{rotate}} \tab Rotate values around the date-line (for lon/lat data) \cr \code{\link{t}} \tab Transpose a Raster* object\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{III. Raster algebra}{ \tabular{ll}{ \code{\link{Arith-methods}} \tab Arith functions (\code{+, -, *, ^, \%\%, \%/\%, /}) \cr \code{\link{Math-methods}} \tab Math functions like \code{abs, sqrt, trunc, log, log10, exp, sin, round} \cr \code{\link{Logic-methods}} \tab Logic functions (\code{!, &, |}) \cr \code{\link{Summary-methods}} \tab Summary functions (\code{mean, max, min, range, prod, sum, any, all}) \cr \code{\link{Compare-methods}} \tab Compare functions (\code{==, !=, >, <, <=, >=}) \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{IV. Cell based computation}{ \tabular{ll}{ \code{\link{calc}} \tab Computations on a single Raster* object \cr \code{\link{overlay}} \tab Computations on multiple RasterLayer objects \cr \code{\link{cover}} \tab First layer covers second layer except where the first layer is \code{NA} \cr \code{\link{mask}} \tab Use values from first Raster except where cells of the mask Raster are \code{NA}\cr \code{\link{cut}} \tab Reclassify values using ranges \cr \code{\link{subs}} \tab Reclassify values using an 'is-becomes' matrix \cr \code{\link{reclassify}} \tab Reclassify using a 'from-to-becomes' matrix \cr \code{\link{init}} \tab Initialize cells with new values \cr \code{\link{stackApply}} \tab Computations on groups of layers in Raster* object \cr \code{\link{stackSelect}} \tab Select cell values from different layers using an index RasterLayer\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{V. Spatial contextual computation}{ \tabular{ll}{ \code{\link{distance}} \tab Shortest distance to a cell that is not \code{NA}\cr \code{\link{gridDistance}} \tab Distance when traversing grid cells that are not \code{NA} \cr \code{\link{distanceFromPoints}} \tab Shortest distance to any point in a set of points \cr \code{\link{direction}} \tab Direction (azimuth) to or from cells that are not \code{NA}\cr \code{\link{focal}} \tab Focal (neighborhood; moving window) functions \cr \code{\link{localFun}} \tab Local association (using neighborhoods) functions \cr \code{\link{boundaries}} \tab Detection of boundaries (edges)\cr \code{\link{clump}} \tab Find clumps (patches) \cr \code{\link{adjacent}} \tab Identify cells that are adjacent to a set of cells on a raster \cr \code{\link{area}} \tab Compute area of cells (for longitude/latitude data) \cr \code{\link{terrain}} \tab Compute slope, aspect and other characteristics from elevation data \cr \code{\link{Moran}} \tab Compute global or local Moran or Geary indices of spatial autocorrelation \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{VI. Model predictions}{ \tabular{ll}{ \code{\link{predict}} \tab Predict a non-spatial model to a RasterLayer \cr \code{\link{interpolate}} \tab Predict a spatial model to a RasterLayer \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{VII. Data type conversion}{ You can coerce Raster* objects to Spatial* objects using \code{as}, as in \code{as(object, 'SpatialGridDataFrame')} \tabular{ll}{ \code{\link{raster}} \tab RasterLayer from SpatialGrid*, image, or matrix objects\cr \code{\link{rasterize}} \tab Rasterizing points, lines or polygons\cr \code{\link{rasterToPoints}} \tab Create points from a RasterLayer \cr \code{\link{rasterToPolygons}} \tab Create polygons from a RasterLayer \cr \code{\link{rasterToContour}} \tab Contour lines from a RasterLayer \cr \code{\link{rasterFromXYZ}} \tab RasterLayer from regularly spaced points\cr \code{\link{rasterFromCells}} \tab RasterLayer from a Raster object and cell numbers\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{VIII. Summarizing}{ \tabular{ll}{ \code{\link{cellStats}} \tab Summarize a Raster cell values with a function \cr \code{\link{summary}} \tab Summary of the values of a Raster* object (quartiles and mean) \cr \code{\link{freq}} \tab Frequency table of Raster cell values \cr \code{\link{crosstab}} \tab Cross-tabulate two Raster* objects\cr \code{\link{unique}} \tab Get the unique values in a Raster* object \cr \code{\link{zonal}} \tab Summarize a Raster* object by zones in a RasterLayer \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{IX. Accessing values of Raster* object cells}{ Apart from the function listed below, you can also use indexing with \code{[} for cell numbers, and \code{[[} for row / column number combinations \cr \tabular{ll}{ \code{\link{getValues}} \tab Get all cell values (fails with very large rasters), or a row of values (safer) \cr \code{\link{getValuesBlock}} \tab Get values for a block (a rectangular area) \cr \code{\link{getValuesFocal}} \tab Get focal values for one or more rows\cr \code{\link{as.matrix}} \tab Get cell values as a matrix \cr \code{\link{as.array}} \tab Get cell values as an array \cr \code{\link{extract}} \tab Extract cell values from a Raster* object (e.g., by cell, coordinates, polygon)\cr \code{\link{sampleRandom}} \tab Random sample \cr \code{\link{sampleRegular}} \tab Regular sample \cr \code{\link{minValue}} \tab Get the minimum value of the cells of a Raster* object (not always known) \cr \code{\link{maxValue}} \tab Get the maximum value of the cells of a Raster* object (not always known) \cr \code{\link{setMinMax}} \tab Compute the minimum and maximum value of a Raster* object if these are not known \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{X. Plotting}{ See the rasterVis package for additional plotting methods for Raster* objects using methods from 'lattice' and other packages. \tabular{ll}{ \bold{Maps} \tab \cr \code{\link{plot}} \tab Plot a Raster* object. The main method to create a map \cr \code{\link{plotRGB}} \tab Combine three layers (red, green, blue channels) into a single 'real color' image \cr \code{\link{spplot}} \tab Plot a Raster* with the spplot function (sp package) \cr \code{\link{image}} \tab Plot a Raster* with the image function \cr \code{\link{persp}} \tab Perspective plot of a RasterLayer \cr \code{\link{contour}} \tab Contour plot of a RasterLayer \cr \code{\link{filledContour}} \tab Filled contour plot of a RasterLayer \cr \code{\link{text}} \tab Plot the values of a RasterLayer on top of a map \cr .\cr \bold{Interacting with a map} \tab \cr \code{\link{zoom}} \tab Zoom in to a part of a map \cr \code{\link{click}} \tab Query values of Raster* or Spatial* objects by clicking on a map \cr \code{\link{select}} \tab Select a geometric subset of a Raster* or Spatial* object \cr \code{\link{drawPoly}} \tab Create a SpatialPolygons object by drawing it \cr \code{\link{drawLine}} \tab Create a SpatialLines object by drawing it \cr \code{\link{drawExtent}} \tab Create an Extent object by drawing it \cr .\cr \bold{Other plots} \tab \cr \code{\link{plot}} \tab x-y scatter plot of the values of two RasterLayer objects\cr \code{\link{hist}} \tab Histogram of Raster* object values \cr \code{\link{barplot}} \tab barplot of a RasterLayer \cr \code{\link{density}} \tab Density plot of Raster* object values \cr \code{\link{pairs}} \tab Pairs plot for layers in a RasterStack or RasterBrick \cr \code{\link{boxplot}} \tab Box plot of the values of one or multiple layers\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XI. Getting and setting Raster* dimensions }{ Basic parameters of existing Raster* objects can be obtained, and in most cases changed. If there are values associated with a RasterLayer object (either in memory or via a link to a file) these are lost when you change the number of columns or rows or the resolution. This is not the case when the extent is changed (as the number of columns and rows will not be affected). Similarly, with \bold{projection} you can set the projection, but this does not transform the data (see \link{projectRaster} for that). \tabular{ll}{ \code{\link{ncol}}\tab The number of columns \cr \code{\link{nrow}} \tab The number of rows \cr \code{\link{ncell}} \tab The number of cells (can not be set directly, only via ncol or nrow) \cr \code{\link{res}} \tab The resolution (x and y) \cr \code{\link{nlayers}} \tab How many layers does the object have? \cr \code{\link{names}} \tab Get or set the layer names \cr \code{\link{xres}} \tab The x resolution (can be set with res) \cr \code{\link{yres}} \tab The y resolution (can be set with res)\cr \code{\link{xmin}} \tab The minimum x coordinate (or longitude) \cr \code{\link{xmax}} \tab The maximum x coordinate (or longitude) \cr \code{\link{ymin}} \tab The minimum y coordinate (or latitude) \cr \code{\link{ymax}} \tab The maximum y coordinate (or latitude) \cr \code{\link{extent}} \tab The extent (minimum and maximum x and y coordinates) \cr \code{\link{origin}} \tab The origin of a Raster* object\cr \code{\link{crs}} \tab The coordinate reference system (map projection) \cr \code{\link{isLonLat}} \tab Test if an object has a longitude/latitude coordinate reference system \cr \code{\link{filename}} \tab Filename to which a RasterLayer or RasterBrick is linked \cr \code{\link{bandnr}} \tab layer (=band) of a multi-band file that this RasterLayer is linked to \cr \code{\link{nbands}} \tab How many bands (layers) does the file associated with a RasterLayer object have? \cr \code{\link{compareRaster}} \tab Compare the geometry of Raster* objects \cr \code{\link{NAvalue}} \tab Get or set the \code{NA} value (for reading from a file) \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XII. Computing row, column, cell numbers and coordinates}{ Cell numbers start at 1 in the upper-left corner. They increase within rows, from left to right, and then row by row from top to bottom. Likewise, row numbers start at 1 at the top of the raster, and column numbers start at 1 at the left side of the raster. \tabular{ll}{ \code{\link{xFromCol}} \tab x-coordinates from column numbers \cr \code{\link{yFromRow}} \tab y-coordinates from row numbers \cr \code{\link{xFromCell}} \tab x-coordinates from row numbers \cr \code{\link{yFromCell}} \tab y-coordinates from cell numbers \cr \code{\link{xyFromCell}} \tab x and y coordinates from cell numbers \cr \code{\link{colFromX}} \tab Column numbers from x-coordinates (or longitude) \cr \code{\link{rowFromY}} \tab Row numbers from y-coordinates (or latitude) \cr \code{\link{rowColFromCell}} \tab Row and column numbers from cell numbers\cr \code{\link{cellFromXY}} \tab Cell numbers from x and y coordinates \cr \code{\link{cellFromRowCol}} \tab Cell numbers from row and column numbers \cr \code{\link{cellsFromExtent}} \tab Cell numbers from extent object \cr \code{\link{coordinates}} \tab x and y coordinates for all cells \cr \code{\link{validCell}} \tab Is this a valid cell number? \cr \code{\link{validCol}} \tab Is this a valid column number? \cr \code{\link{validRow}} \tab Is this a valid row number? \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XIII. Writing files}{ \tabular{ll}{ \bold{Basic}\cr \code{\link{setValues}} \tab Put new values in a Raster* object \cr \code{\link{writeRaster}} \tab Write all values of Raster* object to disk \cr \code{\link{KML}} \tab Save raster as KML file \cr .\cr \bold{Advanced}\cr \code{\link{blockSize}} \tab Get suggested block size for reading and writing \cr \code{\link{writeStart}} \tab Open a file for writing \cr \code{\link{writeValues}} \tab Write some values \cr \code{\link{writeStop}} \tab Close the file after writing \cr \code{\link{update}} \tab Change the values of an existing file \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XIV. Manipulation of SpatialPolygons* and other vector type Spatial* objects}{ Some of these functions are in the \code{sp} package. The name in \bold{bold} is the equivalent command in ArcGIS. \tabular{ll}{ \code{\link{bind}} \tab \bold{append} combine Spatial* objects of the same (vector) type \cr \code{\link{erase}} or "-" \tab \bold{erase} parts of a SpatialPolygons* object\cr \code{\link{intersect}} or "*" \tab \bold{intersect} SpatialPolygons* objects\cr \code{\link{union}} or "+" \tab \bold{union} SpatialPolygons* objects\cr \code{\link{cover}} \tab \bold{update} and \bold{identity} for a SpatialPolygons and another one\cr \code{\link{symdif}} \tab\bold{symmetrical difference} of two SpatialPolygons* objects \cr \code{\link{aggregate}} \tab \bold{dissolve} smaller polygons into larger ones \cr \code{\link[sp]{disaggregate}} \tab \bold{explode}: turn polygon parts into separate polygons (in the \code{sp} package) \cr \code{\link{crop}} \tab \bold{clip} a Spatial* object using a rectangle (Extent object)\cr \code{\link{select}} \tab \bold{select} - interactively select spatial features\cr \code{\link{click}} \tab \bold{identify} attributes by clicking on a map\cr \code{\link[sp]{merge}} \tab \bold{Join table} (in the \code{sp} package) \cr \code{\link[sp]{over}} \tab spatial queries between Spatial* objects \cr \code{\link{extract}} \tab spatial queries between Spatial* and Raster* objects \cr \code{\link{as.data.frame}} \tab coerce coordinates of \code{SpatialLines} or \code{SpatialPolygons} into a data.frame\cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XV. Extent objects}{ \tabular{ll}{ \code{\link{extent}} \tab Create an extent object \cr \code{\link{intersect}} \tab Intersect two extent objects \cr \code{\link{union}} \tab Combine two extent objects \cr \code{\link{round}} \tab round/floor/ceiling of the coordinates of an Extent object \cr \code{\link{alignExtent}} \tab Align an extent with a Raster* object \cr \code{\link{drawExtent}} \tab Create an Extent object by drawing it on top of a map (see plot) \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XVI. Miscellaneous}{ \tabular{ll}{ \code{\link{rasterOptions}} \tab Show, set, save or get session options \cr \code{\link{pointDistance}} \tab Distance between points \cr \code{\link{readIniFile}} \tab Read a (windows) 'ini' file \cr \code{\link{hdr}} \tab Write header file for a number of raster formats \cr \code{\link{trim}} \tab Remove leading and trailing blanks from a character string \cr \code{\link{extension}} \tab Get or set the extension of a filename \cr \code{\link{cv}} \tab Coefficient of variation \cr \code{\link{modal}} \tab Modal value \cr \code{\link{sampleInt}} \tab Random sample of (possibly very large) range of integer values \cr \code{\link{showTmpFiles}} \tab Show temporary files \cr \code{\link{removeTmpFiles}} \tab Remove temporary files \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \section{XVII. For programmers}{ \tabular{ll}{ \code{\link{canProcessInMemory}} \tab Test whether a file can be created in memory \cr \code{\link{pbCreate}} \tab Initialize a progress bar \cr \code{\link{pbStep}} \tab Take a progress bar step \cr \code{\link{pbClose}} \tab Close a progress bar \cr \code{\link{readStart}} \tab Open file connections for efficient multi-chunk reading \cr \code{\link{readStop}} \tab Close file connections \cr \code{\link{rasterTmpFile}} \tab Get a name for a temporary file \cr \code{\link{inMemory}} \tab Are the cell values in memory? \cr \code{\link{fromDisk}} \tab Are the cell values read from a file? \cr --------------------------- \tab ------------------------------------------------------------------------------------------ \cr } } \author{Except where indicated otherwise, the functions in this package were written by Robert J. Hijmans} \section{Acknowledgments}{ Extensive contributions were made by Jacob van Etten, Jonathan Greenberg, Matteo Mattiuzzi, and Michael Sumner. Significant help was also provided by Phil Heilman, Agustin Lobo, Oscar Perpinan Lamigueiro, Stefan Schlaffer, Jon Olav Skoien, Steven Mosher, and Kevin Ummel. Contributions were also made by Jochen Albrecht, Neil Best, Andrew Bevan, Roger Bivand, Isabelle Boulangeat, Lyndon Estes, Josh Gray, Tim Haering, Herry Herry, Paul Hiemstra, Ned Hornig, Mayeul Kauffmann, Bart Kranstauber, Rainer Krug, Alice Laborte, John Lewis, Lennon Li, Justin McGrath, Babak Naimi, Carsten Neumann, Joshua Perlman, Richard Plant, Edzer Pebesma, Etienne Racine, David Ramsey, Shaun Walbridge, Julian Zeidler and many others. } \keyword{package} \keyword{spatial} raster/man/cellsFromExtent.Rd0000644000176200001440000000246514507510157015746 0ustar liggesusers\name{cellsFromExtent} \alias{cellsFromExtent} \alias{extentFromCells} \title{Cells from extent, and vice versa} \description{ cellsFromExtent returns the cell numbers for a Raster* object that are within a specfied extent (rectangular area), supply an object of class Extent, or another Raster* object. extentFromCells returns an Extent object from a Raster* object and cell numbers. All cells are within the returned Extent. } \usage{ cellsFromExtent(object, extent, expand=FALSE) extentFromCells(object, cells) } \arguments{ \item{object}{A Raster* object} \item{extent}{An object of class Extent (which you can create with newExtent(), or another Raster* object )} \item{expand}{Logical. If \code{TRUE}, \code{NA} is returned for (virtual) cells implied by \code{bndbox}, that are outside the RasterLayer (\code{object}). If \code{FALSE}, only cell numbers for the area where \code{object} and \code{bndbox} overlap are returned (see \link[raster]{intersect}) } \item{cells}{numeric. A vector of cell numbers} } \value{ a vector of cell numbers } \seealso{ \code{\link[raster]{extent}}, \code{\link{cellFromXY}} } \examples{ r <- raster() bb <- extent(-5, 5, -5, 5) cells <- cellsFromExtent(r, bb) r <- crop(r, bb) values(r) <- cells e <- extentFromCells(r, 50:55) } \keyword{spatial} raster/man/rotate.Rd0000644000176200001440000000144414507510157014122 0ustar liggesusers\name{rotate} \docType{methods} \alias{rotate} \alias{rotate,Raster-method} \title{Rotate} \description{ Rotate a Raster* object that has x coordinates (longitude) from 0 to 360, to standard coordinates between -180 and 180 degrees. Longitude between 0 and 360 is frequently used in global climate models. } \usage{ \S4method{rotate}{Raster}(x, filename='', ...) } \arguments{ \item{x}{Raster* object} \item{filename}{character. Output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or a RasterBrick object } \seealso{ \code{\link[raster]{flip}} } \examples{ r <- raster(nrow=18, ncol=36) m <- matrix(1:ncell(r), nrow=18) values(r) <- as.vector(t(m)) extent(r) <- extent(0, 360, -90, 90) rr <- rotate(r) } \keyword{spatial} raster/man/disaggregate.Rd0000644000176200001440000000301214507510157015243 0ustar liggesusers\name{disaggregate} \alias{disaggregate} \alias{disaggregate,Raster-method} \title{Disaggregate} \description{ Disaggregate a RasterLayer to create a new RasterLayer with a higher resolution (smaller cells). The values in the new RasterLayer are the same as in the larger original cells unless you specify \code{method="bilinear"}, in which case values are locally interpolated (using the \code{\link[raster]{resample}} function). } \usage{ \S4method{disaggregate}{Raster}(x, fact=NULL, method='', filename='', ...) } \arguments{ \item{x}{a Raster object} \item{fact}{integer. amount of disaggregation expressed as number of cells (horizontally and vertically). This can be a single integer or two integers c(x,y), in which case the first one is the horizontal disaggregation factor and y the vertical disaggreation factor. If a single integer value is supplied, cells are disaggregated with the same factor in x and y direction} \item{method}{Character. \code{''} or \code{'bilinear'}. If \code{'bilinear'}, values are locally interpolated (using the \code{\link[raster]{resample}} function} \item{filename}{Character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ Raster object } \seealso{ \code{\link[raster]{aggregate}} } \author{Robert J. Hijmans and Jim Regetz} \examples{ r <- raster(ncols=10, nrows=10) rd <- disaggregate(r, fact=c(10, 2)) ncol(rd) nrow(rd) values(r) <- 1:ncell(r) rd <- disaggregate(r, fact=c(4, 2), method='bilinear') } \keyword{spatial} raster/man/rasterToPoints.Rd0000644000176200001440000000210714507510157015621 0ustar liggesusers\name{rasterToPoints} \alias{rasterToPoints} \title{ Raster to points conversion} \description{ Raster to point conversion. Cells with NA are not converted. A function can be used to select a subset of the raster cells (by their values). } \usage{ rasterToPoints(x, fun=NULL, spatial=FALSE, ...) } \arguments{ \item{x}{A Raster* object } \item{fun}{Function to select a subset of raster values} \item{spatial}{Logical. If \code{TRUE}, the function returns a SpatialPointsDataFrame object } \item{...}{Additional arguments. Currently only \code{progress} to specify a progress bar. "text", "window", or "" (the default, no progress bar)} } \details{ \code{fun} should be a simple function returning a logical value. E.g.: \code{fun=function(x){x==1}} or \code{fun=function(x){x>3}} } \value{ A matrix with three columns: x, y, and v (value), or a SpatialPointsDataFrame object } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- runif(ncell(r)) * 10 r[r>8] <- NA p <- rasterToPoints(r) p <- rasterToPoints(r, fun=function(x){x>6}) #plot(r) #points(p) } \keyword{ spatial } raster/man/which.Rd0000644000176200001440000000243714507510157013731 0ustar liggesusers\name{which} \docType{methods} \alias{Which} \alias{Which,RasterLayer-method} \title{Which cells are TRUE?} \description{ \code{Which} returns a RasterLayer with \code{TRUE} or \code{FALSE} setting cells that are \code{NA} to \code{FALSE} (unless \code{na.rm=FALSE}). If the RasterLayer has numbers, all values that are 0 become \code{FALSE} and all other values become \code{TRUE}. The function can also return the cell numbers that are \code{TRUE} } \usage{ \S4method{Which}{RasterLayer}(x, cells=FALSE, na.rm=TRUE, ...) } \arguments{ \item{x}{RasterLayer} \item{cells}{logical. If \code{TRUE}, cell numbers are returned, otherwise a RasterLayer is returned} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values are treated as \code{FALSE}, otherwise they remain \code{NA} (only when \code{cells=FALSE})} \item{...}{Additional arguments (none implemented)} } \seealso{ \code{\link{which.max}}, \code{\link{which.min}} } \value{ RasterLayer } \examples{ r <- raster(ncol=10, nrow=10) set.seed(0) values(r) <- runif(ncell(r)) r[r < 0.2 ] <- 0 r[r > 0.8] <- 1 r[r > 0 & r < 1 ] <- 0.5 Which(r, cells=TRUE) Which(r > 0.5, cells=TRUE) s1 <- r > 0.5 s2 <- Which(r > 0.5) s1[1:15] s2[1:15] # this expression x1 <- Which(r, na.rm=FALSE) # is the inverse of x2 <- r==0 } \keyword{spatial} raster/man/adjacent.Rd0000644000176200001440000000503114507510157014371 0ustar liggesusers\name{adjacent} \alias{adjacent} \alias{adjacent,BasicRaster-method} \title{Adjacent cells} \description{ Identify cells that are adjacent to a set of cells on a raster. } \usage{ \S4method{adjacent}{BasicRaster}(x, cells, directions=4, pairs=TRUE, target=NULL, sorted=FALSE, include=FALSE, id=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{cells}{vector of cell numbers for which adjacent cells should be found. Cell numbers start with 1 in the upper-left corner and increase from left to right and from top to bottom} \item{directions}{the number of directions in which cells should be connected: 4 (rook's case), 8 (queen's case), 16 (knight and one-cell queen moves), or 'bishop' to connect cells with one-cell diagonal moves. Or a neighborhood matrix (see Details)} \item{pairs}{logical. If \code{TRUE}, a matrix of pairs of adjacent cells is returned. If \code{FALSE}, a vector of cells adjacent to \code{cells} is returned} \item{target}{optional vector of target cell numbers that should be considered. All other adjacent cells are ignored} \item{sorted}{logical. Should the results be sorted? } \item{include}{logical. Should the focal cells be included in the result? } \item{id}{logical. Should the id of the cells be included in the result? (numbered from 1 to length(cells) } \item{...}{additional arguments. None implemented } } \details{ A neighborhood matrix identifies the cells around each cell that are considered adjacent. The matrix should have one, and only one, cell with value 0 (the focal cell); at least one cell with value 1 (the adjacent cell(s)); All other cells are not considered adjacent and ignored. } \value{ matrix or vector with adjacent cells. } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster(nrows=10, ncols=10) adjacent(r, cells=c(1, 55), directions=8, pairs=TRUE) a <- adjacent(r, cell = c(1,55,90), directions=4, sorted=TRUE) a r[c(1,55,90)] <- 1 r[a] <- 2 plot(r) # same result as above rook <- matrix(c(NA, 1, NA, 1, 0, 1, NA, 1, NA), ncol=3, byrow=TRUE) adjacent(r, cells = c(1,55,90), directions=rook, sorted=TRUE) # Count the number of times that a cell with a certain value # occurs next to a cell with a certain value set.seed(0) r <- raster(ncol=10, nrow=10) values(r) <- round(runif(ncell(r)) * 5) a <- adjacent(r, 1:ncell(r), 4, pairs=TRUE) tb <- table(r[a[,1]], r[a[,2]]) tb # make a matrix out of the 'table' object tb <- unclass(tb) plot(raster(tb, xmn=-0.5, xmx=5.5, ymn=-0.5, ymx=5.5)) } \keyword{spatial} raster/man/shapefile.Rd0000644000176200001440000000315614507510157014566 0ustar liggesusers \name{shapefile} \alias{shapefile} \alias{shapefile,character-method} \alias{shapefile,Spatial-method} \title{ Read or write a shapefile } \description{ Reading and writing of "ESRI shapefile" format spatial data. Only the three vector types (points, lines, and polygons) can be stored in shapefiles. A shapefile should consist of at least four files: .shp (the geometry), .dbf (the attributes), .shx (the index that links the two, and .prj (the coordinate reference system). If the .prj file is missing, a warning is given. If any other file is missing an error occurs (although one could in principle recover the .shx from the .shp file). Additional files are ignored. } \usage{ \S4method{shapefile}{character}(x, stringsAsFactors=FALSE, verbose=FALSE, warnPRJ=TRUE, ...) \S4method{shapefile}{Spatial}(x, filename='', overwrite=FALSE, ...) } \arguments{ \item{x}{character (a file name, when reading a shapefile) or Spatial* object (when writing a shapefile)} \item{filename}{character. Filename to write a shapefile} \item{overwrite}{logical. Overwrite existing shapefile?} \item{verbose}{logical. If \code{TRUE}, information about the file is printed} \item{warnPRJ}{logical. If \code{TRUE}, a warning is given if there is no .prj file} \item{stringsAsFactors}{logical. If \code{TRUE}, strings are converted to factors} \item{...}{Additional arguments (none)} } \value{ Spatial*DataFrame (reading). Nothing is returned when writing a shapefile. } \examples{ filename <- system.file("external/lux.shp", package="raster") filename p <- shapefile(filename) \dontrun{ shapefile(p, 'copy.shp') } } \keyword{spatial} raster/man/coords.Rd0000644000176200001440000000275514507510157014123 0ustar liggesusers\name{Extreme coordinates} \alias{xmin} \alias{xmax} \alias{ymin} \alias{ymax} \alias{xmin<-} \alias{xmax<-} \alias{ymin<-} \alias{ymax<-} \alias{xmin,BasicRaster-method} \alias{xmax,BasicRaster-method} \alias{ymin,BasicRaster-method} \alias{ymax,BasicRaster-method} \alias{xmin,Extent-method} \alias{xmax,Extent-method} \alias{ymin,Extent-method} \alias{ymax,Extent-method} \alias{xmin,Spatial-method} \alias{xmax,Spatial-method} \alias{ymin,Spatial-method} \alias{ymax,Spatial-method} \alias{xmin<-,Extent,numeric-method} \alias{xmin<-,BasicRaster,numeric-method} \alias{xmax<-,Extent,numeric-method} \alias{xmax<-,BasicRaster,numeric-method} \alias{ymin<-,Extent,numeric-method} \alias{ymin<-,BasicRaster,numeric-method} \alias{ymax<-,Extent,numeric-method} \alias{ymax<-,BasicRaster,numeric-method} \title{Coordinates of the Extent of a Raster object} \description{ These functions return or set the extreme coordinates of a Raster* object; and return them for Spatial* objects. } \usage{ xmin(x) xmax(x) ymin(x) ymax(x) xmin(x, ...) <- value xmax(x, ...) <- value ymin(x, ...) <- value ymax(x, ...) <- value } \arguments{ \item{x}{Raster* or Extent object} \item{value}{numeric. x or y coordinate} \item{...}{additional arguments. None implemented} } \value{ numeric } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{dimensions}} } \examples{ r <- raster(xmn=-0.5, xmx = 9.5, ncols=10) xmin(r) xmax(r) ymin(r) ymax(r) xmin(r) <- -180 xmax(r) <- 180 } \keyword{spatial} raster/man/KML.Rd0000644000176200001440000000460414507510157013250 0ustar liggesusers\name{KML} \alias{KML} \alias{KML,Spatial-method} \alias{KML,RasterLayer-method} \alias{KML,RasterStackBrick-method} \title{Write a KML or KMZ file} \description{ Export raster data to a KML file and an accompanying PNG image file. Multi-layer objects can be used to create an animation. The function attempts to combine these into a single (and hence more convenient) KMZ file (a zip file containing the KML and PNG files). See package plotKML for more advanced functionality } \usage{ \S4method{KML}{RasterLayer}(x, filename, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) \S4method{KML}{RasterStackBrick}(x, filename, time=NULL, col=rev(terrain.colors(255)), colNA=NA, maxpixels=100000, blur=1, zip='', overwrite=FALSE, ...) \S4method{KML}{Spatial}(x, filename, zip='', overwrite=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{filename}{output filename} \item{time}{character vector with time lables for multilayer objects. The length of this vector should be nlayers(x) to indicate "when" or nlayers(x)+1 to indicate "begin-end"} \item{col}{color scheme to be used (see \link[graphics]{image})} \item{colNA}{The color to use for the background (default is transparent)} \item{maxpixels}{maximum number of pixels. If ncell(raster) > maxpixels, sampleRegular is used to reduce the number of pixels} \item{blur}{Integer (default=1). Higher values help avoid blurring of isolated pixels (at the expense of a png file that is blur^2 times larger)} \item{zip}{If there is no zip program on your path (on windows), you can supply the full path to a zip.exe here, in order to make a KMZ file} \item{overwrite}{logical. If \code{TRUE}, overwrite the file if it exists} \item{...}{If \code{x} is a Raster* object, additional arguments that can be passed to \link[graphics]{image}} } \value{ None. Used for the side-effect files written to disk. } \author{This function was adapted for the raster package by Robert J. Hijmans, with ideas from Tony Fischbach, and based on functions in the maptools package by Duncan Golicher, David Forrest and Roger Bivand.} \examples{ \dontrun{ # Meuse data from the sp package data(meuse.grid) b <- rasterFromXYZ(meuse.grid) projection(b) <- "+init=epsg:28992" # transform to longitude/latitude p <- projectRaster(b, crs="+proj=longlat +datum=WGS84", method='ngb') KML(p, file='meuse.kml') } } \keyword{spatial} raster/man/extremeValues.Rd0000644000176200001440000000213314507510157015451 0ustar liggesusers\name{extremeValues} \alias{minValue} \alias{maxValue} \alias{minValue,RasterLayer-method} \alias{minValue,RasterStack-method} \alias{minValue,RasterBrick-method} \alias{maxValue,RasterLayer-method} \alias{maxValue,RasterStack-method} \alias{maxValue,RasterBrick-method} \title{Minimum and maximum values} \description{ Returns the minimum or maximum value of a RasterLayer or layer in a RasterStack } \usage{ minValue(x, ...) maxValue(x, ...) } \arguments{ \item{x}{RasterLayer or RasterStack object} \item{...}{Additional argument: layer number (for RasterStack or RasterBrick objects) } } \value{ a number } \details{ If a Raster* object is created from a file on disk, the min and max values are often not known (depending on the file format). You can use \code{\link[raster]{setMinMax}} to set them in the Raster* object. } \examples{ r <- raster() r <- setValues(r, 1:ncell(r)) minValue(r) maxValue(r) r <- setValues(r, round(100 * runif(ncell(r)) + 0.5)) minValue(r) maxValue(r) r <- raster(system.file("external/test.grd", package="raster")) minValue(r) maxValue(r) } \keyword{spatial} raster/man/getValues.Rd0000644000176200001440000000356114507510157014565 0ustar liggesusers\name{getValues} \alias{values} \alias{values,Raster-method} \alias{getValues} \alias{getValues,RasterLayer,missing,missing-method} \alias{getValues,RasterLayerSparse,missing,missing-method} \alias{getValues,RasterStack,missing,missing-method} \alias{getValues,RasterBrick,missing,missing-method} \alias{getValues,RasterLayer,numeric,missing-method} \alias{getValues,RasterLayerSparse,numeric,missing-method} \alias{getValues,RasterStack,numeric,missing-method} \alias{getValues,RasterBrick,numeric,missing-method} \alias{getValues,RasterLayer,numeric,numeric-method} \alias{getValues,RasterLayerSparse,numeric,numeric-method} \alias{getValues,RasterStack,numeric,numeric-method} \alias{getValues,RasterBrick,numeric,numeric-method} \title{Get raster cell values} \description{ getValues returns all values or the values for a number of rows of a Raster* object. Values returned for a RasterLayer are a vector. The values returned for a RasterStack or RasterBrick are always a matrix, with the rows representing cells, and the columns representing layers \code{values} is a shorthand version of getValues (for all rows). } \usage{ getValues(x, row, nrows, ...) values(x, ...) } \arguments{ \item{x}{Raster* object} \item{row}{Numeric. Row number, should be between 1 and nrow(x), or missing in which case all values are returned} \item{nrows}{Numeric. Number of rows. Should be an integer > 0, or missing} \item{...}{Additional arguments. When x is a \code{RasterLayer}: \code{format} to specify the output format. Either "matrix" or, the default "", in which case a vector is returned} } \value{ vector or matrix of raster values } \seealso{\code{\link{getValuesBlock}, \link{getValuesFocal}, \link{setValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) r v <- getValues(r) length(v) head(v) getValues(r, row=10) } \keyword{spatial} \keyword{methods} raster/man/modal.Rd0000644000176200001440000000245014507510157013716 0ustar liggesusers\name{modal} \alias{modal} \alias{modal,ANY-method} \alias{modal,Raster-method} \title{modal value} \description{ Compute the mode for a vector of numbers, or across raster layers. The mode, or modal value, is the most frequent value in a set of values. } \usage{ \S4method{modal}{ANY}(x, ..., ties='random', na.rm=FALSE, freq=FALSE) \S4method{modal}{Raster}(x, ..., ties='random', na.rm=FALSE, freq=FALSE) } \arguments{ \item{x}{vector of numbers (typically integers), characters, logicals, or factors, or a Raster* object} \item{...}{additional argument of the same type as \code{x}} \item{ties}{character. Indicates how to treat ties. Either 'random', 'lowest', 'highest', 'first', or 'NA'} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values are ignored. If \code{FALSE}, \code{NA} is returned if \code{x} has any \code{NA} values} \item{freq}{return the frequency of the modal value, instead of the modal value} } \value{ vector or RasterLayer. The vector has length 1 and is of the same type as \code{x}, except when \code{x} is a factor and additional arguments (values) are supplied, in which case the values are coerced to characters and a character value is returned. } \examples{ data <- c(0,1,2,3,3,3,3,4,4,4,5,5,6,7,7,8,9,NA) modal(data, na.rm=TRUE) } \keyword{univar} \keyword{math} raster/man/resolution.Rd0000644000176200001440000000135114507510157015024 0ustar liggesusers\name{resolution} \alias{xres} \alias{yres} \alias{res} \alias{xres,BasicRaster-method} \alias{yres,BasicRaster-method} \alias{res,BasicRaster-method} \alias{res<-} \alias{res<-,BasicRaster-method} \title{Resolution} \description{ Get (or set) the x and/or y resolution of a Raster* object } \usage{ xres(x) yres(x) res(x) res(x) <- value } \arguments{ \item{x}{Raster* object} \item{value}{Resolution (single number or vector of two numbers) } } \value{ A single numeric value or two numeric values. } \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{ncell}} } \examples{ r <- raster(ncol=18, nrow=18) xres(r) yres(r) res(r) res(r) <- 1/120 # set yres differently res(r) <- c(1/120, 1/60) } \keyword{spatial} raster/man/extent.Rd0000644000176200001440000000316614507510157014136 0ustar liggesusers\name{extent} \alias{extent} \alias{extent,Extent-method} \alias{extent,BasicRaster-method} \alias{extent,Spatial-method} \alias{extent,sf-method} \alias{extent,bbox-method} \alias{extent,matrix-method} \alias{extent,numeric-method} \alias{extent,list-method} \alias{extent,GridTopology-method} \alias{bbox,Raster-method} \alias{bbox,Extent-method} \title{Extent} \description{ This function returns an Extent object of a Raster* or Spatial* object (or an Extent object), or creates an Extent object from a 2x2 matrix (first row: xmin, xmax; second row: ymin, ymax), vector (length=4; order= xmin, xmax, ymin, ymax) or list (with at least two elements, with names 'x' and 'y') \code{bbox} returns a \code{sp} package like 'bbox' object (a matrix) } \usage{ extent(x, ...) } \arguments{ \item{x}{Raster* or Extent object, a matrix, a bbox, or a vector of four numbers } \item{...}{Additional arguments. When x is a single number representing 'xmin', you can pass three additional numbers (xmax, ymin, ymax) When \code{x} is a Raster* object, you can pass four additional arguments to crop the extent: \code{r1, r2, c1, c2}, representing the first and last row and column number } } \value{ Extent object } \author{Robert J. Hijmans; Etienne Racine wrote the extent function for a list} \seealso{ \code{\link[raster]{extent}}, \code{\link[raster]{drawExtent}} } \examples{ r <- raster() extent(r) extent(c(0, 20, 0, 20)) #is equivalent to extent(0, 20, 0, 20) extent(matrix(c(0, 0, 20, 20), nrow=2)) x <- list(x=c(0,1,2), y=c(-3,5)) extent(x) #crop the extent by row and column numbers extent(r, 1, 20, 10, 30) } \keyword{spatial} raster/man/barplot.Rd0000644000176200001440000000270014507510157014263 0ustar liggesusers\name{barplot} \docType{methods} \alias{barplot} \alias{barplot,RasterLayer-method} \title{Bar plot of a RasterLayer} \description{Create a barplot of the values of a RasterLayer. For large datasets a regular sample with a size of approximately \code{maxpixels} is used.} \usage{ \S4method{barplot}{RasterLayer}(height, maxpixels=1000000, digits=0, breaks=NULL, col=rainbow, ...) } \arguments{ \item{height}{RasterLayer} \item{maxpixels}{integer. To regularly subsample very large objects} \item{digits}{integer used to determine how to \code{\link{round}} the values before tabulating. Set to \code{NULL} or to a large number if you do not want any rounding } \item{breaks}{breaks used to group the data as in \code{\link[base]{cut}}} \item{col}{a color generating function such as \code{\link{rainbow}}, or a vector of colors} \item{...}{additional arguments for plotting as in \code{\link[graphics]{barplot}}} } \seealso{ \code{\link{hist}, \link{boxplot}} } \value{ A numeric vector (or matrix, when \code{beside = TRUE}) of the coordinates of the bar midpoints, useful for adding to the graph. See \code{\link[graphics]{barplot}} } \examples{ f <- system.file("external/test.grd", package="raster") r <- raster(f) barplot(r, digits=-2, las=2, ylab='Frequency') op <- par(no.readonly = TRUE) par(mai = c(1, 2, .5, .5)) barplot(r, breaks=10, col=c('red', 'blue'), horiz=TRUE, digits=NULL, las=1) par(op) } \keyword{methods} \keyword{spatial} raster/man/mosaic.Rd0000644000176200001440000000346614507510157014105 0ustar liggesusers\name{mosaic} \docType{methods} \alias{mosaic} \alias{mosaic,Raster,Raster-method} \title{ Merge Raster* objects using a function for overlapping areas } \description{ Mosaic Raster* objects to form a new object with a larger spatial extent. A function is used to compute cell values in areas where layers overlap (in contrast to the \code{\link[raster]{merge}} function which uses the values of the 'upper' layer). All objects must have the same origin, resolution, and coordinate reference system. } \usage{ \S4method{mosaic}{Raster,Raster}(x, y, ..., fun, tolerance=0.05, filename="") } \arguments{ \item{x}{Raster* object} \item{y}{Raster* object} \item{...}{Additional Raster or Extent objects (and/or arguments for writing files as in \code{\link{writeRaster})}} \item{fun}{Function. E.g. mean, min, or max. Must be a function that accepts a 'na.rm' argument} \item{tolerance}{Numeric. permissible difference in origin (relative to the cell resolution). See \code{\link[base]{all.equal}}} \item{filename}{Character. Output filename (optional)} } \details{ The Raster objects must have the same origin and resolution. } \value{ RasterLayer or RasterBrick object. } \seealso{ \code{\link[raster]{merge}}, \code{\link[raster]{extend}}} \examples{ r <- raster(ncol=100, nrow=100) r1 <- crop(r, extent(-10, 11, -10, 11)) r2 <- crop(r, extent(0, 20, 0, 20)) r3 <- crop(r, extent(9, 30, 9, 30)) values(r1) <- 1:ncell(r1) values(r2) <- 1:ncell(r2) values(r3) <- 1:ncell(r3) m1 <- mosaic(r1, r2, r3, fun=mean) s1 <- stack(r1, r1*2) s2 <- stack(r2, r2/2) s3 <- stack(r3, r3*4) m2 <- mosaic(s1, s2, s3, fun=min) # if you have a list of Raster objects, you can use do.call x <- list(r1, r2, r3) names(x)[1:2] <- c('x', 'y') x$fun <- mean x$na.rm <- TRUE y <- do.call(mosaic, x) } \keyword{methods} \keyword{spatial} raster/man/direction.Rd0000644000176200001440000000255014507510157014603 0ustar liggesusers\name{direction} \alias{direction} \alias{direction,RasterLayer-method} \title{Direction} \description{ The direction (azimuth) to or from the nearest cell that is not \code{NA}. The direction unit is in radians, unless you use argument \code{degrees=TRUE}. } \usage{ \S4method{direction}{RasterLayer}(x, filename='', degrees=FALSE, from=FALSE, doEdge=FALSE, ...) } \arguments{ \item{x}{RasterLayer object} \item{filename}{Character. Output filename (optional)} \item{degrees}{Logical. If \code{FALSE} (the default) the unit of direction is radians.} \item{from}{Logical. Default is \code{FALSE}. If \code{TRUE}, the direction from (instead of to) the nearest cell that is not \code{NA} is returned} \item{doEdge}{Logical. If \code{TRUE}, the \code{\link{boundaries}} function is called first. This may be efficient in cases where you compute the distance to large blobs. Calling \code{boundaries} determines the edge cells that matter for direction computation} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{RasterLayer} \seealso{ \code{\link[raster]{distance}}, \code{\link[raster]{gridDistance}} For the direction between (longitude/latitude) points, see the \code{azimuth} function in the \code{geosphere} package } \examples{ r <- raster(ncol=36,nrow=18) values(r) <- NA r[306] <- 1 b <- direction(r) #plot(b) } \keyword{spatial} raster/man/plot.Rd0000644000176200001440000001412614507510157013603 0ustar liggesusers\name{plot} \docType{methods} \alias{plot} \alias{plot,Raster,ANY-method} \alias{plot,Raster,Raster-method} \alias{plot,Extent,missing-method} \alias{lines,RasterLayer-method} \alias{lines,Extent-method} \title{Plot a Raster* object} \description{ Plot (that is, make a map of) the values of a Raster* object, or make a scatterplot of their values. Points, lines, and polygons can be drawn on top of a map using \code{plot(..., add=TRUE)}, or with functions like \code{points, lines, polygons} See the \code{rasterVis} package for more advanced (trellis/lattice) plotting of Raster* objects. } \usage{ \S4method{plot}{Raster,ANY}(x, y, maxpixels=500000, col, alpha=NULL, colNA=NA, add=FALSE, ext=NULL, useRaster=TRUE, interpolate=FALSE, addfun=NULL, nc, nr, maxnl=16, main, npretty=0, ...) \S4method{plot}{Raster,Raster}(x, y, maxpixels=100000, cex, xlab, ylab, nc, nr, maxnl=16, main, add=FALSE, gridded=FALSE, ncol=25, nrow=25, ...) } \arguments{ \item{x}{Raster* object} \item{y}{If \code{x} is a RasterStack or RasterBrick: integer, character (layer name(s)), or missing to select which layer(s) to plot. If missing, all RasterLayers in the RasterStack will be plotted (up to a maximum of 16). Or another Raster* object of the same extent and resolution, to produce a scatter plot of the cell values. } \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting. If \code{gridded=TRUE} maxpixels may be ignored to get a larger sample} \item{col}{A color palette, i.e. a vector of n contiguous colors generated by functions like \link{rainbow}, \link{heat.colors}, \link{topo.colors}, \link[sp]{bpy.colors} or one or your own making, perhaps using \code{\link{colorRampPalette}}. If none is provided, \code{rev(terrain.colors(255))} is used unless \code{x} has a 'color table'} \item{alpha}{Number between 0 and 1 to set transparency. 0 is entirely transparent, 1 is not transparent (NULL is equivalent to 1)} \item{colNA}{The color to use for the background (default is transparent)} \item{add}{Logical. Add to current plot?} \item{ext}{An extent object to zoom in a region (see also \code{\link{zoom}} and \code{\link{crop}(x, \link{drawExtent}())}} \item{useRaster}{If \code{TRUE}, the rasterImage function is used for plotting. Otherwise the image function is used. This can be useful if rasterImage does not work well on your system (see note)} \item{interpolate}{Logical. Should the image be interpolated (smoothed)? Only used when \code{useRaster = TRUE}} \item{addfun}{Function to add additional items such as points or polygons to the plot (map). Typically containing statements like "points(xy); plot(polygons, add=TRUE)". This is particularly useful to add something to each map when plotting a multi-layer Raster* object.} \item{npretty}{integer. Number of decimals for \link{pretty} lables on the axes} \item{...}{Graphical parameters. Any argument that can be passed to \code{\link[fields]{image.plot}} and to base \code{plot}, such as axes=FALSE, main='title', ylab='latitude'} \item{xlab}{Optional. x-axis label)} \item{ylab}{Optional. y-axis label)} \item{nc}{Optional. The number of columns to divide the plotting device in (when plotting multiple layers in a RasterLayer or RasterBrick object)} \item{nr}{Optional. The number of rows to divide the plotting device in (when plotting multiple layers in a RasterLayer or RasterBrick object)} \item{maxnl}{integer. Maximum number of layers to plot (for a multi-layer object)} \item{main}{character. Main plot title} \item{cex}{Symbol size for scatter plots} \item{gridded}{logical. If \code{TRUE} the scatterplot is gridded (counts by cells)} \item{ncol}{integer. Number of columns for gridding} \item{nrow}{integer. Number of rows for gridding} } \details{ Most of the code for the plot function for a single Raster* object was taken from image.plot (fields package). Raster objects with a color-table (e.g. a graphics file) are plotted according to that color table. } \note{ raster uses \code{\link[graphics]{rasterImage}} from the graphics package. For unknown reasons this does not work on Windows Server and on a few versions of Windows XP. On that system you may need to use argument \code{useRaster=FALSE} to get a plot. } \seealso{ The \code{rasterVis} package has lattice based methods for plotting Raster* objects (like \code{\link[raster]{spplot}}) red-green-blue plots (e.g. false color composites) can be made with \code{\link[raster]{plotRGB}} \code{\link[raster]{barplot}}, \code{\link[raster]{hist}}, \code{\link[raster]{text}}, \code{\link[raster]{persp}}, \code{\link[raster]{contour}}, \code{\link[raster]{pairs}} } \examples{ # RasterLayer r <- raster(nrows=10, ncols=10) r <- setValues(r, 1:ncell(r)) plot(r) e <- extent(r) plot(e, add=TRUE, col='red', lwd=4) e <- e / 2 plot(e, add=TRUE, col='red') # Scatterplot of 2 RasterLayers r2 <- sqrt(r) plot(r, r2) plot(r, r2, gridded=TRUE) # Multi-layer object (RasterStack / Brick) s <- stack(r, r2, r/r) plot(s, 2) plot(s) # two objects, different range, one scale: values(r) <- runif(ncell(r)) r2 <- r/2 brks <- seq(0, 1, by=0.1) nb <- length(brks)-1 cols <- rev(terrain.colors(nb)) par(mfrow=c(1,2)) plot(r, breaks=brks, col=cols, lab.breaks=brks, zlim=c(0,1), main='first') plot(r2, breaks=brks, col=cols, lab.breaks=brks, zlim=c(0,1), main='second') # breaks and labels x <- raster(nc=10, nr=10) values(x) <- runif(ncell(x)) brk <- c(0, 0.25, 0.75, 1) arg <- list(at=c(0.12,0.5,0.87), labels=c("Low","Med.","High")) plot(x, col=terrain.colors(3), breaks=brk) plot(x, col=terrain.colors(3), breaks=brk, axis.args=arg) par(mfrow=c(1,1)) # color ramp plot(x, col=colorRampPalette(c("red", "white", "blue"))(255)) # adding random points to the map xy <- cbind(-180 + runif(10) * 360, -90 + runif(10) * 180) points(xy, pch=3, cex=5) # for SpatialPolygons do # plot(pols, add=TRUE) # adding the same points to each map of each layer of a RasterStack fun <- function() { points(xy, cex=2) points(xy, pch=3, col='red') } plot(s, addfun=fun) } \keyword{methods} \keyword{spatial} raster/man/origin.Rd0000644000176200001440000000142714507510157014114 0ustar liggesusers\name{origin} \alias{origin} \alias{origin,BasicRaster-method} \alias{origin<-} \alias{origin<-,BasicRaster-method} \title{Origin} \description{ Origin returns (or sets) the coordinates of the point of origin of a Raster* object. This is the point closest to (0, 0) that you could get if you moved towards that point in steps of the x and y resolution. } \usage{ origin(x, ...) origin(x) <- value } \arguments{ \item{x}{Raster* object} \item{value}{numeric vector of length 1 or 2} \item{...}{additional arguments. None implemented} } \value{ A vector of two numbers (x and y coordinates), or a changed origin for \code{x}. } \seealso{ \code{\link[raster]{extent}}} \examples{ r <- raster(xmn=-0.5, xmx = 9.5, ncols=10) origin(r) r origin(r) <- 0 r } \keyword{spatial} raster/man/update.Rd0000644000176200001440000000351414507510157014106 0ustar liggesusers\name{update} \docType{methods} \alias{update} \alias{update,RasterLayer-method} \alias{update,RasterBrick-method} \title{Update raster cells of files (on disk)} \description{ Update cell values of a file (i.e., cell values on disk) associated with a RasterLayer or RasterBrick. User beware: this function _will_ make changes to your file (first make a copy if you are not sure what you are doing). Writing starts at a cell number \code{cell}. You can write a vector of values (in cell order), or a matrix. You can also provide a vector of cell numbers (of the same length as vector \code{v}) to update individual cells. See \code{\link{writeFormats}} for supported formats. } \usage{ \S4method{update}{RasterLayer}(object, v, cell, ...) \S4method{update}{RasterBrick}(object, v, cell, band, ...) } \arguments{ \item{object}{RasterLayer or RasterBrick that is associated with a file} \item{v}{vector or matrix with new values} \item{cell}{cell from where to start writing. Or a vector of cell numbers if v is a vector of the same length}. \item{band}{band (layer) to update (for RasterBrick objects)}. \item{...}{additional arguments. None implemented} } \value{ RasterLayer or RasterBrick } \examples{ \dontrun{ # setting up an example RasterLayer with file r <- raster(nrow=5, ncol=10, vals=0) r <- writeRaster(r, rasterTmpFile(), overwrite=TRUE, datatype='INT2S') as.matrix(r) # update with a vector starting a cell r <- update(r, v=rep(1, 5), cell=6) # 99.99 gets rounded because this is an integer file r <- update(r, v=9.99, cell=50) as.matrix(r) # update with a vector of values and matching vector of cell numbers r <- update(r, v=5:1, cell=c(5,15,25,35,45)) as.matrix(r) # updating with a marix, anchored at a cell number m <- matrix(1:10, ncol=2) r <- update(r, v=m, cell=2) as.matrix(r) } } \keyword{methods} \keyword{spatial} raster/man/rasterOptions.Rd0000644000176200001440000001052614507510157015501 0ustar liggesusers\name{Options} \alias{rasterOptions} \alias{tmpDir} \title{Global options for the raster package} \description{ Set, inspect, reset, save a number of global options used by the raster package. Most of these options are used when writing files to disk. They can be ignored by specific functions if the corresponding argument is provided as an argument to these functions. The default location is returned by \code{rasterTmpDir}. It is the same as that of the R temp directory but you can change it (for the current session) with \code{rasterOptions(tmpdir="path")}. To permanently set any of these options, you can add them to \code{/etc/Rprofile.site>}. For example, to change the default directory used to save temporary files, add a line like this: \code{options(rasterTmpDir='c:/temp/')} to that file. All temporary raster files in that folder that are older than 24 hrs are deleted when the raster package is loaded. Function \code{tmpDir} returns the location of the temporary files } \usage{ rasterOptions(format, overwrite, datatype, tmpdir, tmptime, progress, timer, chunksize, minmemory, maxmemory, memfrac, todisk, setfileext, tolerance, standardnames, depracatedwarnings, addheader, default=FALSE) tmpDir(create=TRUE) } \arguments{ \item{format}{character. The default file format to use. See \code{\link[raster]{writeFormats}}} \item{overwrite}{logical. The default value for overwriting existing files. If \code{TRUE}, existing files will be overwritten} \item{datatype}{character. The default data type to use. See \link[raster]{dataType}} \item{tmpdir}{character. The default location for writing temporary files; See \code{\link{rasterTmpFile}}} \item{tmptime}{number > 1. The number of hours after which a temporary file will be deleted. As files are deleted when loading the raster package, this option is only useful if you save this option so that it is loaded when starting a new session} \item{progress}{character. Valid values are "text", "window" and "" (the default in most functions, no progress bar)} \item{timer}{Logical. If \code{TRUE}, the time it took to complete the function is printed} \item{chunksize}{integer. Maximum number of bytes to read/write in a single chunk while processing (chunk by chunk) disk based Raster* objects} \item{maxmemory}{numeric. Maximum number of bytes to read into memory. If a process is expected to require more than this value, \code{\link{canProcessInMemory}} will return \code{FALSE}. It cannot be set to a value smaller than 10000 } \item{minmemory}{numeric. Minimum number of bytes that are guaranteed to be fit into memory. If a process is expected to require more than this value, RAM available will be estimated. It cannot be set to a value smaller than 10000} \item{memfrac}{numeric. Fraction of available RAM that may be used by a process} \item{todisk}{logical. For debugging only. Default is \code{FALSE} and should normally not be changed. If \code{TRUE}, results are always written to disk, even if no filename is supplied (a temporary filename is used)} \item{setfileext}{logical. Default is \code{TRUE}. If \code{TRUE}, the file extension will be changed when writing (if known for the file type). E.g. GTiff files will be saved with the .tif extension } \item{tolerance}{numeric. The tolerance used when comparing the origin and resolution of Raster* objects. Expressed as the fraction of a single cell. This should be a number between 0 and 0.5 } \item{standardnames}{logical. Default is \code{TRUE}. Should \code{\link{names}} be standardized to be syntactically valid names (using \code{\link{make.names}})} \item{depracatedwarnings}{logical. If \code{TRUE} (the default) a warning is generated when a depracated (obsolete) function is used} \item{addheader}{character. If not equal to \code{''} (the default) an additional header file is written when a raster format file (grd/gri) is written. Supported formats are as in \code{\link{hdr}}} \item{default}{logical. If \code{TRUE}, all options are set to their default values} \item{create}{logical. If \code{TRUE}, the temporary files directory is created if it does not exist} } \value{ list of the current options (invisibly). If no arguments are provided the options are printed. } \seealso{ \code{\link[base]{options}}, \code{\link[raster]{rasterTmpFile}} } \examples{ \dontrun{ rasterOptions() rasterOptions(chunksize=2e+07) } } \keyword{ spatial } raster/man/transpose.Rd0000644000176200001440000000066614507510157014647 0ustar liggesusers\name{transpose} \docType{methods} \alias{t} \alias{t,RasterLayer-method} \alias{t,RasterStackBrick-method} \title{Transpose} \description{ Transpose a Raster* object } \usage{ t(x) } \arguments{ \item{x}{a Raster* object} } \value{ RasterLayer or RasterBrick } \seealso{ transpose: \code{\link{flip}, \link[raster]{rotate}} } \examples{ r <- raster(nrow=18, ncol=36) values(r) <- 1:ncell(r) rt <- t(r) } \keyword{spatial} raster/man/getData.Rd0000644000176200001440000000034714642773303014202 0ustar liggesusers\name{getData} \alias{getData} \alias{ccodes} \title{Get geographic data } \description{ This function has been deprecated and does not work anymore. } \usage{ getData(...) ccodes() } \arguments{ \item{...}{arguments} } raster/man/blockSize.Rd0000644000176200001440000000242414507510157014550 0ustar liggesusers\name{blockSize} \alias{blockSize} \alias{blockSize,Raster-method} \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{ \S4method{blockSize}{Raster}(x, chunksize, n=nlayers(x), minblocks=4, minrows=1) } \arguments{ \item{x}{Raster* object} \item{chunksize}{Integer, normally missing. Can be used to set the block size; unit is number of cells. Block size is then computed in units of number of rows (always >= 1) } \item{n}{Integer. number of layers to consider. The function divides chunksize by n to determine blocksize } \item{minblocks}{Integer. Minimum number of blocks } \item{minrows}{Integer. Minimum number of rows in each block } } \value{ A list with three elements: \code{rows}, the suggested row numbers at which to start the blocks for reading and writing, \code{nrows}, the number of rows in each block, and, \code{n}, the total number of blocks } \seealso{ \code{\link[raster]{writeValues}} } \examples{ r <- raster(system.file("external/test.grd", package="raster")) blockSize(r) } \keyword{ spatial } \keyword{ methods } raster/man/clearValues.Rd0000644000176200001440000000066014507510157015071 0ustar liggesusers \name{clearValues} \alias{clearValues} \title{Clear values} \description{ Clear cell values of a Raster* object from memory } \usage{ clearValues(x) } \arguments{ \item{x}{Raster* object } } \seealso{ \code{\link{values}}, \code{\link[raster]{replacement} }} \value{ a Raster* object } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- 1:ncell(r) r <- clearValues(r) } \keyword{ spatial } \keyword{ methods } raster/man/crosstab.Rd0000644000176200001440000000276614507510157014454 0ustar liggesusers\name{crosstab} \docType{methods} \alias{crosstab} \alias{crosstab,Raster,Raster-method} \alias{crosstab,RasterStackBrick,missing-method} \title{Cross-tabulate} \description{ Cross-tabulate two RasterLayer objects, or mulitiple layers in a RasterStack or RasterBrick to create a contingency table. } \usage{ \S4method{crosstab}{Raster,Raster}(x, y, digits=0, long=FALSE, useNA=FALSE, progress='', ...) \S4method{crosstab}{RasterStackBrick,missing}(x, digits=0, long=FALSE, useNA=FALSE, progress='', ...) } \arguments{ \item{x}{Raster* object} \item{y}{Raster* object if \code{x} is a RasterLayer; Can be missing if \code{x} is a RasterStack or RasterBrick} \item{digits}{integer. The number of digits for rounding the values before cross-tabulation} \item{long}{logical. If \code{TRUE} the results are returned in 'long' format data.frame instead of a table} \item{useNA}{logical, indicting if the table should includes counts of \code{NA} values} \item{progress}{character. "text", "window", or "" (the default, no progress bar), only for large files that cannot be processed in one step} \item{...}{additional arguments. none implemented} } \value{ A table or data.frame } \seealso{ \code{\link[raster]{freq}}, \code{\link[raster]{zonal}} } \examples{ r <- raster(nc=5, nr=5) values(r) <- runif(ncell(r)) * 2 s <- setValues(r, runif(ncell(r)) * 3) crosstab(r,s) rs <- r/s r[1:5] <- NA s[20:25] <- NA x <- stack(r, s, rs) crosstab(x, useNA=TRUE, long=TRUE) } \keyword{methods} \keyword{spatial} raster/man/rowSums.Rd0000644000176200001440000000146114507510157014302 0ustar liggesusers\name{rowSums} \docType{methods} \alias{rowSums} \alias{rowSums,Raster-method} \alias{colSums} \alias{colSums,Raster-method} \title{rowSums and colSums for Raster objects} \description{ Sum values of Raster objects by row or column. } \usage{ \S4method{rowSums}{Raster}(x, na.rm=FALSE, dims=1L,...) \S4method{colSums}{Raster}(x, na.rm=FALSE, dims=1L,...) } \arguments{ \item{x}{Raster* object} \item{na.rm}{logical. If \code{TRUE}, \code{NA} values are ignored} \item{dims}{this argument is ignored} \item{...}{additional arguments (none implemented)} } \value{ vector (if \code{x} is a RasterLayer) or matrix } \seealso{ See \code{\link{cellStats}} for summing all cells values } \examples{ r <- raster(ncols=2, nrows=5) values(r) <- 1:10 as.matrix(r) rowSums(r) colSums(r) } \keyword{spatial} raster/man/interpolate.Rd0000644000176200001440000001156314507510157015155 0ustar liggesusers\name{interpolate} \docType{methods} \alias{interpolate} \alias{interpolate,Raster-method} \title{Interpolate} \description{ Make a RasterLayer with interpolated values using a fitted model object of classes such as 'gstat' (gstat package) or 'Krige' (fields package). That is, these are models that have location ('x' and 'y', or 'longitude' and 'latitude') as independent variables. If x and y are the only independent variables provide an empty (no associated data in memory or on file) RasterLayer for which you want predictions. If there are more spatial predictor variables provide these as a Raster* object in the first argument of the function. If you do not have x and y locations as implicit predictors in your model you should use \code{\link[raster]{predict}} instead. } \usage{ \S4method{interpolate}{Raster}(object, model, filename="", fun=predict, xyOnly=TRUE, xyNames=c('x', 'y'), ext=NULL, const=NULL, index=1, na.rm=TRUE, debug.level=1, ...) } \arguments{ \item{object}{Raster* object} \item{model}{model object} \item{filename}{character. Output filename (optional)} \item{fun}{function. Default value is 'predict', but can be replaced with e.g. 'predict.se' (depending on the class of the model object)} \item{xyOnly}{logical. If \code{TRUE}, values of the Raster* object are not considered as co-variables; and only x and y (longitude and latitude) are used. This should match the model} \item{xyNames}{character. variable names that the model uses for the spatial coordinates. E.g., \code{c('longitude', 'latitude')}} \item{ext}{Extent object to limit the prediction to a sub-region of \code{x}} \item{const}{data.frame. Can be used to add a constant for which there is no Raster object for model predictions. This is particulary useful if the constant is a character-like factor value} \item{index}{integer. To select the column if 'predict.model' returns a matrix with multiple columns} \item{na.rm}{logical. Remove cells with NA values in the predictors before solving the model (and return \code{NA} for those cells). In most cases this will not affect the output. This option prevents errors with models that cannot handle \code{NA} values} \item{debug.level}{for gstat models only. See ?} \item{...}{additional arguments passed to the predict.'model' function} } \value{ Raster* object } \seealso{ \code{\link[raster]{predict}}, \code{\link[gstat]{predict.gstat}}, \code{\link[fields]{Tps}} } \examples{ \donttest{ ## Thin plate spline interpolation with x and y only # some example data r <- raster(system.file("external/test.grd", package="raster")) ra <- aggregate(r, 10) xy <- data.frame(xyFromCell(ra, 1:ncell(ra))) v <- getValues(ra) # remove NAs i <- !is.na(v) xy <- xy[i,] v <- v[i] #### Thin plate spline model library(fields) tps <- Tps(xy, v) p <- raster(r) # use model to predict values at all locations p <- interpolate(p, tps) p <- mask(p, r) plot(p) ## change the fun from predict to fields::predictSE to get the TPS standard error se <- interpolate(p, tps, fun=predictSE) se <- mask(se, r) plot(se) ## another variable; let's call it elevation elevation <- (init(r, 'x') * init(r, 'y')) / 100000000 names(elevation) <- 'elev' z <- extract(elevation, xy) # add as another independent variable xyz <- cbind(xy, z) tps2 <- Tps(xyz, v) p2 <- interpolate(elevation, tps2, xyOnly=FALSE) # as a linear coveriate tps3 <- Tps(xy, v, Z=z) # Z is a separate argument in Krig.predict, so we need a new function # Internally (in interpolate) a matrix is formed of x, y, and elev (Z) pfun <- function(model, x, ...) { predict(model, x[,1:2], Z=x[,3], ...) } p3 <- interpolate(elevation, tps3, xyOnly=FALSE, fun=pfun) #### gstat examples library(gstat) data(meuse) ## inverse distance weighted (IDW) r <- raster(system.file("external/test.grd", package="raster")) data(meuse) mg <- gstat(id = "zinc", formula = zinc~1, locations = ~x+y, data=meuse, nmax=7, set=list(idp = .5)) z <- interpolate(r, mg) z <- mask(z, r) ## kriging coordinates(meuse) <- ~x+y crs(meuse) <- crs(r) ## ordinary kriging v <- variogram(log(zinc)~1, meuse) m <- fit.variogram(v, vgm(1, "Sph", 300, 1)) gOK <- gstat(NULL, "log.zinc", log(zinc)~1, meuse, model=m) OK <- interpolate(r, gOK) # examples below provided by Maurizio Marchi ## universial kriging vu <- variogram(log(zinc)~elev, meuse) mu <- fit.variogram(vu, vgm(1, "Sph", 300, 1)) gUK <- gstat(NULL, "log.zinc", log(zinc)~elev, meuse, model=mu) names(r) <- 'elev' UK <- interpolate(r, gUK, xyOnly=FALSE) ## co-kriging gCoK <- gstat(NULL, 'log.zinc', log(zinc)~1, meuse) gCoK <- gstat(gCoK, 'elev', elev~1, meuse) gCoK <- gstat(gCoK, 'cadmium', cadmium~1, meuse) gCoK <- gstat(gCoK, 'copper', copper~1, meuse) coV <- variogram(gCoK) plot(coV, type='b', main='Co-variogram') coV.fit <- fit.lmc(coV, gCoK, vgm(model='Sph', range=1000)) coV.fit plot(coV, coV.fit, main='Fitted Co-variogram') coK <- interpolate(r, coV.fit) plot(coK) } } \keyword{methods} \keyword{spatial} raster/man/colortable.Rd0000644000176200001440000000134514507510157014752 0ustar liggesusers\name{colortable} \alias{colortable} \alias{colortable<-} \title{colortable} \description{ Get or set the colortable of a RasterLayer. A colortable is a vector of 256 colors in the RGB triple format as returned by the \code{\link{rgb}} function (e.g. "#C4CDDA"). When setting the colortable, it is assumed that the values are integers in the range [0,255] } \usage{ colortable(x) colortable(x) <- value } \arguments{ \item{x}{RasterLayer object} \item{value}{vector of 256 character values} } \seealso{ \code{\link[raster]{plotRGB}} } \examples{ r <- raster(ncol=10, nrow=10) values(r) <- sample(0:255, ncell(r), replace=TRUE) ctab <- sample(rainbow(256)) colortable(r) <- ctab plot(r) head(colortable(r)) } \keyword{spatial} raster/man/match.Rd0000644000176200001440000000217614507510157013723 0ustar liggesusers\name{match} \docType{methods} \alias{match} \alias{match,Raster-method} \alias{\%in\%} \alias{\%in\%,Raster-method} \title{Value matching for Raster* objects} \description{ \code{match} returns a Raster* object with the position of the matched values. The cell values are the index of the table argument. \code{\%in\%} returns a logical Raster* object indicating if the cells values were matched or not. } \usage{ match(x, table, nomatch = NA_integer_, incomparables = NULL) x \%in\% table } \arguments{ \item{x}{Raster* object} \item{table}{vector of the values to be matched against} \item{nomatch}{the value to be returned in the case when no match is found. Note that it is coerced to integer} \item{incomparables}{a vector of values that cannot be matched. Any value in x matching a value in this vector is assigned the nomatch value. For historical reasons, FALSE is equivalent to NULL} } \value{ Raster* object } \seealso{ \code{\link{calc}, \link[base]{match}} } \examples{ r <- raster(nrow=10, ncol=10) values(r) <- 1:100 m <- match(r, c(5:10, 50:55)) n <- r \%in\% c(5:10, 50:55) } \keyword{spatial} \keyword{methods} raster/man/aggregate.Rd0000644000176200001440000001177714507510157014564 0ustar liggesusers\name{aggregate} \docType{methods} \alias{aggregate} \alias{aggregate,Raster-method} \alias{aggregate,SpatialPolygons-method} \alias{aggregate,SpatialLines-method} \title{Aggregate raster cells or SpatialPolygons/Lines} \description{ Raster* objects: Aggregate a Raster* object to create a new RasterLayer or RasterBrick with a lower resolution (larger cells). Aggregation groups rectangular areas to create larger cells. The value for the resulting cells is computed with a user-specified function. SpatialPolygon*: Aggregate a SpatialPolygon* object, optionally by combining polygons that have the same attributes for one or more variables. If the polygons touch or overlap, internal boundaries are optionally "dissolved". } \usage{ \S4method{aggregate}{Raster}(x, fact, fun=mean, expand=TRUE, na.rm=TRUE, filename='', ...) \S4method{aggregate}{SpatialPolygons}(x, by, sums, dissolve=TRUE, vars=NULL, ...) } \arguments{ \item{x}{Raster* object or SpatialPolygons* object} \item{fact}{postive integer. Aggregation factor expressed as number of cells in each direction (horizontally and vertically). Or two integers (horizontal and vertical aggregation factor) or three integers (when also aggregating over layers). See Details} \item{fun}{function used to aggregate values } \item{expand}{logical. If \code{TRUE} the output Raster* object will be larger than the input Raster* object if a division of the number of columns or rows with \code{factor} is not an integer} \item{na.rm}{logical. If \code{TRUE}, NA cells are removed from calculations } \item{filename}{character. Output filename (optional)} \item{...}{if \code{x} is a Raster* object, additional arguments as for \code{\link{writeRaster}}} \item{by}{character or integer. The variables (column names or numbers) that should be used to aggregate (dissolve) the SpatialPolygons by only maintaining unique combinations of these variables. The default setting is to use no variables and aggregate all polygons. You can also supply a vector with a length of length(x)} \item{sums}{list with function(s) and variable(s) to summarize. This should be a list of lists in which each element of the main lists has two items. The first item is function (e.g. mean), the second element is a vector of column names (or indices) that need to summarize with that function. Be careful with character and factor variables (you can use, e.g. 'first' \code{function(x)x[1]} or 'last' \code{function(x)x[length(x)]} or \code{modal} for these variables} \item{vars}{deprecated. Same as \code{by}} \item{dissolve}{logical. If \code{TRUE} borders between touching or overlapping polygons are removed} } \details{ Aggregation of a \code{x} will result in a Raster* object with fewer cells. The number of cells is the number of cells of \code{x} divided by \code{fact*fact} (when fact is a single number) or \code{prod(fact)} (when fact consists of 2 or 3 numbers). If necessary this number is adjusted according to the value of \code{expand}. For example, \code{fact=2} will result in a new Raster* object with \code{2*2=4} times fewer cells. If two numbers are supplied, e.g., \code{fact=c(2,3)}, the first will be used for aggregating in the horizontal direction, and the second for aggregating in the vertical direction, and the returned object will have \code{2*3=6} times fewer cells. Likewise, \code{fact=c(2,3,4)} aggregates cells in groups of 2 (rows) by 3 (columns) and 4 (layers). Aggregation starts at the upper-left end of a raster (you can use \code{\link{flip}} if you want to start elsewhere). If a division of the number of columns or rows with \code{factor} does not return an integer, the extent of the resulting Raster object will either be somewhat smaller or somewhat larger than the original RasterLayer. For example, if an input RasterLayer has 100 columns, and \code{fact=12}, the output Raster object will have either 8 columns (\code{expand=FALSE}) (using \code{8 x 12 = 96} of the original columns) or 9 columns (\code{expand=TRUE}). In both cases, the maximum x coordinate of the output RasterLayer would, of course, also be adjusted. The function \code{fun} should take multiple numbers, and return a single number. For example \code{mean}, \code{modal}, \code{min} or \code{max}. It should also accept a \code{na.rm} argument (or ignore it as one of the 'dots' arguments). } \value{ RasterLayer or RasterBrick, or a SpatialPolygons* object } \seealso{ \code{\link{disaggregate}}, \code{\link{resample}}. For SpatialPolygons* \code{\link[sp]{disaggregate}} } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster() # a new aggregated raster, no values ra <- aggregate(r, fact=10) r <- setValues(r, runif(ncell(r))) # a new aggregated raster, max of the values ra <- aggregate(r, fact=10, fun=max) # multiple layers s <- stack(r, r*2) x <- aggregate(s,2) #SpatialPolygons p <- shapefile(system.file("external/lux.shp", package="raster")) p pa0 <- aggregate(p) pa0 pa1 <- aggregate(p, by='NAME_1', sums=list(list(mean, 'ID_2'))) pa1 } \keyword{methods} \keyword{spatial} raster/man/distance.Rd0000644000176200001440000000354114507510157014416 0ustar liggesusers\name{distance} \alias{distance} \alias{distance,RasterLayer,missing-method} \alias{distance,RasterLayer,RasterLayer-method} \alias{distance,Spatial,Spatial-method} \title{Distance} \description{ For a single \code{RasterLayer} (\code{y} is missing) this method computes the distance, for all cells that are \code{NA}, to the nearest cell that is not \code{NA}. The distance unit is in meters if the RasterLayer is not projected (\code{+proj=longlat}) and in map units (typically also meters) when it is projected. If two \code{RasterLayer} objects are provided, the cell-value distances are computed. If two \code{Spatial} vector type objects are provided, the distances between pairs of geographic object are computed. } \usage{ \S4method{distance}{RasterLayer,missing}(x, y, filename='', doEdge=TRUE, ...) \S4method{distance}{RasterLayer,RasterLayer}(x, y, ...) \S4method{distance}{Spatial,Spatial}(x, y, ...) } \arguments{ \item{x}{RasterLayer object} \item{y}{missing, RasterLayer or Spatial object} \item{filename}{Character. Filename for the output RasterLayer (optional)} \item{doEdge}{Logical. If \code{TRUE}, the \code{\link{boundaries}} function is called first. This may be efficient in cases where you compute the distance to large blobs. Calling \code{boundaries} determines the edge cells that matter for distance computation} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{RasterLayer} \seealso{ \code{\link[raster]{distanceFromPoints}}, \code{\link[raster]{gridDistance}}, \code{\link[raster]{pointDistance}} See the \code{gdistance} package for more advanced distances, and the \code{geosphere} package for great-circle distances (and more) between points in longitude/latitude coordinates. } \examples{ r <- raster(ncol=36,nrow=18) values(r) <- NA r[500] <- 1 dist <- distance(r) #plot(dist / 1000) } \keyword{spatial} raster/man/shift.Rd0000644000176200001440000000206114507510157013735 0ustar liggesusers\name{shift} \docType{methods} \alias{shift} \alias{shift,Raster-method} \alias{shift,SpatialPolygons-method} \alias{shift,SpatialLines-method} \alias{shift,SpatialPoints-method} \title{Shift} \description{ Shift the location of a Raster* of vector type Spatial* object in the x and/or y direction } \usage{ \S4method{shift}{Raster}(x, dx=0, dy=0, filename='', ...) \S4method{shift}{SpatialPolygons}(x, dx=0, dy=0, ...) \S4method{shift}{SpatialLines}(x, dx=0, dy=0, ...) \S4method{shift}{SpatialPoints}(x, dx=0, dy=0, ...) } \arguments{ \item{x}{Raster* or Spatial* object} \item{dx}{numeric. The shift in horizontal direction} \item{dy}{numeric. The shift in vertical direction} \item{filename}{character file name (optional)} \item{...}{if \code{x} is a Raster* object: additional arguments as for \code{\link{writeRaster}} } } \value{ Same object type as \code{x} } \seealso{ \code{\link{flip}}, \code{\link{rotate}}, and the elide function in the maptools package } \examples{ r <- raster() r <- shift(r, dx=1, dy=-1) } \keyword{spatial} raster/man/merge.Rd0000644000176200001440000000441514507510157013724 0ustar liggesusers\name{merge} \docType{methods} \alias{merge} \alias{merge,Raster,Raster-method} \alias{merge,RasterStackBrick,missing-method} \alias{merge,Extent,ANY-method} \title{ Merge Raster* objects } \description{ Merge Raster* objects to form a new Raster object with a larger spatial extent. If objects overlap, the values get priority in the same order as the arguments, but \code{NA} values are ignored (except when \code{overlap=FALSE}). See \code{\link[raster]{subs}} to merge a \code{Raster*} object and a \code{data.frame}. } \usage{ \S4method{merge}{Raster,Raster}(x, y, ..., tolerance=0.05, filename="", overlap=TRUE, ext=NULL) \S4method{merge}{RasterStackBrick,missing}(x, ..., tolerance=0.05, filename="", ext=NULL) \S4method{merge}{Extent,ANY}(x, y, ...) } \arguments{ \item{x}{Raster* or Extent object} \item{y}{Raster* if \code{x} is a Raster* object (or missing). If \code{x} is an Extent, \code{y} can be an Extent or object from which an Extent can be extracted} \item{...}{additional Raster or Extent objects (and/or arguments for writing files as in \code{\link{writeRaster})}} \item{tolerance}{numeric. permissible difference in origin (relative to the cell resolution). See \code{\link[base]{all.equal}}} \item{filename}{character. Output filename (optional)} \item{overlap}{logical. If \code{FALSE} values of overlapping objects are based on the first layer, even if they are \code{NA}} \item{ext}{Extent object (optional) to limit the output to that extent} } \details{ The Raster objects must have the same origin and resolution. In areas where the Raster objects overlap, the values of the Raster object that is first in the sequence of arguments will be retained. If you would rather use the average of cell values, or do another computation, you can use \code{\link[raster]{mosaic}} instead of merge. } \value{ RasterLayer or RasterBrick } \examples{ r1 <- raster(xmx=-150, ymn=60, ncols=30, nrows=30) values(r1) <- 1:ncell(r1) r2 <- raster(xmn=-100, xmx=-50, ymx=50, ymn=30) res(r2) <- c(xres(r1), yres(r1)) values(r2) <- 1:ncell(r2) rm <- merge(r1, r2) # if you have many RasterLayer objects in a list # you can use do.call: x <- list(r1, r2) # add arguments such as filename # x$filename <- 'test.tif' m <- do.call(merge, x) } \keyword{methods} \keyword{spatial} raster/man/extend.Rd0000644000176200001440000000421314507510157014110 0ustar liggesusers\name{extend} \alias{extend} \alias{extend,Raster-method} \alias{extend,Extent-method} \title{Extend} \description{ Extend returns an Raster* object with a larger spatial extent. The output Raster object has the outer minimum and maximum coordinates of the input Raster and Extent arguments. Thus, all of the cells of the original raster are included. See \code{\link[raster]{crop}} if you (also) want to remove rows or columns. There is also an extend method for Extent objects to enlarge (or reduce) an Extent. You can also use algebraic notation to do that (see examples). This function has replaced function "expand" (to avoid a name conflict with the Matrix package). } \usage{ \S4method{extend}{Raster}(x, y, value=NA, snap="near", filename='', ...) \S4method{extend}{Extent}(x, y, ...) } \arguments{ \item{x}{Raster or Extent object} \item{y}{If \code{x} is a Raster object, \code{y} should be an Extent object, or any object that is or has an Extent object, or an object from which it can be extracted (such as sp objects). Alternatively, you can provide a numeric vector of length 2 indicating the number of rows and columns that need to be added (or a single number when the number of rows and columns is equal) If \code{x} is an Extent object, \code{y} should be a numeric vector of 1, 2, or 4 elements} \item{value}{value to assign to new cells} \item{snap}{Character. One of "near", "in", or "out", to determine in which direction the extent should be aligned. To the nearest border, inwards or outwards} \item{filename}{Character (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick, or Extent } \author{Robert J. Hijmans and Etienne B. Racine (Extent method)} \seealso{\code{\link[raster]{crop}}, \code{\link[raster]{merge}}} \examples{ r <- raster(xmn=-150, xmx=-120, ymx=60, ymn=30, ncol=36, nrow=18) values(r) <- 1:ncell(r) e <- extent(-180, 0, 0, 90) re <- extend(r, e) # extend with a number of rows and columns (at each side) re2 <- extend(r, c(2,10)) # Extent object e <- extent(r) e extend(e, 10) extend(e, 10, -10, 0, 20) e + 10 e * 2 } \keyword{spatial} raster/man/zvalues.Rd0000644000176200001440000000121214507510157014306 0ustar liggesusers\name{z-values} \alias{getZ} \alias{setZ} \title{Get or set z-values} \description{ Initial functions for a somewhat more formal approach to get or set z values (e.g. time) associated with layers of Raster* objects. In development. } \usage{ setZ(x, z, name='time') getZ(x) } \arguments{ \item{x}{Raster* object} \item{z}{vector of z values of any type (e.g. of class 'Date')} \item{name}{character label} } \value{ setZ: Raster* object getZ: vector } \examples{ r <- raster(ncol=10, nrow=10) s <- stack(lapply(1:3, function(x) setValues(r, runif(ncell(r))))) s <- setZ(s, as.Date('2000-1-1') + 0:2) s getZ(s) } \keyword{spatial} raster/man/sampleInt.Rd0000644000176200001440000000130414507510157014553 0ustar liggesusers\name{SampleInt} \alias{sampleInt} \title{Sample integer values} \description{ Take a random sample from a range of integer values between 1 and \code{n}. Its purpose is similar to that of \code{\link[base]{sample}}, but that function fails when \code{n} is very large. } \usage{ sampleInt(n, size, replace=FALSE) } \arguments{ \item{n}{Positive number (integer); the number of items to choose from } \item{size}{Non-negative integer; the number of items to choose} \item{replace}{Logical. Should sampling be with replacement?} } \value{vector of integer numbers} \examples{ sampleInt(1e+12, 10) # this may fail: # sample.int(1e+12, 10) # sample.int(1e+9, 10) } \keyword{spatial} raster/man/init.Rd0000644000176200001440000000351314507510157013566 0ustar liggesusers\name{initialize} \alias{init} \alias{init,Raster-method} \title{Initialize a Raster object with values} \description{ Create a new RasterLayer with values reflecting a cell property: 'x', 'y', 'col', 'row', or 'cell'. Alternatively, a function can be used. In that case, cell values are initialized without reference to pre-existing values. E.g., initialize with a random number (\code{fun=\link{runif}}). While there are more direct ways of achieving this for small objects (see examples) for which a vector with all values can be created in memory, the \code{init} function will also work for Raster* objects with many cells. } \usage{ \S4method{init}{Raster}(x, fun, filename="", ...) } \arguments{ \item{x}{Raster* object} \item{fun}{function to be applied. This must be a function that can take the number of cells as a single argument to return a vector of values with a length equal to the number of cells, such as \code{fun=runif}. You can also supply one of the following character values: 'x', 'y', 'row', 'col', or 'cell' to get the x or coordinate, row, col or cell number; you can also use 'chess', to get a chessboard pattern} \item{filename}{character. Optional output filename} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer } \note{ For backwards compatibility, the character values valid for \code{fun} can also be passed as named argument \code{v} } \examples{ r <- raster(ncols=36, nrows=18) x <- init(r, fun='cell') y <- init(r, fun=runif) # there are different ways to set all values to 1 # for large rasters: # set1f <- function(x){rep(1, x)} # z1 <- init(r, fun=set1f, filename=rasterTmpFile(), overwrite=TRUE) # This is equivalent to (but not memory safe): z2 <- setValues(r, rep(1, ncell(r))) # or values(r) <- rep(1, ncell(r)) # or values(r) <- 1 } \keyword{spatial} raster/man/as.matrix.Rd0000644000176200001440000000362614507510157014536 0ustar liggesusers\name{as.matrix} \alias{as.vector} \alias{as.matrix} \alias{as.array} \alias{as.array,RasterStackBrick-method} \alias{as.array,RasterLayer-method} \alias{as.matrix,RasterStackBrick-method} \alias{as.matrix,RasterLayer-method} \alias{as.matrix,Extent-method} \alias{as.vector,Extent-method} \alias{as.vector,Raster-method} \title{Get a vector, matrix, or array with raster cell values} \description{ \code{as.vector} returns a vector of cell values. For a RasterLayer it is equivalent to getValues(x). \code{as.matrix} returns all values of a Raster* object as a matrix. For RasterLayers, rows and columns in the matrix represent rows and columns in the RasterLayer object. For other Raster* objects, the matrix returned by \code{as.matrix} has columns for each layer and rows for each cell. \code{as.array} returns an array of matrices that are like those returned by \code{as.matrix} for a RasterLayer If there is insufficient memory to load all values, you can use \code{\link{getValues}} or \code{\link{getValuesBlock}} to read chunks of the file. \code{as.matrix} and \code{as.vector} can also be used to obtain the coordinates from an Extent object. } \usage{ as.matrix(x, ...) as.array(x, ...) \S4method{as.vector}{Extent}(x, mode='any') \S4method{as.vector}{Raster}(x, mode='any') } \arguments{ \item{x}{ Raster* or (for \code{as.matrix} and \code{as.vector}) Extent object } \item{mode}{Character string giving an atomic mode (such as "numeric" or "character") or "list", or "any". Note: this argument is currently ignored!} \item{...}{ additional arguments: \code{maxpixels} Integer. To regularly subsample very large objects \code{transpose} Logical. Transpose the data? (for as.array only) }} \value{ matrix, array, or vector } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- 1:ncell(r) as.matrix(r) s <- stack(r,r) as.array(s) as.vector(extent(s)) } \keyword{spatial} \keyword{methods} raster/man/clump.Rd0000644000176200001440000000263014507510157013742 0ustar liggesusers\name{clump} \alias{clump} \alias{clump,RasterLayer-method} \title{Detect clumps} \description{ Detect clumps (patches) of connected cells. Each clump gets a unique ID. NA and zero are used as background values (i.e. these values are used to separate clumps). You can use queen's or rook's case, using the \code{directions} argument. For larger files that are processed in chunks, the highest clump number is not necessarily equal to the number of clumps (unless you use argument \code{gaps=FALSE}). } \usage{ \S4method{clump}{RasterLayer}(x, filename="", directions=8, gaps=TRUE, ...) } \arguments{ \item{x}{RasterLayer} \item{filename}{Character. Filename for the output RasterLayer (optional)} \item{directions}{Integer. Which cells are considered adjacent? Should be 8 (Queen's case) or 4 (Rook's case) } \item{gaps}{Logical. If \code{TRUE} (the default), there may be 'gaps' in the chunk numbers (e.g. you may have clumps with IDs 1, 2, 3 and 5, but not 4). If it is \code{FALSE}, these numbers will be recoded from 1 to n (4 in this example)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \note{ This function requires that the igraph package is available. } \value{ RasterLayer } \author{Robert J. Hijmans and Jacob van Etten} \examples{ r <- raster(ncols=12, nrows=12) set.seed(0) values(r) <- round(runif(ncell(r))*0.7 ) rc <- clump(r) freq(rc) plot(rc) } \keyword{spatial} raster/man/text.Rd0000644000176200001440000000316614507510157013613 0ustar liggesusers\name{text} \docType{methods} \alias{text} \alias{text,RasterLayer-method} \alias{text,RasterStackBrick-method} \alias{text,SpatialPoints-method} \alias{text,SpatialPolygons-method} \title{Add labels to a map} \description{ Plots labels, that is a textual (rather than color) representation of values, on top an existing plot (map). } \usage{ \S4method{text}{RasterLayer}(x, labels, digits=0, fun=NULL, halo=FALSE, ...) \S4method{text}{RasterStackBrick}(x, labels, digits=0, fun=NULL, halo=FALSE, ...) \S4method{text}{SpatialPolygons}(x, labels, halo=FALSE, ...) \S4method{text}{SpatialPoints}(x, labels, halo=FALSE, ...) } \arguments{ \item{x}{Raster*, SpatialPoints* or SpatialPolygons* object} \item{labels}{character. Optional. Vector of labels with \code{length(x)} or a variable name from \code{names(x)}} \item{digits}{integer. how many digits should be used?} \item{fun}{function to subset the values plotted (as in \code{\link{rasterToPoints}})} \item{halo}{logical. If \code{TRUE} a 'halo' is printed around the text. If \code{TRUE}, additional arguments \code{hc='white'} and \code{hw=0.1} can be modified to set the colour and width of the halo} \item{...}{additional arguments to pass to graphics function \code{\link[graphics]{text}} } } \seealso{ \code{\link[graphics]{text}, \link[raster]{plot}} } \examples{ r <- raster(nrows=4, ncols=4) r <- setValues(r, 1:ncell(r)) plot(r) text(r) plot(r) text(r, halo=TRUE, hc='blue', col='white', hw=0.2) plot(r, col=bpy.colors(5)) text(r, fun=function(x){x<5 | x>12}, col=c('red', 'white'), vfont=c("sans serif", "bold"), cex=2) } \keyword{methods} \keyword{spatial} raster/man/animate.Rd0000644000176200001440000000216514507510157014243 0ustar liggesusers\name{animate} \docType{methods} \alias{animate} \alias{animate,RasterStackBrick-method} \title{Animate layers of a Raster* object} \description{ Animate (sequentially plot) the layers of a RasterStack or RasterBrick* object to create a movie } \usage{ \S4method{animate}{RasterStackBrick}(x, pause=0.25, main, zlim, maxpixels=50000, n=10, ...) } \arguments{ \item{x}{Raster* object} \item{pause}{numeric. How long should be the pause be between layers?} \item{main}{title for each layer. If not supplied the z-value is used if available. Otherwise the names are used.} \item{zlim}{numeric vector of lenght 2. Range of values to plot} \item{maxpixels}{integer > 0. Maximum number of cells to use for the plot. If \code{maxpixels < ncell(x)}, \code{sampleRegular} is used before plotting} \item{n}{integer > 0. Number of loops} \item{...}{Additional arguments passed to \code{\link{plot}}} } \value{ None } \seealso{ \code{\link{plot}}, \code{\link{spplot}}, \code{\link{plotRGB}} } \examples{ b <- brick(system.file("external/rlogo.grd", package="raster")) animate(b, n=1) } \keyword{methods} \keyword{spatial} raster/man/spEasy.Rd0000644000176200001440000000272514507510157014073 0ustar liggesusers\name{spEasy} \alias{spLines} \alias{spPolygons} \title{Create SpatialLines* or SpatialPolygons*} \description{ Helper functions to simplify the creation of SpatialLines* or SpatialPolygons* objects from coordinates. } \usage{ spLines(x, ..., attr=NULL, crs="") spPolygons(x, ..., attr=NULL, crs="") } \arguments{ \item{x}{matrix of list with matrices. Each matrix must have two columns with x and y coordinates (or longitude and latitude, in that order). Multi-line or multi-polygon objects can be formed by combining matrices in a list} \item{...}{additional matrices and/or lists with matrices} \item{attr}{data.frame with the attributes to create a *DataFrame object. The number of rows must match the number of lines/polgyons} \item{crs}{the coordinate reference system (PROJ4 or WKT notation)} } \value{ SpatialLines* or SpatialPolygons* } \examples{ x1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60)) x2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55)) x3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45)) x4 <- rbind(c(41,-41.5), c(51,-35), c(62,-41), c(51,-50)) a <- spLines(x1, x2, x3) b <- spLines(x1, list(x2, x3), attr=data.frame(id=1:2), crs='+proj=longlat +datum=WGS84') b hole <- rbind(c(-150,-20), c(-100,-10), c(-110,20), c(-130,10)) d <- spPolygons(list(x1,hole), x2, list(x3, x4)) att <- data.frame(ID=1:3, name=c('a', 'b', 'c')) e <- spPolygons(list(x1,hole), x2, list(x3, x4), attr=att, crs='+proj=longlat +datum=WGS84') e } \keyword{spatial} raster/man/rotated.Rd0000644000176200001440000000050314507510157014261 0ustar liggesusers\name{rotated} \alias{rotated} \title{Do the raster cells have a rotation?} \description{ Do the raster cells have a rotation? } \usage{ rotated(x) } \arguments{ \item{x}{A Raster* object} } \value{ Logical value } \seealso{ \code{\link{rectify}}} \examples{ r <- raster() rotated(r) } \keyword{spatial} raster/man/ncell.Rd0000644000176200001440000000163214507510157013720 0ustar liggesusers\name{ncell} \alias{ncol} \alias{nrow} \alias{nrow,BasicRaster-method} \alias{ncol,BasicRaster-method} \alias{ncell} \alias{ncell,ANY-method} \alias{ncell,BasicRaster-method} \alias{length,BasicRaster-method} \alias{nrow<-} \alias{ncol<-} \alias{nrow<-,BasicRaster,numeric-method} \alias{ncol<-,BasicRaster,numeric-method} \title{Number or rows, columns, and cells of a Raster* object} \description{ Get the number of rows, columns, or cells of a Raster* object. } \usage{ ncol(x) nrow(x) ncell(x) ncol(x, ...) <- value nrow(x, ...) <- value } \arguments{ \item{x}{a Raster object} \item{value}{row or column number (integer > 0)} \item{...}{additional arguments. None implemented} } \value{ Integer } \seealso{ \code{\link{dim}, \link{extent}}, \link{res} } \examples{ r <- raster() ncell(r) ncol(r) nrow(r) dim(r) nrow(r) <- 18 ncol(r) <- 36 # equivalent to dim(r) <- c(18, 36) } \keyword{spatial} raster/man/layerize.Rd0000644000176200001440000000321114507510157014442 0ustar liggesusers\name{layerize} \docType{methods} \alias{layerize} \alias{layerize,RasterLayer,missing-method} \alias{layerize,RasterLayer,RasterLayer-method} \title{Layerize} \description{ Create a RasterBrick with a Boolean layer for each class (value, or subset of the values) in a RasterLayer. For example, if the cell values of a RasterLayer indicate what vegetation type they are, this function will create a layer (presence/absence; dummy variable) for each of these classes. Classes and cell values are always truncated to integers. You can supply a second spatially overlapping RasterLayer with larger cells (do not use smaller cells!). In this case the cell values are counts for each class. A similar result might be obtained more efficiently by using layerize with a single RasterLayer followed by \code{\link{aggregate}(x, , sum)}. } \usage{ \S4method{layerize}{RasterLayer,missing}(x, classes=NULL, falseNA=FALSE, filename='', ...) \S4method{layerize}{RasterLayer,RasterLayer}(x, y, classes=NULL, filename='', ...) } \arguments{ \item{x}{RasterLayer} \item{y}{RasterLayer or missing} \item{classes}{numeric. The values (classes) for which layers should be made. If \code{NULL} all classes are used} \item{falseNA}{logical. If \code{TRUE}, cells that are not of the class represented by a layer are \code{NA} rather then \code{FALSE}} \item{filename}{character. Output filename (optional)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \value{ RasterBrick } \examples{ r <- raster(nrow=20, ncol=20) values(r) <- c(rep(NA, 50), rep(1:5, 70)) b <- layerize(r) r2 <- raster(nrow=5, ncol=5) b2 <- layerize(r, r2) } \keyword{spatial} raster/man/Rcpp-classes.Rd0000644000176200001440000000063414507510157015163 0ustar liggesusers\name{Rcpp-class} \docType{class} \alias{SpPoly} \alias{SpPolygons} \alias{SpPolyPart} \alias{SpExtent} \alias{SpPoly-class} \alias{SpPolyPart-class} \alias{SpPolygons-class} \alias{Rcpp_SpExtent-class} \alias{Rcpp_SpPolygons-class} \alias{Rcpp_SpPoly-class} \alias{Rcpp_SpPolyPart-class} \title{ Rcpp classes} \description{ These classes are for internal use only } \keyword{classes} \keyword{spatial} raster/man/cellFrom.Rd0000644000176200001440000000625014507510157014367 0ustar liggesusers\name{cellFrom} \alias{cellFromRowCol} \alias{cellFromRowCol,BasicRaster,numeric,numeric-method} \alias{colFromX} \alias{colFromX,BasicRaster,numeric-method} \alias{rowFromY} \alias{rowFromY,BasicRaster,numeric-method} \alias{cellFromXY} \alias{cellFromXY,BasicRaster,ANY-method} \alias{cellFromRow} \alias{cellFromCol} \alias{cellFromRowColCombine} \alias{cellFromRowColCombine,BasicRaster,numeric,numeric-method} \alias{fourCellsFromXY} \alias{cellFromLine} \alias{cellFromPolygon} \title{Get cell, row, or column number} \description{ Get cell number(s) of a Raster* object from row and/or column numbers. Cell numbers start at 1 in the upper left corner, and increase from left to right, and then from top to bottom. The last cell number equals the number of cells of the Raster* object. } \usage{ cellFromRowCol(object, row, col, ...) cellFromRowColCombine(object, row, col, ...) cellFromRow(object, rownr) cellFromCol(object, colnr) colFromX(object, x) rowFromY(object, y) cellFromXY(object, xy) cellFromLine(object, lns) cellFromPolygon(object, p, weights=FALSE) fourCellsFromXY(object, xy, duplicates=TRUE) } \arguments{ \item{object}{Raster* object (or a SpatialPixels* or SpatialGrid* object)} \item{colnr}{column number; or vector of column numbers} \item{rownr}{row number; or vector of row numbers} \item{col}{column number; or vector of column numbers} \item{row}{row number; or vector of row numbers} \item{x}{x coordinate(s)} \item{y}{y coordinate(s)} \item{xy}{matrix of x and y coordinates, or a SpatialPoints or SpatialPointsDataFrame object} \item{lns}{SpatialLines object} \item{p}{SpatialPolygons object} \item{weights}{Logical. If \code{TRUE}, the fraction of each cell that is covered is also returned} \item{duplicates}{Logical. If \code{TRUE}, the same cell number can be returned twice (if the point in the middle of a division between two cells) or four times (if a point is in the center of a cell)} \item{...}{additional arguments (none implemented)} } \details{ \code{cellFromRowCol} returns the cell numbers obtained for each row / col number pair. In contrast, \code{cellFromRowColCombine} returns the cell numbers obtained by the combination of all row and column numbers supplied as arguments. \code{fourCellsFromXY} returns the four cells that are nearest to a point (if the point falls on the raster). Also see \code{\link{adjacent}}. } \value{ vector of row, column or cell numbers. \code{cellFromLine} and \code{cellFromPolygon} return a list, \code{fourCellsFromXY} returns a matrix. } \seealso{ \code{\link{xyFromCell}, \link{cellsFromExtent}, \link{rowColFromCell}} } \examples{ r <- raster(ncols=10, nrows=10) cellFromRowCol(r, 5, 5) cellFromRowCol(r, 1:2, 1:2) cellFromRowColCombine(r, 1:3, 1:2) cellFromCol(r, 1) cellFromRow(r, 1) colFromX(r, 0.5) rowFromY(r, 0.5) cellFromXY(r, cbind(c(0.5,5), c(15, 88))) fourCellsFromXY(r, cbind(c(0.5,5), c(15, 88))) cds1 <- rbind(c(-180,-20), c(-160,5), c(-60, 0), c(-160,-60), c(-180,-20)) cds2 <- rbind(c(80,0), c(100,60), c(120,0), c(120,-55), c(80,0)) pols <- SpatialPolygons(list(Polygons(list(Polygon(cds1)), 1), Polygons(list(Polygon(cds2)), 2))) cellFromPolygon(r, pols) } \keyword{spatial} raster/man/metadata.Rd0000644000176200001440000000265414507510157014410 0ustar liggesusers\name{metadata} \alias{metadata} \alias{metadata,Raster-method} \alias{metadata<-} \title{ Metadata } \description{ Get or set a metadata to a Raster object } \usage{ \S4method{metadata}{Raster}(x) metadata(x) <- value } \arguments{ \item{x}{Raster* object } \item{value}{list with named elements. Each element may be another list of named elements (but these nested lists are not allowed to be lists themselves)} } \note{ The metadata can contain single values or vectors of basic data types (character, integer, numeric) and Date. Some other types may also be supported. You cannot use a matrix or data.frame as a meta-data element. } \value{ Raster* object or list } \examples{ r <- raster(nc=10, nr=10) values(r) <- 1:ncell(r) m <- list(wave=list(a=1, b=2, c=c('cool', 'important')), that=list(red='44', blue=1:5, days=as.Date(c('2014-1-15','2014-2-15'))), this='888 miles from here', today=NA) metadata(r) <- m \dontrun{ x <- writeRaster(r, rasterTmpFile(), overwrite=TRUE) metax <- metadata(x) identical(metax, m) # nested too deep badmeta1 <- list(wave=list(a=1, b=2, c='x'), that=list(red='4', blue=list(bad=5))) metadata(r) <- badmeta1 # missing names badmeta2 <- list(wave=list(1, 2, c='x'), that=list(red='44', blue=14), this='8m') metadata(r) <- badmeta2 # matrix not allowed badmeta3 <- list(wave=list(a=1, b=matrix(1:4, ncol=2), c='x'), that=list(red='4')) metadata(r) <- badmeta3 } } \keyword{ spatial } raster/man/getValuesFocal.Rd0000644000176200001440000000353514507510157015533 0ustar liggesusers \name{getValuesFocal} \alias{getValuesFocal} \alias{getValuesFocal,Raster-method} \alias{getValuesFocal,Raster,missing,missing,numeric-method} \alias{getValuesFocal,Raster,numeric,numeric,numeric-method} \title{Get focal raster cell values} \description{ This function returns a matrix (or matrices) for all focal values of a number of rows of a Raster* object} \usage{ \S4method{getValuesFocal}{Raster}(x, row, nrows, ngb, names=FALSE, padValue=NA, array=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{row}{Numeric. Row number, should be between 1 and nrow(x). Can be omitted to get all rows} \item{nrows}{Numeric. Number of rows, should be a positive integer smaller than \code{row+nrow(x)}. Should be omitted if \code{row} is omitted} \item{ngb}{Neighbourhood size. Either a single integer or a vector of two integers \code{c(nrow, ncol)}} \item{names}{logical. If \code{TRUE}, the matrix returned has row and column names} \item{padValue}{numeric. The value of the cells of the "padded" rows and columns. That is 'virtual' values for cells within a neighbourhood, but outside the raster} \item{array}{logical. If \code{TRUE} and \code{x} has multiple layers, an array is returned in stead of a list of matrices} \item{...}{additional arguments (none implemented)} } \value{ If \code{x} has a single layer, a matrix with one row for each focal cell, and one column for each neighbourhood cell around it. If \code{x} has multiple layers, an array (if \code{array=TRUE}) or a list of such matrices (one list element (matrix) for each layer) } \seealso{ \code{\link{getValues}, \link{focal}} } \examples{ r <- raster(nr=5, nc=5, crs='+proj=utm +zone=12') values(r) <- 1:25 as.matrix(r) getValuesFocal(r, row=1, nrows=2, ngb=3, names=TRUE) getValuesFocal(stack(r,r), row=1, nrows=1, ngb=3, names=TRUE, array=TRUE) } \keyword{spatial} \keyword{methods} raster/man/cv.Rd0000644000176200001440000000172114507510157013232 0ustar liggesusers\name{cv} \alias{cv} \alias{cv,ANY-method} \alias{cv,Raster-method} \title{Coefficient of variation} \description{ Compute the coefficient of variation (expressed as a percentage). If there is only a single value, \code{sd} is \code{NA} and \code{cv} returns \code{NA} if \code{aszero=FALSE} (the default). However, if (\code{aszero=TRUE}), \code{cv} returns \code{0}. } \usage{ \S4method{cv}{ANY}(x, ..., aszero=FALSE, na.rm = FALSE) \S4method{cv}{Raster}(x, ..., aszero=FALSE, na.rm = FALSE) } \arguments{ \item{x}{A vector of numbers (typically integers for modal), or a Raster* object} \item{...}{additional (vectors of) numbers, or Raster objects} \item{aszero}{logical. If \code{TRUE}, a zero is returned (rather than an NA) if the cv of single value is computed} \item{na.rm}{Remove (ignore) NA values} } \value{ vector or RasterLayer } \examples{ data <- c(0,1,2,3,3,3,3,4,4,4,5,5,6,7,7,8,9,NA) cv(data, na.rm=TRUE) } \keyword{univar} \keyword{math} raster/man/zApply.Rd0000644000176200001440000000200514507510157014075 0ustar liggesusers\name{zApply} \alias{zApply} \title{z (time) apply} \description{ Experimental function to apply a function over a (time) series of layers of a Raster object } \usage{ zApply(x, by, fun=mean, name='', ...) } \arguments{ \item{x}{Raster* object} \item{by}{aggregation indices or function } \item{fun}{function to compute aggregated values } \item{name}{character label of the new time series } \item{...}{additional arguments} } \value{ Raster* object } \author{Oscar Perpinan Lamigueiro & Robert J. Hijmans} \examples{ # 12 values of irradiation, 1 for each month G0dm=c(2.766,3.491,4.494,5.912,6.989,7.742,7.919,7.027,5.369,3.562,2.814,2.179)*1000; # RasterBrick with 12 layers based on G0dm + noise r <- raster(nc=10, nr=10) s <- brick(lapply(1:12, function(x) setValues(r, G0dm[x]+100*rnorm(ncell(r)) ))) # time tm <- seq(as.Date('2010-01-15'), as.Date('2010-12-15'), 'month') s <- setZ(s, tm, 'months') # library(zoo) # x <- zApply(s, by=as.yearqtr, fun=mean, name='quarters') } \keyword{spatial} raster/man/as.data.frame.Rd0000644000176200001440000000516014507510157015227 0ustar liggesusers\name{as.data.frame} \alias{as.data.frame} \alias{as.data.frame,Raster-method} \alias{as.data.frame,SpatialPolygons-method} \alias{as.data.frame,SpatialLines-method} \title{Get a data.frame with raster cell values, or coerce SpatialPolygons, Lines, or Points to a data.frame} \description{ \code{as.matrix} returns all values of a Raster* object as a matrix. For RasterLayers, rows and columns in the matrix represent rows and columns in the RasterLayer object. For other Raster* objects, the matrix returned by \code{as.matrix} has columns for each layer and rows for each cell. \code{as.array} returns an array of matrices that are like those returned by \code{as.matrix} for a RasterLayer If there is insufficient memory to load all values, you can use \code{\link{getValues}} or \code{\link{getValuesBlock}} to read chunks of the file. You could also first use \code{\link{sampleRegular}} The methods for Spatial* objects allow for easy creation of a data.frame with the coordinates and attributes; the default method only returns the attributes data.frame } \usage{ \S4method{as.data.frame}{Raster}(x, row.names=NULL, optional=FALSE, xy=FALSE, na.rm=FALSE, long=FALSE, ...) \S4method{as.data.frame}{SpatialPolygons}(x, row.names=NULL, optional=FALSE, xy=FALSE, centroids=TRUE, sepNA=FALSE, ...) \S4method{as.data.frame}{SpatialLines}(x, row.names=NULL, optional=FALSE, xy=FALSE, sepNA=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{row.names}{\code{NULL} or a character vector giving the row names for the data frame. Missing values are not allowed} \item{optional}{logical. If \code{TRUE}, setting row names and converting column names (to syntactic names: see make.names) is optional} \item{xy}{logical. If \code{TRUE}, also return the spatial coordinates} \item{na.rm}{logical. If \code{TRUE}, remove rows with NA values. This can be particularly useful for very large datasets with many NA values} \item{long}{logical. If \code{TRUE}, values are \code{\link{reshape}d} from a wide to a long format} \item{centroids}{logical. If \code{TRUE} return the centroids instead of all spatial coordinates (only relevant if \code{xy=TRUE})} \item{sepNA}{logical. If \code{TRUE} the parts of the spatial objects are separated by lines that are \code{NA} (only if \code{xy=TRUE} and, for polygons, if \code{centroids=FALSE}} \item{...}{Additional arguments (none)} } \value{ data.frame } \examples{ r <- raster(ncol=3, nrow=3) values(r) <- sqrt(1:ncell(r)) r[3:5] <- NA as.data.frame(r) s <- stack(r, r*2) as.data.frame(s) as.data.frame(s, na.rm=TRUE) } \keyword{spatial} \keyword{methods} raster/man/click.Rd0000644000176200001440000000463414507510157013715 0ustar liggesusers\name{click} \alias{click} \alias{click,Raster-method} \alias{click,SpatialGrid-method} \alias{click,SpatialPixels-method} \alias{click,missing-method} \alias{click,SpatialPolygons-method} \alias{click,SpatialLines-method} \alias{click,SpatialPoints-method} \title{Query by clicking on a map} \description{ Click on a map (plot) to get values of a Raster* or Spatial* object at that location; and optionally the coordinates and cell number of the location. For SpatialLines and SpatialPoints you need to click twice (draw a box). } \usage{ \S4method{click}{Raster}(x, n=Inf, id=FALSE, xy=FALSE, cell=FALSE, type="n", show=TRUE, ...) \S4method{click}{SpatialGrid}(x, n=1, id=FALSE, xy=FALSE, cell=FALSE, type="n", ...) \S4method{click}{SpatialPolygons}(x, n=1, id=FALSE, xy=FALSE, type="n", ...) \S4method{click}{SpatialLines}(x, ...) \S4method{click}{SpatialPoints}(x, ...) } \arguments{ \item{x}{Raster*, or Spatial* object (or missing)} \item{n}{number of clicks on the map} \item{id}{Logical. If \code{TRUE}, a numeric ID is shown on the map that corresponds to the row number of the output} \item{xy}{Logical. If \code{TRUE}, xy coordinates are included in the output} \item{cell}{Logical. If \code{TRUE}, cell numbers are included in the output} \item{type}{One of "n", "p", "l" or "o". If "p" or "o" the points are plotted; if "l" or "o" they are joined by lines. See ?locator} \item{show}{logical. Print the values after each click?} \item{...}{additional graphics parameters used if type != "n" for plotting the locations. See ?locator} } \value{ The value(s) of \code{x} at the point(s) clicked on (or touched by the box drawn). } \note{ The plot only provides the coordinates for a spatial query, the values are read from the Raster* or Spatial* object that is passed as an argument. Thus you can extract values from an object that has not been plotted, as long as it spatialy overlaps with with the extent of the plot. Unless the process is terminated prematurely values at at most \code{n} positions are determined. The identification process can be terminated by clicking the second mouse button and selecting 'Stop' from the menu, or from the 'Stop' menu on the graphics window. } \seealso{ \code{\link{select}, \link[raster]{drawExtent}} } \examples{ \dontrun{ r <- raster(system.file("external/test.grd", package="raster")) plot(r) click(r) # now click on the plot (map) }} \keyword{ spatial } raster/man/intersect.Rd0000644000176200001440000000526614507510157014632 0ustar liggesusers\name{intersect} \docType{methods} \alias{intersect} \alias{intersect,Extent,ANY-method} \alias{intersect,Raster,ANY-method} \alias{intersect,SpatialPoints,ANY-method} \alias{intersect,SpatialPolygons,SpatialPolygons-method} \alias{intersect,SpatialPolygons,SpatialLines-method} \alias{intersect,SpatialPolygons,SpatialPoints-method} \alias{intersect,SpatialPolygons,ANY-method} \alias{intersect,SpatialLines,SpatialPolygons-method} \alias{intersect,SpatialLines,SpatialLines-method} \title{ Intersect } \description{ It depends on the classes of the \code{x} and \code{y} what is returned. If \code{x} is a Raster* object the extent of \code{y} is used, irrespective of the class of \code{y}, and a Raster* is returned. This is equivalent to \code{\link{crop}}. If \code{x} is a Spatial* object, a new Spatial* object is returned. If \code{x} or \code{y} has a data.frame, these are also returned (after merging if necessary) as part of a Spatial*DataFrame. 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. } \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 p <- shapefile(system.file("external/lux.shp", package="raster")) b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') projection(b) <- projection(p) i <- intersect(p, b) plot(p) plot(b, add=TRUE, col='red') plot(i, add=TRUE, col='blue', lwd=2) } \keyword{methods} \keyword{spatial} raster/man/area.Rd0000644000176200001440000000442014507510157013531 0ustar liggesusers\name{area} \alias{area} \alias{area,RasterLayer-method} \alias{area,RasterStackBrick-method} \alias{area,SpatialPolygons-method} \title{Size of cells} \description{ Raster objects: Compute the approximate surface area of cells in an unprojected (longitude/latitude) Raster object. It is an approximation because area is computed as the height (latitudinal span) of a cell (which is constant among all cells) times the width (longitudinal span) in the (latitudinal) middle of a cell. The width is smaller at the poleward side than at the equator-ward side of a cell. This variation is greatest near the poles and the values are thus not very precise for very high latitudes. SpatialPolygons: Compute the area of the spatial features. Works for both planar and angular (lon/lat) coordinate reference systems } \usage{ \S4method{area}{RasterLayer}(x, filename="", na.rm=FALSE, weights=FALSE, ...) \S4method{area}{RasterStackBrick}(x, filename="", na.rm=FALSE, weights=FALSE, ...) \S4method{area}{SpatialPolygons}(x, ...) } \arguments{ \item{x}{Raster* or SpatialPolygons object} \item{filename}{character. Filename for the output Raster object (optional)} \item{na.rm}{logical. If \code{TRUE}, cells that are \code{NA} are ignored} \item{weights}{logical. If \code{TRUE}, the area of each cells is divided by the total area of all cells that are not \code{NA}} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \details{ If \code{x} is a RasterStack/Brick, a RasterBrick will be returned if \code{na.rm=TRUE}. However, if \code{na.rm=FALSE}, a RasterLayer is returned, because the values would be the same for all layers. } \value{ If \code{x} is a Raster* object: RasterLayer or RasterBrick. Cell values represent the size of the cell in km2, or the relative size if \code{weights=TRUE}. If the CRS is not longitude/latitude the values returned are the product of the cell resolution (typically in square meter). If \code{x} is a SpatialPolygons* object: area of each spatial object in squared meters if the CRS is longitude/latitude, or in squared map units (typically meter) } \examples{ r <- raster(nrow=18, ncol=36) a <- area(r) p <- shapefile(system.file("external/lux.shp", package="raster")) p$area <- round(area(p) / 10000000,1) p$area } \keyword{methods} \keyword{spatial} raster/man/sampleRandom.Rd0000644000176200001440000000326314507510157015247 0ustar liggesusers\name{sampleRandom} \alias{sampleRandom} \alias{sampleRandom,Raster-method} \title{Random sample} \description{ Take a random sample from the cell values of a Raster* object (without replacement). } \usage{ \S4method{sampleRandom}{Raster}(x, size, na.rm=TRUE, ext=NULL, cells=FALSE, rowcol=FALSE, xy=FALSE, sp=FALSE, asRaster=FALSE, ...) } \arguments{ \item{x}{Raster* object} \item{size}{positive integer giving the number of items to choose} \item{na.rm}{logical. If \code{TRUE} (the default), \code{NA} values are removed from random sample} \item{ext}{Extent object. To limit regular sampling to the area within the extent} \item{cells}{logical. If \code{TRUE}, sampled cell numbers are also returned} \item{rowcol}{logical. If \code{TRUE}, sampled row and column numbers are also returned} \item{xy}{logical. If \code{TRUE}, coordinates of sampled cells are also returned} \item{sp}{logical. If \code{TRUE}, a SpatialPointsDataFrame is returned} \item{asRaster}{logical. If \code{TRUE}, a Raster* object is returned with random cells with values, all other cells with \code{NA}} \item{...}{Additional arguments as in \code{\link{writeRaster}}. Only relevant when \code{asRaster=TRUE}} } \details{ With argument \code{na.rm=TRUE}, the returned sample may be smaller than requested } \value{ A vector, matrix (if \code{cells=TRUE} or \code{x} is a multi-layered object), or a SpatialPointsDataFrame (if \code{sp=TRUE} ) } \seealso{\code{\link{sampleRegular}, \link{sampleStratified}}} \examples{ r <- raster(system.file("external/test.grd", package="raster")) sampleRandom(r, size=10) s <- stack(r, r) sampleRandom(s, size=5, cells=TRUE, sp=TRUE) } \keyword{spatial} raster/man/crop.Rd0000644000176200001440000000457614507510157013600 0ustar liggesusers\name{crop} \alias{crop} \alias{crop,Raster-method} \alias{crop,Spatial-method} \alias{crop,Raster,ANY-method} \alias{crop,Spatial,ANY-method} \title{Crop} \description{ crop returns a geographic subset of an object as specified by an Extent object (or object from which an extent object can be extracted/created). If \code{x} is a Raster* object, the Extent is aligned to \code{x}. Areas included in \code{y} but outside the extent of \code{x} are ignored (see \code{\link{extend}} if you want a larger area). } \usage{ \S4method{crop}{Raster}(x, y, filename="", snap='near', datatype=NULL, ...) \S4method{crop}{Spatial}(x, y, ...) } \arguments{ \item{x}{Raster* object or SpatialPolygons*, SpatialLines*, or SpatialPoints* object} \item{y}{Extent object, or any object from which an Extent object can be extracted (see Details)} \item{filename}{Character, output filename. Optional} \item{snap}{Character. One of 'near', 'in', or 'out', for use with \code{\link{alignExtent}}} \item{datatype}{Character. Output \code{\link{dataType}} (by default it is the same as the input datatype)} \item{...}{Additional arguments as for \code{\link{writeRaster}}} } \note{values within the extent of a Raster* object can be set to NA with \link[raster]{mask}} \details{ Objects from which an Extent can be extracted/created include RasterLayer, RasterStack, RasterBrick and objects of the Spatial* classes from the sp package. You can check this with the \code{\link[raster]{extent}} function. New Extent objects can also be created with function \code{\link{extent}} and \code{\link{drawExtent}} by clicking twice on a plot. To crop by row and column numbers you can create an extent like this (for Raster \code{x}, row 5 to 10, column 7 to 12) \code{crop(x, extent(x, 5, 10, 7, 12))} } \value{ RasterLayer or RasterBrick object; or SpatialLines or SpatialPolygons object. } \seealso{ \code{\link[raster]{extend}}, \code{\link[raster]{merge}} } \examples{ r <- raster(nrow=45, ncol=90) values(r) <- 1:ncell(r) e <- extent(-160, 10, 30, 60) rc <- crop(r, e) # use row and column numbers: rc2 <- crop(r, extent(r, 5, 10, 7, 15)) # crop Raster* with Spatial* object b <- as(extent(6, 6.4, 49.75, 50), 'SpatialPolygons') crs(b) <- crs(r) rb <- crop(r, b) # crop a SpatialPolygon* object with another one p <- shapefile(system.file("external/lux.shp", package="raster")) pb <- crop(p, b) } \keyword{spatial} raster/man/flip.Rd0000644000176200001440000000174014507510157013555 0ustar liggesusers\name{flip} \docType{methods} \alias{flip} \alias{flip,RasterLayer-method} \alias{flip,RasterStackBrick-method} \title{Flip} \description{ Flip the values of a Raster* object by inverting the order of the rows (direction=y) or the columns direction='x'. } \usage{ \S4method{flip}{RasterLayer}(x, direction='y', filename='', ...) \S4method{flip}{RasterStackBrick}(x, direction='y', filename='', ...) } \arguments{ \item{x}{Raster* object} \item{direction}{Character. 'y' or 'x'; or 1 (=x) or 2 (=y)} \item{filename}{character. Output filename (optional)} \item{...}{if \code{x} is a Raster* object, additional arguments as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick } \seealso{ transpose: \code{\link{t}}, \code{\link[raster]{rotate}} } \examples{ r <- raster(nrow=18, ncol=36) m <- matrix(1:ncell(r), nrow=18) values(r) <- as.vector(t(m)) rx <- flip(r, direction='x') values(r) <- as.vector(m) ry <- flip(r, direction='y') } \keyword{spatial} raster/man/writeRaster.Rd0000644000176200001440000001252714511777041015145 0ustar liggesusers\name{writeRaster} \alias{writeRaster,RasterLayer,character-method} \alias{writeRaster,RasterStackBrick,character-method} \alias{writeRaster} \title{Write raster data to a file} \description{ Write an entire Raster* object to a file, using one of the many supported formats. See \code{\link[raster]{writeValues}} for writing in chunks (e.g. by row). When writing a file to disk, the file format is determined by the 'format=' argument if supplied, or else by the file extension (if the extension is known). If other cases the default format is used. The default format is 'raster', but this setting can be changed (see \code{\link{rasterOptions}}). } \usage{ \S4method{writeRaster}{RasterLayer,character}(x, filename, format, ...) \S4method{writeRaster}{RasterStackBrick,character}(x, filename, format, bylayer, suffix='numbers', ...) } \arguments{ \item{x}{Raster* object} \item{filename}{Output filename} \item{format}{Character. Output file type. See \code{\link[raster]{writeFormats}}. If this argument is not provided, it is attempted to infer it from the filename extension. If that fails, the default format is used. The default format is 'raster', but this can be changed using \code{\link{rasterOptions}}} \item{...}{Additional arguments: \code{datatype}: Character. Output data type (e.g. 'INT2S' or 'FLT4S'). See \code{\link{dataType}}. If no datatype is specified, 'FLT4S' is used, unless this default value was changed with \code{\link{rasterOptions}} \code{overwrite}: Logical. If TRUE, "filename" will be overwritten if it exists \code{progress}: Character. Set a value to show a progress bar. Valid values are "text" and "window". \code{NAflag}: Numeric. To overwrite the default value used to represent \code{NA} in a file \code{bandorder}: Character. 'BIL', 'BIP', or 'BSQ'. For 'native' file formats only. For some other formats you can use the 'options' argument (see below) \code{options}: Character. File format specific GDAL options. E.g., when writing a geotiff file you can use: \code{options=c("COMPRESS=NONE", "TFW=YES")} You can use options=c("PROFILE=BASELINE") to create a plain tif with no GeoTIFF tags. This can be useful when writing files to be read by applications intolerant of unrecognised tags. NetCDF files have the following additional, optional, arguments: \code{varname}, \code{varunit}, \code{longname}, \code{xname}, \code{yname}, \code{zname}, \code{zunit} \code{prj}: Logical. If \code{TRUE}, the crs is written to a .prj file. This can be useful when writing to an ascii file or another file type that does not store the crs \code{setStatistics}: logical. If \code{TRUE} (the default) the min and max cell values are written to file (if the format permits it) } \item{bylayer}{if \code{TRUE}, write a separate file for each layer. You can provide a vector of filenames that matches the number of layers. Or you can provide a single filename that will get a unique suffix (see below)} \item{suffix}{'numbers' or 'names' to determine the suffix that each file gets when \code{bylayer=TRUE}; either a number between \code{1} and \code{nlayers(x)} or \code{names(x)}} } \details{ See \code{writeFormats} for supported file types ("formats", "drivers"). 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 \tab .tif \tab Yes \cr \tab \code{ENVI} \tab ENVI .hdr Labelled \tab .envi \tab Yes \cr \tab \code{EHdr} \tab ESRI .hdr Labelled \tab .bil \tab Yes \cr \tab \code{HFA} \tab Erdas Imagine Images (.img) \tab .img \tab Yes \cr } } \value{ This function is used for the side-effect of writing values to a file. } \seealso{\code{\link[raster]{writeFormats}}, \code{\link[raster]{writeValues}} } \examples{ tmp <- tempdir() r <- raster(system.file("external/test.grd", package="raster")) # take a small part r <- crop(r, extent(179880, 180800, 329880, 330840) ) # write to an integer binary file rf <- writeRaster(r, filename=file.path(tmp, "allint.grd"), datatype='INT4S', overwrite=TRUE) # make a brick and save multi-layer file b <- brick(r, sqrt(r)) bf <- writeRaster(b, filename=file.path(tmp, "multi.grd"), bandorder='BIL', overwrite=TRUE) # write to a new geotiff file rf <- writeRaster(r, filename=file.path(tmp, "test.tif"), format="GTiff", overwrite=TRUE) bf <- writeRaster(b, filename=file.path(tmp, "multi.tif"), options="INTERLEAVE=BAND", overwrite=TRUE) # write to netcdf if (require(ncdf4)) { rnc <- writeRaster(r, filename=file.path(tmp, "netCDF.nc"), format="CDF", overwrite=TRUE) } } \keyword{ spatial } \keyword{ methods } raster/man/rasterize.Rd0000644000176200001440000001735414511776566014660 0ustar liggesusers\name{rasterize} \docType{methods} \alias{rasterize} \alias{rasterize,matrix,Raster-method} \alias{rasterize,data.frame,Raster-method} \alias{rasterize,sf,Raster-method} \alias{rasterize,SpatialPoints,Raster-method} \alias{rasterize,SpatialLines,Raster-method} \alias{rasterize,SpatialPolygons,Raster-method} \alias{rasterize,Extent,Raster-method} \title{Rasterize points, lines, or polygons} \description{ Transfer values associated with 'object' type spatial data (points, lines, polygons) to raster cells. For polygons, values are transferred if the polygon covers the center of a raster cell. For lines, values are transferred to all cells that are touched by a line. You can combine this behaviour by rasterizing polygons as lines first and then as polygons. If \code{x} represents points, each point is assigned to a grid cell. Points that fall on a border between cells are placed in the cell to the right and/or in the cell below. The value of a grid cell is determined by the values associated with the points and function \code{fun}. } \usage{ \S4method{rasterize}{matrix,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...) \S4method{rasterize}{SpatialPoints,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", na.rm=TRUE, ...) \S4method{rasterize}{SpatialLines,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", ...) \S4method{rasterize}{SpatialPolygons,Raster}(x, y, field, fun='last', background=NA, mask=FALSE, update=FALSE, updateValue='all', filename="", getCover=FALSE, silent=TRUE, ...) } \arguments{ \item{x}{points (a SpatialPoints* object, or a two-column matrix (or data.frame)), SpatialLines*, SpatialPolygons*, or an Extent object } \item{y}{Raster* object} \item{field}{numeric or character. The value(s) to be transferred. This can be a single number, or a vector of numbers that has the same length as the number of spatial features (points, lines, polygons). If \code{x} is a Spatial*DataFrame, this can be the column name of the variable to be transferred. If missing, the attribute index is used (i.e. numbers from 1 to the number of features). You can also provide a vector with the same length as the number of spatial features, or a matrix where the number of rows matches the number of spatial features} \item{fun}{function or character. To determine what values to assign to cells that are covered by multiple spatial features. You can use functions such as \code{min, max}, or \code{mean}, or one of the following character values: \code{'first'}, \code{'last'}, \code{'count'}. The default value is \code{'last'}. In the case of SpatialLines*, \code{'length'} is also allowed (currently for planar coordinate systems only). If \code{x} represents points, \code{fun} must accept a \code{na.rm} argument, either explicitly or through the ellipses ('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: \code{fun=function(x, na.rm){if (na.rm) length(na.omit(x)) else (length(x)}}, or use a function that removes \code{NA} values in all cases, like this function to compute the number of unique values per grid cell "richness": \code{fun=function(x, ...) {length(unique(na.omit(x)))} }. If you want to count the number of points in each grid cell, you can use \code{ fun='count'} or \code{fun=function(x,...){length(x)}}. You can also pass multiple functions using a statement like \code{fun=function(x, ...) c(length(x),mean(x))}, in which case the returned object is a RasterBrick (multiple layers). } \item{background}{numeric. Value to put in the cells that are not covered by any of the features of \code{x}. Default is \code{NA}} \item{mask}{logical. If \code{TRUE} the values of the input Raster object are 'masked' by the spatial features of \code{x}. That is, cells that spatially overlap with the spatial features retain their values, the other cells become \code{NA}. Default is \code{FALSE}. This option cannot be used when \code{update=TRUE}} \item{update}{logical. If \code{TRUE}, the values of the Raster* object are updated for the cells that overlap the spatial features of \code{x}. Default is \code{FALSE}. Cannot be used when \code{mask=TRUE}} \item{updateValue}{numeric (normally an integer), or character. Only relevant when \code{update=TRUE}. Select, by their values, the cells to be updated with the values of the spatial features. Valid character values are \code{'all'}, \code{'NA'}, and \code{'!NA'}. Default is \code{'all'}} \item{filename}{character. Output filename (optional)} \item{na.rm}{If \code{TRUE}, \code{NA} values are removed if \code{fun} honors the \code{na.rm} argument} \item{getCover}{logical. If \code{TRUE}, the fraction of each grid cell that is covered by the polygons is returned (and the values of \code{field, fun, mask}, and \code{update} are ignored. The fraction covered is estimated by dividing each cell into 100 subcells and determining presence/absence of the polygon in the center of each subcell} \item{silent}{Logical. If \code{TRUE}, feedback on the polygon count is suppressed. Default is \code{FALSE}} \item{...}{Additional arguments for file writing as for \code{\link{writeRaster}}} } \value{ RasterLayer or RasterBrick } \seealso{ \code{\link{extract}} } \examples{ ############################### # rasterize points ############################### r <- raster(ncols=36, nrows=18) n <- 1000 set.seed(123) x <- runif(n) * 360 - 180 y <- runif(n) * 180 - 90 xy <- cbind(x, y) # get the (last) indices r0 <- rasterize(xy, r) # presence/absensce (NA) (is there a point or not?) r1 <- rasterize(xy, r, field=1) # how many points? r2 <- rasterize(xy, r, fun=function(x,...)length(x)) vals <- runif(n) # sum of the values associated with the points r3 <- rasterize(xy, r, vals, fun=sum) # with a SpatialPointsDataFrame vals <- 1:n p <- data.frame(xy, name=vals) coordinates(p) <- ~x+y r <- rasterize(p, r, 'name', fun=min) #r2 <- rasterize(p, r, 'name', fun=max) #plot(r, r2, cex=0.5) ############################### # rasterize lines ############################### cds1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60)) cds2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55)) cds3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45)) lines <- spLines(cds1, cds2, cds3) r <- raster(ncols=90, nrows=45) r <- rasterize(lines, r) \dontrun{ plot(r) plot(lines, add=TRUE) r <- rasterize(lines, r, fun='count') plot(r) values(r) <- 1:ncell(r) r <- rasterize(lines, r, mask=TRUE) plot(r) values(r) <- 1 r[lines] <- 10 plot(r) } ############################### # rasterize polygons ############################### p1 <- rbind(c(-180,-20), c(-140,55), c(10, 0), c(-140,-60), c(-180,-20)) hole <- rbind(c(-150,-20), c(-100,-10), c(-110,20), c(-150,-20)) p1 <- list(p1, hole) p2 <- rbind(c(-10,0), c(140,60), c(160,0), c(140,-55), c(-10,0)) p3 <- rbind(c(-125,0), c(0,60), c(40,5), c(15,-45), c(-125,0)) pols <- spPolygons(p1, p2, p3) r <- raster(ncol=90, nrow=45) r <- rasterize(pols, r, fun=sum) \dontrun{ plot(r) plot(pols, add=T) # add a polygon p5 <- rbind(c(-180,10), c(0,90), c(40,90), c(145,-10), c(-25, -15), c(-180,0), c(-180,10)) addpoly <- SpatialPolygons(list(Polygons(list(Polygon(p5)), 1))) addpoly <- as(addpoly, "SpatialPolygonsDataFrame") addpoly@data[1,1] <- 10 r2 <- rasterize(addpoly, r, field=1, update=TRUE, updateValue="NA") plot(r2) plot(pols, border="blue", lwd=2, add=TRUE) plot(addpoly, add=TRUE, border="red", lwd=2) # get the percentage cover of polygons in a cell r3 <- raster(ncol=36, nrow=18) r3 <- rasterize(pols, r3, getCover=TRUE) } } \keyword{methods} \keyword{spatial} raster/man/gridDistance.Rd0000644000176200001440000000361514507510157015226 0ustar liggesusers\name{gridDistance} \alias{gridDistance} \alias{gridDistance,RasterLayer-method} \title{Distance on a grid} \description{ The function calculates the distance to cells of a RasterLayer when the path has to go through the centers of neighboring raster cells (currently only implemented as a 'queen' case in which cells have 8 neighbors). The distance is in meters if the coordinate reference system (CRS) of the RasterLayer is longitude/latitude (\code{+proj=longlat}) and in the units of the CRS (typically meters) in other cases. Distances are computed by summing local distances between cells, which are connected with their neighbours in 8 directions. } \usage{ \S4method{gridDistance}{RasterLayer}(x, origin, omit=NULL, filename="", ...) } \arguments{ \item{x}{RasterLayer} \item{origin}{value(s) of the cells from which the distance is calculated} \item{omit}{value(s) of the cells which cannot be traversed (optional)} \item{filename}{character. output filename (optional)} \item{...}{additional arguments as for \code{\link{writeRaster}}} } \seealso{See \code{\link[raster]{distance}} for 'as the crow flies' distance. Additional distance measures and options (directions, cost-distance) are available in the '\code{gdistance}' package.} \details{ If the RasterLayer to be processed is big, it will be processed in chunks. This may lead to errors in the case of complex objects spread over different chunks (meandering rivers, for instance). You can try to solve these issues by varying the chunk size, see function setOptions(). } \value{RasterLayer} \author{Jacob van Etten and Robert J. Hijmans } \examples{ #world lon/lat raster r <- raster(ncol=10,nrow=10, vals=1) r[48] <- 2 r[66:68] <- 3 d <- gridDistance(r,origin=2,omit=3) plot(d) #UTM small area crs(r) <- "+proj=utm +zone=15 +ellps=GRS80 +datum=NAD83 +units=m +no_defs" d <- gridDistance(r,origin=2,omit=3) plot(d) } \keyword{spatial} raster/man/addLayer.Rd0000644000176200001440000000166214507510157014353 0ustar liggesusers\name{addLayer} \alias{addLayer} \alias{addLayer,Raster-method} \alias{dropLayer} \alias{dropLayer,RasterStack-method} \alias{dropLayer,RasterBrick-method} \title{Add or drop a layer} \description{ Add a layer to a Raster* object or drop a layer from a RasterStack or RasterBrick. The object returned is always a RasterStack (unless nothing to add or drop was provided, in which case the original object is returned). } \usage{ addLayer(x, ...) dropLayer(x, i, ...) } \arguments{ \item{x}{Raster* object} \item{i}{integer. Indices of the layers to be dropped} \item{...}{Additional arguments. The layers to add for addLayer. None implemented for dropLayer)} } \value{ RasterStack } \seealso{ \code{\link[raster]{subset}}} \examples{ file <- system.file("external/test.grd", package="raster") s <- stack(file, file, file) r <- raster(file) s <- addLayer(s, r/2, r*2) s s <- dropLayer(s, c(3, 5)) nlayers(s) } \keyword{ spatial } raster/DESCRIPTION0000644000176200001440000000603014742252332013263 0ustar liggesusersPackage: raster Type: Package Title: Geographic Data Analysis and Modeling Version: 3.6-31 Date: 2025-01-16 Imports: Rcpp, methods, terra (>= 1.8-5) LinkingTo: Rcpp Depends: sp (>= 1.4-5), R (>= 3.5.0) Suggests: ncdf4, igraph, tcltk, parallel, rasterVis, MASS, sf, tinytest, gstat, fields, exactextractr Description: Reading, writing, manipulating, analyzing and modeling of spatial data. This package has been superseded by the "terra" package . License: GPL (>= 3) URL: https://rspatial.org/raster BugReports: https://github.com/rspatial/raster/issues/ Authors@R: c( person("Robert J.", "Hijmans", role = c("cre", "aut"), email = "r.hijmans@gmail.com", comment = c(ORCID = "0000-0001-5872-2872")), person("Jacob", "van Etten", role = "ctb"), person("Michael", "Sumner", role = "ctb"), person("Joe", "Cheng", role = "ctb"), person("Dan", "Baston", role = "ctb"), person("Andrew", "Bevan", role = "ctb"), person("Roger", "Bivand", role = "ctb"), person("Lorenzo", "Busetto", role = "ctb"), person("Mort", "Canty", role = "ctb"), person("Ben", "Fasoli", role = "ctb"), person("David", "Forrest", role = "ctb"), person("Aniruddha", "Ghosh", role = "ctb"), person("Duncan", "Golicher", role = "ctb"), person("Josh", "Gray", role = "ctb"), person("Jonathan A.", "Greenberg", role = "ctb"), person("Paul", "Hiemstra", role = "ctb"), person("Kassel", "Hingee", role = "ctb"), person("Alex", "Ilich", role = "ctb"), person("Institute for Mathematics Applied Geosciences", role="cph"), person("Charles", "Karney", role = "ctb"), person("Matteo", "Mattiuzzi", role = "ctb"), person("Steven", "Mosher", role = "ctb"), person("Babak", "Naimi", role = "ctb"), person("Jakub", "Nowosad", role = "ctb"), person("Edzer", "Pebesma", role = "ctb"), person("Oscar", "Perpinan Lamigueiro", role = "ctb"), person("Etienne B.", "Racine", role = "ctb"), person("Barry", "Rowlingson", role = "ctb"), person("Ashton", "Shortridge", role = "ctb"), person("Bill", "Venables", role = "ctb"), person("Rafael", "Wueest", role = "ctb") ) NeedsCompilation: yes Packaged: 2025-01-16 16:16:21 UTC; rhijm Author: Robert J. Hijmans [cre, aut] (), Jacob van Etten [ctb], Michael Sumner [ctb], Joe Cheng [ctb], Dan Baston [ctb], Andrew Bevan [ctb], Roger Bivand [ctb], Lorenzo Busetto [ctb], Mort Canty [ctb], Ben Fasoli [ctb], David Forrest [ctb], Aniruddha Ghosh [ctb], Duncan Golicher [ctb], Josh Gray [ctb], Jonathan A. Greenberg [ctb], Paul Hiemstra [ctb], Kassel Hingee [ctb], Alex Ilich [ctb], Institute for Mathematics Applied Geosciences [cph], Charles Karney [ctb], Matteo Mattiuzzi [ctb], Steven Mosher [ctb], Babak Naimi [ctb], Jakub Nowosad [ctb], Edzer Pebesma [ctb], Oscar Perpinan Lamigueiro [ctb], Etienne B. Racine [ctb], Barry Rowlingson [ctb], Ashton Shortridge [ctb], Bill Venables [ctb], Rafael Wueest [ctb] Maintainer: Robert J. Hijmans Repository: CRAN Date/Publication: 2025-01-16 18:50:02 UTC