-
Notifications
You must be signed in to change notification settings - Fork 294
/
stars.R
410 lines (382 loc) · 16.5 KB
/
stars.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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
#' functions to interact with gdal not meant to be called directly by users (but e.g. by stars::read_stars)
#'
#' @param x character vector, possibly of length larger than 1 when more than one raster is read
#' @param ... ignored
#' @param options character; raster layer read options
#' @param driver character; driver short name; when empty vector, driver is auto-detected.
#' @param read_data logical; if \code{FALSE}, only the imagery metadata is returned
#' @param NA_value (double) non-NA value to use for missing values; if \code{NA}, when writing missing values are not specially flagged in output dataset, when reading the default (dataset) missing values are used (if present / set).
#' @param RasterIO_parameters list with named parameters to GDAL's RasterIO; see the stars::read_stars documentation.
#' @details These functions are exported for the single purpose of being used by package stars, they are not meant to be used directly and may change or disappear without prior notice or deprecation warnings.
#' @name gdal
#' @keywords internal
#' @export
gdal_read = function(x, ..., options = character(0), driver = character(0), read_data = TRUE, NA_value = NA_real_,
RasterIO_parameters = list()) {
if (is.numeric(read_data)) {
max_cells = as.double(read_data)
read_data = FALSE
} else
max_cells = as.double(-1.)
CPL_read_gdal(as.character(x), as.character(options), as.character(driver),
as.logical(read_data), as.double(NA_value), RasterIO_parameters, max_cells)
}
#' @rdname gdal
#' @export
#' @param type gdal write type
#' @param geotransform length 6 numeric vector with GDAL geotransform parameters.
#' @param update logical; \code{TRUE} if in an existing raster file pixel values shall be updated.
#' @param scale_offset length 2 numeric; contains scale and offset values
gdal_write = function(x, ..., file, driver = "GTiff", options = character(0), type = "Float32",
NA_value = NA_real_, geotransform, update = FALSE, scale_offset = c(1.0, 0.0)) {
if (!requireNamespace("stars", quietly = TRUE))
stop("stars required: install that first") # nocov
if (any(scale_offset != c(1.0, 0.0)) && packageVersion("sf") <= "1.0-9")
warning("handling scale_offset requires sf > 1.0-9")
d = stars::st_dimensions(x)
xydims = attr(d, "raster")$dimensions
if (!all.equal(match(xydims, names(d)), 1:2))
stop("x and y raster dimensions need to be in place 1 and 2")
from = c(d[[1]]$from, d[[2]]$from) - 1
dims = c(d[[1]]$to, d[[2]]$to)
if (length(d) == 3)
dims = c(dims, d[[3]]$to - d[[3]]$from + 1)
if (inherits(x, "stars_proxy")) {
mat = matrix(0, 0, 0) # nocov start
only_create = TRUE # don't write any pixel data
if (!all(from == 0))
warning("writing raster to original size") # otherwise, geotransform needs to be modified
from = c(0, 0) # nocov end
} else {
mat = x[[1]]
dm = dim(mat)
if (is.factor(mat)) {
rgba = NULL
ex = attr(mat, "exclude")
if (is.null(ex))
lev = c("", levels(mat)) # add "" for value 0: R factors start at 1
else {
if (any(ex)) {
lev = vector("character", length(ex)) # fills with ""
lev[!ex] = levels(mat)
rgba = if (!is.null(co <- attr(mat, "rgba"))) {
n = length(ex)
coltab = cbind(rep(0., n), rep(0, n), rep(0, n), rep(255, n))
coltab[!ex,] = co
coltab
}
values = which(!ex) - 1
mat = values[as.numeric(mat)]
} else
lev = levels(mat)
}
mat = structure(mat, class = NULL, levels = lev, dim = dm, rgba = rgba)
}
only_create = FALSE # write x too
if (! update) {
if (!all(from == 0))
stop("cannot write sub-rasters only")
if (!all(dims == dm))
stop("dimensions don't match")
}
dim(mat) = c(dm[1], prod(dm[-1])) # flatten to 2-D matrix
}
if (length(dims) == 2)
dims = c(dims, 1) # one band
else if (is.character(d[[3]]$values)) # add band descriptions?
attr(mat, "descriptions") = d[[3]]$values
CPL_write_gdal(mat, file, driver, options, type, dims, from, geotransform,
st_crs(x)[[2]], as.double(NA_value), scale_offset, create = !update,
only_create = only_create)
}
#' @param gt double vector of length 6
#' @rdname gdal
#' @details gdal_inv_geotransform returns the inverse geotransform
#' @export
gdal_inv_geotransform = function(gt)
CPL_inv_geotransform(as.double(gt))
## @param x two-column matrix with columns and rows, as understood by GDAL; 0.5 refers to the first cell's center;
## FIXME: this is now duplicate in sf and stars
xy_from_colrow = function(x, geotransform, inverse = FALSE) {
# http://www.gdal.org/classGDALDataset.html , search for geotransform:
# 0-based indices:
# Xp = geotransform[0] + P*geotransform[1] + L*geotransform[2];
# Yp = geotransform[3] + P*geotransform[4] + L*geotransform[5];
if (inverse) {
geotransform = gdal_inv_geotransform(geotransform) # nocov start
if (anyNA(geotransform))
stop("geotransform not invertible") # nocov end
}
stopifnot(ncol(x) == 2)
matrix(geotransform[c(1, 4)], nrow(x), 2, byrow = TRUE) +
x %*% matrix(geotransform[c(2, 3, 5, 6)], nrow = 2, ncol = 2)
}
# convert x/y gdal dimensions into a list of points, or a list of square polygons
#' @export
st_as_sfc.dimensions = function(x, ..., as_points = NA, use_cpp = TRUE, which = seq_len(prod(dim(x))),
geotransform) {
if (is.na(as_points))
stop("as_points should be set to TRUE (`points') or FALSE (`polygons')")
xy2sfc = function(cc, dm, as_points) { # form points or polygons from a matrix with corner points
if (as_points)
unlist(apply(cc, 1, function(x) list(st_point(x))), recursive = FALSE)[which]
else {
stopifnot(prod(dm) == nrow(cc))
lst = vector("list", length = prod(dm - 1))
for (y in 1:(dm[2]-1)) {
for (x in 1:(dm[1]-1)) {
i1 = (y - 1) * dm[1] + x # top-left
i2 = (y - 1) * dm[1] + x + 1 # top-right
i3 = (y - 0) * dm[1] + x + 1 # bottom-right
i4 = (y - 0) * dm[1] + x # bottlom-left
lst[[ (y-1)*(dm[1]-1) + x ]] = st_polygon(list(cc[c(i1,i2,i3,i4,i1),]))
}
}
lst[which]
}
}
raster = attr(x, "raster")
xy_names = raster$dimensions
xd = x[[ xy_names[1] ]]
yd = x[[ xy_names[2] ]]
cc = if (!is.na(xd$offset) && !is.na(yd$offset)) {
xy = if (as_points) # grid cell centres:
expand.grid(x = seq(xd$from, xd$to) - 0.5, y = seq(yd$from, yd$to) - 0.5)
else # grid corners: from 0 to n
expand.grid(x = seq(xd$from - 1, xd$to), y = seq(yd$from - 1, yd$to))
xy_from_colrow(as.matrix(xy), geotransform)
} else if (is.null(xd$values) || is.null(yd$values)) { # only one of [xd|yd] has $values:
if (!requireNamespace("stars", quietly = TRUE)) # nocov start
stop("stars required: install that first")
if (! as_points)
stop("st_as_sfc(): mixed regular and rectilinear dimensions only supported if as_points = TRUE")
as.matrix(st_coordinates(x)) # nocov end
} else { # both xd and yd have $values:
expand = function(x) { # might fail on the poles or dateline
d = diff(x)
c(x[1] - 0.5 * d[1], x + 0.5 * c(d, tail(d, 1)))
}
if (raster$curvilinear) { # expand jointly:
if (!as_points && all(dim(xd$values) == dim(x)[xy_names])) { # expand from points to cells/polygons:
xd$values = apply((apply(xd$values, 1, expand)), 1, expand)
yd$values = apply((apply(yd$values, 1, expand)), 1, expand)
}
cbind(as.vector(xd$values), as.vector(yd$values))
} else { # rectlinear: expand independently
if (! as_points) {
xd$values = if (inherits(xd$values, "intervals"))
c(xd$values$start, tail(xd$values$end, 1))
else
expand(xd$values)
yd$values = if (inherits(yd$values, "intervals"))
c(yd$values$start, tail(yd$values$end, 1))
else
expand(yd$values)
} else {
if (inherits(xd$values, "intervals"))
xd$values = 0.5 * (xd$values$start + xd$values$end)
if (inherits(yd$values, "intervals"))
yd$values = 0.5 * (yd$values$start + yd$values$end)
}
as.matrix(expand.grid(x = xd$values, y = yd$values))
}
}
dims = dim(x) + !as_points
if (use_cpp) {
bb = if (cc_has_NAs <- anyNA(cc))
bbox.Mtrx(na.omit(cc))
else
bbox.Mtrx(cc)
structure(CPL_xy2sfc(cc, as.integer(dims), as_points, as.integer(which), cc_has_NAs),
crs = st_crs(xd$refsys), n_empty = 0L, bbox = bb)
} else
st_sfc(xy2sfc(cc, dims, as_points), crs = xd$refsys)
}
#' @details gdal_crs reads coordinate reference system from GDAL data set
#' @param file character; file name
#' @return object of class \code{crs}, see \link{st_crs}.
#' @rdname gdal
#' @export
gdal_crs = function(file, options = character(0)) {
st_crs(CPL_get_crs(file, options)$crs)
}
#' @details get_metadata gets metadata of a raster layer
#' @rdname gdal
#' @export
#' @param domain_item character vector of length 0, 1 (with domain), or 2 (with domain and item); use \code{""} for the default domain, use \code{NA_character_} to query the domain names.
#' @param parse logical; should metadata be parsed into a named list (\code{TRUE}) or returned as character data?
#' @return named list with metadata items
#' @examples
#' \dontrun{
#' f = system.file("tif/L7_ETMs.tif", package="stars")
#' f = system.file("nc/avhrr-only-v2.19810901.nc", package = "stars")
#' gdal_metadata(f)
#' gdal_metadata(f, NA_character_)
#' try(gdal_metadata(f, "wrongDomain"))
#' gdal_metadata(f, c("", "AREA_OR_POINT"))
#' }
gdal_metadata = function(file, domain_item = character(0), options = character(0), parse = TRUE) {
stopifnot(is.character(file))
stopifnot(is.character(domain_item))
stopifnot(length(domain_item) <= 2)
stopifnot(is.character(options))
if (length(domain_item) >= 1 && !is.na(domain_item[1]) &&
!(domain_item[1] %in% CPL_get_metadata(file, NA_character_, options)))
stop("domain_item[1] not found in available metadata domains")
p = CPL_get_metadata(file, domain_item, options)
if (!is.na(domain_item[1]) && parse)
split_strings(p)
else
p
}
split_strings = function(md, split = "=") {
splt = strsplit(md, split)
lst = lapply(splt, function(x) if (length(x) <= 1) NA_character_ else x[[2]])
structure(lst, names = sapply(splt, function(x) x[[1]]), class = "gdal_metadata")
}
#' @param name logical; retrieve name of subdataset? If \code{FALSE}, retrieve description
#' @export
#' @return \code{gdal_subdatasets} returns a zero-length list if \code{file} does not have subdatasets, and else a named list with subdatasets.
#' @rdname gdal
#' @details gdal_subdatasets returns the subdatasets of a gdal dataset
gdal_subdatasets = function(file, options = character(0), name = TRUE) {
if (!("SUBDATASETS" %in% CPL_get_metadata(file, NA_character_, options)))
list()
else {
md = gdal_metadata(file, "SUBDATASETS", options, TRUE)
if (name)
md[seq(1, length(md), by = 2)]
else
md[seq(2, length(md), by = 2)]
}
}
#' @param use_integer boolean; if \code{TRUE}, raster values are read as (and rounded to) unsigned 32-bit integers values; if \code{FALSE} they are read as 32-bit floating points numbers. The former is supposedly faster.
#' @param mask stars object with NA mask (0 where NA), or NULL
#' @param breaks numeric vector with break values for contour polygons (or lines)
#' @param use_contours logical;
#' @param contour_lines logical;
#' @param connect8 logical; if \code{TRUE} use 8 connection algorithm, rather than 4
#' @rdname gdal
#' @export
gdal_polygonize = function(x, mask = NULL, file = tempfile(), driver = "GTiff", use_integer = TRUE,
geotransform, breaks = classInt::classIntervals(na.omit(as.vector(x[[1]])))$brks,
use_contours = FALSE, contour_lines = FALSE, connect8 = FALSE, ...) {
gdal_write(x, file = file, driver = driver, geotransform = geotransform) # nocov start
on.exit(unlink(file))
mask_name = if (!is.null(mask)) {
mask_name = tempfile()
gdal_write(mask, file = mask_name, driver = driver, geotransform = geotransform)
on.exit(unlink(mask_name))
mask_name
} else
character(0)
contour_options = if (use_contours) { # construct contour_options:
nbreaks = breaks
if (max(breaks) == max(x[[1]], na.rm = TRUE)) # expand, because GDAL will not include interval RHS
nbreaks[length(nbreaks)] = breaks[length(breaks)] * 1.01
c(paste0("FIXED_LEVELS=", paste0(nbreaks, collapse = ",")),
"ELEV_FIELD=0", "ELEV_FIELD_MIN=1", "ELEV_FIELD_MAX=2",
paste0("POLYGONIZE=", ifelse(contour_lines, "NO", "YES")))
} else
character(0)
options = if (connect8)
"8CONNECTED=8"
else
character(0)
pol = CPL_polygonize(file, mask_name, "GTiff", "Memory", "foo", options, 0,
contour_options, use_contours, use_integer)
out = process_cpl_read_ogr(pol, quiet = TRUE)
names(out)[1] = names(x)[1]
if (! contour_lines && use_contours) {
# if (out$Min[1] == 0 && out$Min[1] > min(breaks))
# out$Min[1] = -Inf
#
# https://github.com/r-spatial/sf/pull/1608 :
i <- match(out$Max[1], sort(breaks))
out$Min[1] = if (!is.na(i) && i > 1)
sort(breaks)[i - 1]
else
-Inf
out$Max[out$Max == 2^32 - 1] = Inf
f = paste0("[", out$Min, ",", out$Max, ")")
out[[1]] = factor(f, levels = f)
} else
out$Min = out$Max = NULL
out # nocov end
}
#' @param sf object of class \code{sf}
#' @name gdal
#' @export
gdal_rasterize = function(sf, x, gt, file, driver = "GTiff", options = character()) {
gdal_write(x, file = file, driver = driver, geotransform = gt)
geoms = which(sapply(sf, inherits, "sfc"))
values = as.double(t(as.matrix(as.data.frame(sf)[-geoms])))
CPL_rasterize(file, driver, st_geometry(sf), values, options, NA_real_);
}
#' @export
#' @rdname gdal
#' @param f gdal raster data source filename
#' @param pts points matrix
#' @param bilinear logical; use bilinear interpolation, rather than nearest neighbor?
gdal_extract = function(f, pts, bilinear = FALSE) {
CPL_extract(f, pts, as.logical(bilinear))
}
#' @rdname gdal
#' @param file file name
#' @param array_name array name
#' @param offset offset (pixels)
#' @param count number of pixels to read
#' @param step step size (pixels)
#' @param proxy logical; return proxy object?
#' @param debug logical; print debug messages?
#' @export
gdal_read_mdim = function(file, array_name = character(0), options = character(0),
offset = integer(0), count = integer(0), step = integer(0),
proxy = FALSE, debug = FALSE) {
CPL_read_mdim(file, array_name, options, offset, count, step, proxy, debug)
}
#' @rdname gdal
#' @param dimx integer named vector with dimensions of object
#' @param cdl list with variables, each having a named dim attribute
#' @param wkt character; WKT of crs
#' @param xy character; names of the spatial x and y dimension
#' @param root_group_options character; driver specific options regarding the creation of the root group
#' @param options character; driver specific options regarding reading or creating the dataset
#' @param as_float logical; when \code{TRUE} write 4-byte floating point numbers, when \code{FALSE} write 8-byte doubles.
#' @export
gdal_write_mdim = function(file, driver, dimx, cdl, wkt, xy, ...,
root_group_options = character(0), options = character(0),
as_float = TRUE) {
CPL_write_mdim(file, driver, dimx, cdl, wkt, xy, root_group_options, options, as_float)
}
#' @name gdal
#' @param f character; file name
#' @param nxy integer vector of length 2
#' @param values fill value
#' @param crs object of class \code{crs}
#' @param xlim numeric
#' @param ylim numeric
#' @export
gdal_create = function(f, nxy, values, crs, xlim, ylim) {
CPL_create(as.character(f), as.integer(nxy), as.double(values), crs$wkt, as.double(xlim), as.double(ylim))
}
#' Add or remove overviews to/from a raster image
#'
#' add or remove overviews to/from a raster image
#' @param file character; file name
#' @param overviews integer; overview levels
#' @param method character; method to create overview; one of: nearest, average, rms, gauss, cubic, cubicspline, lanczos, average_mp, average_magphase, mode
#' @param layers integer; layers to create overviews for (default: all)
#' @param options character; dataset opening options
#' @param config_options named character vector with GDAL config options, like \code{c(option1=value1, option2=value2)}
#' @param clean logical; if \code{TRUE} only remove overviews, do not add
#' @param read_only logical; if \code{TRUE}, add overviews to another file with extension \code{.ovr} added to \code{file}
#' @return \code{TRUE}, invisibly, on success
#' @seealso \link{gdal_utils} for access to other gdal utilities that have a C API
#' @export
gdal_addo = function(file, overviews = c(2,4,8,16), method = "NEAREST", layers = integer(0),
options = character(0), config_options = character(0), clean = FALSE, read_only = FALSE) {
stopifnot(length(method) == 1, is.character(method), is.numeric(overviews), is.character(config_options))
invisible(CPL_gdaladdo(file, method, as.integer(overviews), as.integer(layers), as.character(options),
config_options, as.logical(clean)[1], as.logical(read_only)[1]))
}