-
Notifications
You must be signed in to change notification settings - Fork 1
/
gis.R
121 lines (116 loc) · 3.71 KB
/
gis.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#' Create a `.prj` file
#'
#' In cases where a shapefile is missing its associated `.prj` file.
#'
#' @param shpFile The filename of a shapefile to add `.prj`
#' @param urlForProj The url from which to fetch the projection, e.g.,
#' `"http://spatialreference.org/ref/epsg/nad83-utm-zone-11n/prj/"`.
#'
#' @export
#' @importFrom tools file_path_sans_ext
#' @importFrom utils download.file
createPrjFile <- function(shpFile,
urlForProj = "http://spatialreference.org/ref/epsg/nad83-utm-zone-11n/prj/") { #nolint
basenameWithoutExt <- file_path_sans_ext(shpFile)
basenameWithoutExt <- basenameWithoutExt[-length(basenameWithoutExt)]
prjFile <- paste0(basenameWithoutExt, ".prj")
if (!file.exists(prjFile)) {
download.file(urlForProj, destfile = prjFile)
}
}
#' Faster version of [raster::factorValues()]
#'
#' Note there is an option to remove the NAs, which will make it MUCH faster,
#' if `TRUE`
#'
#' @inheritParams raster::factorValues
#'
#' @param na.rm Logical. If `TRUE`, then the NAs will be removed, returning a possibly
#' shorter vector
#' @export
#' @importFrom raster levels
#' @importFrom stats na.omit
factorValues2 <- function(x, v, layer, att, append.names, na.rm = FALSE) {
if (is(x, "SpatRaster")) {
if (!requireNamespace("terra", quietly = TRUE)) stop("please install.packages('terra')")
levs <- terra::cats(x)[[1]]
idCol <- "id"
} else {
levs <- raster::levels(x)[[1]]
idCol <- "ID"
}
if (isTRUE(na.rm))
v <- na.omit(v)
a <- match(v, levs[[idCol]])
return(levs[[att]][a])
}
#' Extract or create a raster to match
#'
#' This extracts or creates a new raster layer, whose intention is to be used as
#' the `rasterToMatch` argument in further `prepInputs` calls.
#'
#' @param x A Raster Layer with correct resolution and origin.
#' @param ... Additional arguments
#'
#' @return A `RasterLayer` object.
#'
#' @export
#' @exportMethod rasterToMatch
#' @rdname rasterToMatch
setGeneric(
"rasterToMatch",
function(x, ...) {
standardGeneric("rasterToMatch")
})
#' @param studyArea A `SpatialPolygon*` object that will be sent to `postProcess`.
#'
#' @export
#' @exportMethod rasterToMatch
#' @importFrom raster raster setValues
#' @importFrom reproducible postProcess
#' @rdname rasterToMatch
setMethod("rasterToMatch", signature = "Raster",
definition = function(x, studyArea, ...) {
rtm <- raster::raster(x)
rtm <- setValues(rtm, 1L)
postProcess(rtm, studyArea = studyArea, ...)
})
#' @param rasterToMatch The raster to match in a `fasterize` call.
#'
#' @export
#' @exportMethod rasterToMatch
#' @importFrom fasterize fasterize
#' @importFrom sf st_as_sf
#' @rdname rasterToMatch
setMethod("rasterToMatch", signature = "SpatialPolygonsDataFrame",
definition = function(x, studyArea, rasterToMatch, ...) {
numPolys <- length(x)
xDF <- as.data.frame(x)
x$numPolys <- seq_len(numPolys)
xDF <- data.frame(ID = x$numPolys, xDF)
rtm <- fasterize::fasterize(sf::st_as_sf(x),
field = "numPolys",
rasterToMatch)
levels(rtm) <- xDF
rtm[is.na(rasterToMatch[])] <- NA
rtm
})
#' Normalize each layer of a `RasterStack`
#'
#' Rescales the values of of each `RasterLayer` between `[0,1]`.
#'
#' @param x A `RasterStack` object.
#'
#' @author Tati Micheletti
#' @export
#' @importFrom amc rescale
#' @importFrom raster stack
normalizeStack <- function(x) {
normalized <- lapply(names(x), function(layer) {
lay <- amc::rescale(x[[layer]])
names(lay) <- layer
return(lay)
})
names(normalized) <- names(x)
return(raster::stack(normalized))
}